/* s7, a Scheme interpreter
 *
 *   derived from TinyScheme 1.39, but not a single byte of that code remains
 *   SPDX-License-Identifier: 0BSD
 *   SPDX-FileCopyrightText: 2008 Bill Schottstaedt, bil@ccrma.stanford.edu (and others)
 *
 * Bill Schottstaedt, bil@ccrma.stanford.edu
 *
 * Mike Scholz provided the FreeBSD support (complex trig funcs, etc)
 * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, Satoru Matsusaki, and Christos Vagias provided the MS Visual C++ support
 * Kjetil Matheussen provided the mingw support
 *
 * Documentation is in s7.h, s7.html, s7-ffi.html, and s7-scm.html.
 * s7test.scm is a regression test.
 * repl.scm is a vt100-based listener.
 * nrepl.scm is a notcurses-based listener.
 * cload.scm and lib*.scm tie in various C libraries.
 * lint.scm checks Scheme code for infelicities.
 * r7rs.scm implements some of r7rs (small).
 * write.scm currrently has pretty-print.
 * mockery.scm has the mock-data definitions.
 * reactive.scm has reactive-set and friends.
 * stuff.scm has some stuff.
 * profile.scm has code to display profile data.
 * debug.scm has debugging aids.
 * case.scm has case*, an extension of case to pattern matching.
 * timing tests are in the s7 tools directory
 *
 * s7.c is organized as follows:
 *    structs and type flags
 *    internal debugging stuff
 *    constants
 *    GC
 *    stacks
 *    symbols and keywords
 *    lets
 *    continuations
 *    numbers
 *    characters
 *    strings
 *    ports
 *    format
 *    lists
 *    vectors
 *    hash-tables
 *    c-objects
 *    functions
 *    equal?
 *    generic length, copy, reverse, fill!, append
 *    error handlers
 *    sundry leftovers
 *    the optimizers
 *    multiple-values, quasiquote
 *    eval
 *    *s7*
 *    initialization and free
 *    repl
 *
 * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible,
 *   H_* are documentation strings, Q_* are procedure signatures, scheme "?" corresponds to C "is_", scheme "->" to C "_to_",
 *   *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, Inline means always-inline.
 *   In variables, i, j, and k are ints, p is a pair (usually), e is a let (environment), x and y are numbers (usually), o is opt_info*.
 *   Variable and function names use lower case, as do macros that take parameters.  Named constants (via enum or macros) and labels are
 *   in some facsimile of camel-case, as are macro parameters and the type-check macros.  Op names and basic types are in upper case, as
 *   are C/libc stuff like  NULL, FILE*, etc.
 *
 * ---------------- compile time switches ----------------
 */

#if defined __has_include
#  if __has_include ("mus-config.h")
#    include "mus-config.h"
#  endif
#else
#    include "mus-config.h"
#endif

/*
 * Your config file goes here, or just replace that #include line with the defines you need.
 * The compile-time switches involve booleans, complex numbers, and multiprecision arithmetic.
 * Currently we assume we have setjmp.h (used by the error handlers).
 *
 * Complex number support, which is problematic in C++, Solaris, and netBSD
 *   is on the HAVE_COMPLEX_NUMBERS switch. In OSX or Linux, if you're not using C++,
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 1
 *
 *   In g++ I use:
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 0
 *
 *   In Windows and tcc both are 0.
 *
 *   Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so
 *   HAVE_COMPLEX_NUMBERS means we can find
 *      cimag creal cabs csqrt carg conj
 *   and HAVE_COMPLEX_TRIG means we have
 *      cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh
 *
 * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their
 *   argument -- this will be very confusing for the s7 user because, for example, (sqrt -2)
 *   will return something bogus (it might not signal an error).
 *
 * so the incoming (non-s7-specific) compile-time switches are
 *     HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P
 * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead,
 *   the default is to assume that we're running on a 64-bit machine.
 *
 * To get multiprecision arithmetic, set WITH_GMP to 1.
 *   You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later)
 *
 * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__
 *
 * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included.
 * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN,
 *   to use nrepl also define WITH_NOTCURSES
 *
 * -O3 is often slower than -O2 (at least according to callgrind)
 * -march=native seems to improve tree-vectorization which is important in Snd
 * -ffast-math makes a mess of NaNs, and does not appear to be faster
 *   -fno-math-errno -fno-signed-zeros are slower
 *   I also tried -fno-signaling-nans -fno-trapping-math -fassociative-math, but at least one of them is much slower
 * this code doesn't compile anymore in gcc 4.3
 */

#if (defined(__GNUC__) || defined(__clang__) || defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old. clang defines __GNUC__ */
  #define WITH_GCC 1
#else
  #define WITH_GCC 0
#endif
#if (defined(__clang__) && __cplusplus) /* pointless -- this is a moving target */
  #define WITH_CLANG_PP 1
#else
  #define WITH_CLANG_PP 0
#endif


/* ---------------- initial sizes ---------------- */

#ifndef INITIAL_HEAP_SIZE
  #define INITIAL_HEAP_SIZE 64000         /* 29-Jul-21 -- seems faster */
#endif
#define Initial_Heap_Size INITIAL_HEAP_SIZE
/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory.
 * There are many cases where a bigger heap is faster (but hardware cache size probably matters more).
 * The heap size must be a multiple of 32.  Each object takes 48 bytes.  s7 is fine with the initial heap size set to 800.
 */

#ifndef SYMBOL_TABLE_SIZE
  #define SYMBOL_TABLE_SIZE 32749
#endif
#define Symbol_Table_Size SYMBOL_TABLE_SIZE
/* 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)
 * these numbers may be out-dated -- I need to rerun them.
 */

#ifndef INITIAL_STACK_SIZE
  #define INITIAL_STACK_SIZE 4096  /* was 2048 17-Mar-21 */
#endif
#define Initial_Stack_Size INITIAL_STACK_SIZE
/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */

#define Stack_Resize_Trigger 256   /* was Initial_Stack_Size/2 which seems excessive */

#ifndef GC_TEMPS_SIZE
  #define GC_TEMPS_SIZE 256
#endif
#define Gc_Temps_Size GC_TEMPS_SIZE
/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test.
 *    For the FFI, this sets the lag between a call on s7_cons and the first moment when its result
 *    might be vulnerable to the GC.
 */

#ifndef INITIAL_PROTECTED_OBJECTS_SIZE
  #define INITIAL_PROTECTED_OBJECTS_SIZE 16
#endif
#define Initial_Protected_Objects_Size INITIAL_PROTECTED_OBJECTS_SIZE
/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */


/* ---------------- scheme choices ---------------- */

#ifndef DISABLE_DEPRECATED
  #define DISABLE_DEPRECATED 0
#endif
#define Disable_Deprecated DISABLE_DEPRECATED

#ifndef DISABLE_AUTOLOAD
  #define DISABLE_AUTOLOAD 0
#endif
#define Disable_Autoload DISABLE_AUTOLOAD

#ifndef WITH_GMP
  #define WITH_GMP 0
  /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc
   * WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision)
   */
#endif
#define With_Gmp WITH_GMP

#ifndef DEFAULT_BIGNUM_PRECISION
  #define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */
#endif
#define Default_Bignum_Precision DEFAULT_BIGNUM_PRECISION

#ifndef WITH_PURE_S7
  #define WITH_PURE_S7 0
#endif
#define With_Pure_s7 WITH_PURE_S7

#if With_Pure_s7
  #define WITH_EXTRA_EXPONENT_MARKERS 0
  #define WITH_IMMUTABLE_UNQUOTE 1
  /* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values
   *   and a lot more (inexact/exact, integer-length, etc) -- see s7.html.
   */
#endif

#ifndef WITH_R7RS
  #define WITH_R7RS !With_Pure_s7
  /* this also requires (set! (*s7* 'scheme-version) 'r7rs) */
#endif
#define With_r7rs WITH_R7RS

#ifndef WITH_EXTRA_EXPONENT_MARKERS
  #define WITH_EXTRA_EXPONENT_MARKERS 0
#endif
/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */
#define With_Extra_Exponent_Markers WITH_EXTRA_EXPONENT_MARKERS

#ifdef _MSC_VER
  #define MS_Windows 1
#else
  #define MS_Windows 0
#endif

#ifndef WITH_SYSTEM_EXTRAS
  #define WITH_SYSTEM_EXTRAS (!MS_Windows)
  /* this adds several functions that access file info, directories, times, system, etc */
#endif
#define With_System_Extras WITH_SYSTEM_EXTRAS

#ifndef WITH_IMMUTABLE_UNQUOTE
  #define WITH_IMMUTABLE_UNQUOTE 0  /* this removes the name "unquote" */
#endif
#define With_Immutable_Unquote WITH_IMMUTABLE_UNQUOTE

#ifndef WITH_C_LOADER
  #if (WITH_GCC && (!__MINGW32__) && (!__CYGWIN__)) || defined(__TINYC__)
    #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
#define With_C_Loader WITH_C_LOADER

#ifndef WITH_NOTCURSES
  #define WITH_NOTCURSES 0
#endif
#define With_Notcurses WITH_NOTCURSES

#ifndef WITH_HISTORY
  #define WITH_HISTORY 0
  /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */
#endif
#define With_History WITH_HISTORY

#ifndef DEFAULT_HISTORY_SIZE
  #define DEFAULT_HISTORY_SIZE 8
  /* this is the default length of the eval history buffer */
#endif
#define Default_History_Size DEFAULT_HISTORY_SIZE
#if With_History
  #define Max_History_Size 1048576
#endif

#ifndef DEFAULT_PRINT_LENGTH
  #define DEFAULT_PRINT_LENGTH 40 /* (*s7* 'print-length) initial value, was 32 but that's too small 26-May-24 */
#endif
#define Default_Print_Length DEFAULT_PRINT_LENGTH

#ifndef WITH_NUMBER_SEPARATOR
  #define WITH_NUMBER_SEPARATOR 0
#endif
#define With_Number_Separator WITH_NUMBER_SEPARATOR

/* in case mus-config.h forgets these */
#if MS_Windows
  #ifndef HAVE_COMPLEX_NUMBERS
    #define HAVE_COMPLEX_NUMBERS 0
    /* Da Shen adds that you'll need the compiler flag /fp:precise if you're using github actions */
  #endif
  #ifndef HAVE_COMPLEX_TRIG
    #define HAVE_COMPLEX_TRIG 0
  #endif
#else
  #ifndef HAVE_COMPLEX_NUMBERS
    #if __TINYC__ || (__clang__ && __cplusplus) /* clang++ is hopeless */
      #define HAVE_COMPLEX_NUMBERS 0
    #else
      #define HAVE_COMPLEX_NUMBERS 1
    #endif
  #endif
  #if __cplusplus || __TINYC__
    #ifndef HAVE_COMPLEX_TRIG
      #define HAVE_COMPLEX_TRIG 0
    #endif
  #else
    #ifndef HAVE_COMPLEX_TRIG
      #define HAVE_COMPLEX_TRIG 1
    #endif
  #endif
#endif
#define Have_Complex_Numbers HAVE_COMPLEX_NUMBERS
#define Have_Complex_Trig HAVE_COMPLEX_TRIG

#ifndef WITH_MULTITHREAD_CHECKS
  #define WITH_MULTITHREAD_CHECKS 0
  /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */
#endif
#define With_Multithread_Checks WITH_MULTITHREAD_CHECKS

#ifndef WITH_WARNINGS
  #define WITH_WARNINGS 0
  /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */
#endif
#define With_Warnings WITH_WARNINGS

#ifndef S7_DEBUGGING
  #define S7_DEBUGGING 0
#endif
#define s7_Debugging S7_DEBUGGING

#ifndef EVAL_PRINT          /* print info about eval ops */
  #define EVAL_PRINT 0
#endif
#define Eval_Print EVAL_PRINT
#if Eval_Print && !s7_Debugging
  #undef s7_Debugging
  #define s7_Debugging 1
#endif

#ifndef OPT_PRINT           /* print info about opt_* optimizations */
  #define OPT_PRINT 0
#endif
#define Opt_Print OPT_PRINT
#if Opt_Print && !s7_Debugging
  #undef s7_Debugging
  #define s7_Debugging 1
#endif

#ifndef DO_PRINT            /* print info about do_* optimizations */
  #define DO_PRINT 0
#endif
#define Do_Print DO_PRINT
#if Do_Print && !s7_Debugging
  #undef s7_Debugging
  #define s7_Debugging 1
#endif

#ifndef _GNU_SOURCE
  #define _GNU_SOURCE       /* for qsort_r, grumble... */
#endif

#if !MS_Windows
  #include <unistd.h>
  #include <sys/param.h>
  #include <strings.h>
  #include <errno.h>
  #include <locale.h>
#else
  /* in Snd these are in mus-config.h */
  #ifndef MUS_CONFIG_H_LOADED
    #if _MSC_VER < 1900
      #define snprintf _snprintf
    #endif
    #if _MSC_VER > 1200
      #define _CRT_SECURE_NO_DEPRECATE 1
      #define _CRT_NONSTDC_NO_DEPRECATE 1
      #define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1
    #endif
  #endif
  #include <io.h>
  #pragma warning(disable: 4244) /* conversion might cause loss of data warning */
#endif

#if WITH_GCC && (!s7_Debugging)
  #define Inline inline __attribute__((__always_inline__))
#else
  #if MS_Windows
    #define Inline __forceinline
  #else
    #define Inline inline
  #endif
#endif

#ifndef WITH_VECTORIZE
  #define WITH_VECTORIZE 1
#endif
#define With_Vectorize WITH_VECTORIZE

#if (With_Vectorize) && (defined(__GNUC__) && (__GNUC__ >= 5)) /* is this included -in -O2 now? */
  #define Vectorized __attribute__((optimize("tree-vectorize")))
#else
  #define Vectorized
#endif

#if WITH_GCC
  #define Sentinel __attribute__((sentinel))
#else
  #define Sentinel
#endif

#if MS_Windows
  #define no_return _Noreturn /* deprecated in C23 */
#else
  #define no_return __attribute__((noreturn))
  /* this is ok in gcc/g++/clang and tcc; clang++ complains about "noreturn", hence "no_return" */
  /* pure attribute is rarely applicable here, and does not seem to be helpful (maybe safe_strlen) */
#endif

#ifndef S7_ALIGNED
  #define S7_ALIGNED 0
  /* memclr, local_memset, local_strncmp */
#endif
#define s7_Aligned S7_ALIGNED


#include <stdio.h>
#include <limits.h>
#include <ctype.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
/* #include <time.h> */
#include <stdarg.h>
#include <stddef.h>
#include <stdint.h>
#include <inttypes.h>
#include <setjmp.h>

#if MS_Windows || defined(__MINGW32__)
  #define Jmp_Buf       jmp_buf
  #define SetJmp(A, B)  setjmp(A)
  #define LongJmp(A, B) longjmp(A, B)
#else
  #define Jmp_Buf       sigjmp_buf
  #define SetJmp(A, B)  sigsetjmp(A, B)
  #define LongJmp(A, B) siglongjmp(A, B)
  /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??)
   *   unfortunately sigsetjmp is 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 <pthread.h>
#endif

#if __cplusplus
  #include <cmath>
#else
  #include <math.h>
#endif

#include "s7.h"

/* there is also apparently __STDC_NO_COMPLEX__ */
#if WITH_CLANG_PP
  #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y))
#endif
#if Have_Complex_Numbers
  #if __cplusplus
    #include <complex>
    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 <complex.h>
    /* typedef double complex s7_complex; */
    #if defined(__sun) && defined(__SVR4)
      #undef _Complex_I
      #define _Complex_I 1.0i
    #endif
  #endif
  #ifndef CMPLX
    #if (!(defined(__cplusplus))) && (__GNUC__ > 4 || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 7))) && !defined(__INTEL_COMPILER)
      #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y))
    #else
      #define CMPLX(r, i) ((r) + ((i) * (s7_complex)_Complex_I))
    #endif
  #endif
#endif

#if WITH_CLANG_PP
  #define s7_complex_i ((double)1.0i)
#else
#if (defined(__GNUC__))
  #define s7_complex_i 1.0i
#else
  #define s7_complex_i (s7_complex)_Complex_I /* a float, but we want a double */
#endif
#endif

#ifndef M_PI
  #define M_PI 3.1415926535897932384626433832795029L
#endif

#ifndef INFINITY
  #ifndef HUGE_VAL
    #define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */
    /* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */
  #else
    #define INFINITY HUGE_VAL
  #endif
#endif
#define Infinity INFINITY

#ifndef NAN /* deprecated in C23? */
  #define NAN (Infinity / Infinity) /* apparently ieee754 suggests 0.0/0.0 */
#endif
#define Nan NAN

#if ((!__NetBSD__) && (MS_Windows || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L))))
  #define __func__ __FUNCTION__
#endif

#ifndef POINTER_32 /* for testing */
#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__)))
  #define POINTER_32 true
#else
  #define POINTER_32 false
#endif
#endif
#define Pointer_32 POINTER_32

#define Write_Real_Precision 16
#ifdef __TINYC__
  typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken */
#else
  typedef long double long_double;
#endif
typedef uint64_t s7_uint;

#define ld64 PRId64
/* #define lu64 PRIu64 */
#define p64 PRIdPTR

#define Max_Float_Format_Precision 128 /* does this make any sense? 53 bits in mantissa: 16 digits, are the extra digits just garbage? */

/* types */
enum {T_FREE = 0,
      T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL,
      T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX,
      T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR,
      T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR,
      T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, T_RANDOM_STATE, T_CONTINUATION, T_GOTO,
      T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR,
      T_C_MACRO, T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_RST_NO_REQ_FUNCTION,
      Num_Types};
/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */

static const char *s7_type_names[] =
  {"free", "pair", "nil", "unused", "undefined", "unspecified", "eof_object", "boolean", "character", "syntax", "symbol",
   "integer", "ratio", "real", "complex", "big_integer", "big_ratio", "big_real", "big_complex",
   "string", "c_object", "vector", "int_vector", "float_vector", "byte_vector", "complex_vector",
   "catch", "dynamic_wind", "hash_table", "let", "iterator",
   "stack", "counter", "slot", "c_pointer", "output_port", "input_port", "random_state", "continuation", "goto",
   "closure", "closure*", "macro", "macro*", "bacro", "bacro*",
   "c_macro", "c_function*", "c_function", "c_rst_no_req_function",
   };

/* 1:pair, 2:nil, 3:unused, 4:undefined, 5:unspecified, 6:eof, 7:boolean, 8:character, 9:syntax, 10:symbol,
   11:integer, 12:ratio, 13:real, 14:complex, 15:big_integer, 16:big_ratio, 17:big_real, 18:big_complex,
   19:string, 20:c_object, 21:vector, 22:int_vector, 23:float_vector, 24:byte_vector, 25:complex_vector,
   26:catch, 27:dynamic_wind, 28:hash_table, 29:let, 30:iterator,
   31:stack, 32:counter, 33:slot, 34:c_pointer, 35:output_port, 36:input_port, 37:random_state, 38:continuation, 39:goto,
   40:closure, 41:closure_star, 42:macro, 43:macro_star, 44:bacro, 45:bacro_star,
   46:c_macro, 47:c_function_star, 48:c_function, 49:c_rst_no_req_function,
   50:num_types
*/

typedef struct block_t {
  union {
    void *data;
    s7_pointer d_ptr;
    s7_int *i_ptr;
    s7_int tag;
  } dx;
  int32_t index;
  union {
    bool needs_free;
    uint32_t iter_or_size;
  } ln;
  union {
    s7_int size;
    s7_uint usize;
  } sz;
  union {
    struct block_t *next;
    char *documentation;
    s7_pointer ksym;
    s7_uint nx_uint;
    s7_int *ix_ptr;
    struct {
      uint32_t i1, i2;
    } ix;
  } nx;
  union {
    s7_pointer ex_ptr;
    void *ex_info;
    s7_int ckey;
  } ex;
} block_t;

#define Num_Block_Lists 18
#define Top_Block_List 17
#define Block_List 0

#define block_data(P)                    P->dx.data
#define block_index(P)                   P->index
#define block_set_index(P, Index)        P->index = Index
#define block_size(P)                    P->sz.size
#define block_set_size(P, Size)          P->sz.size = Size
#define block_next(P)                    P->nx.next
#define block_info(P)                    P->ex.ex_info

typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry but can use the mallocate functions */
#define hash_entry_key(P)                P->dx.d_ptr
#define hash_entry_value(P)              (P)->ex.ex_ptr
#define hash_entry_set_value(P, Val)     P->ex.ex_ptr = Val
#define hash_entry_next(P)               block_next(P)
#define hash_entry_raw_hash(P)           P->sz.usize         /* block_size(P) */
#define hash_entry_set_raw_hash(P, Hash) P->sz.usize = Hash  /* block_set_size(P, Hash) */

typedef block_t vdims_t;
#define vdims_rank(P)                    P->sz.size
#define vector_elements_should_be_freed(P) P->ln.needs_free
#define vdims_dims(P)                    P->dx.i_ptr
#define vdims_offsets(P)                 P->nx.ix_ptr
#define vdims_original(P)                P->ex.ex_ptr


typedef enum {Token_Eof, Token_Left_Paren, Token_Right_Paren, Token_Dot, Token_Atom, Token_Quote, Token_Double_Quote,
	      Token_Back_Quote, Token_Comma, Token_At_Mark, Token_Sharp_Const,
              Token_Vector, Token_Byte_Vector, Token_Int_Vector, Token_Float_Vector, Token_Complex_Vector} token_t;

typedef enum {No_Article, Indefinite_Article} article_t;
typedef enum {Dwind_Init, Dwind_Body, Dwind_Finish} dwind_t;
enum {No_Safety = 0, Immutable_Vector_Safety, More_Safety_Warnings};  /* (*s7* 'safety) settings, if typedef'd becomes uint32_t (but we want -1) */

typedef struct {
  int32_t (*read_character)(s7_scheme *sc, s7_pointer port);             /* function to read a character, int32_t for EOF */
  void (*write_character)(s7_scheme *sc, uint8_t c, s7_pointer port);    /* function to write a character */
  void (*write_string)(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */
  token_t (*read_semicolon)(s7_scheme *sc, s7_pointer port);             /* internal skip-to-semicolon reader */
  int32_t (*read_white_space)(s7_scheme *sc, s7_pointer port);           /* internal skip white space reader */
  s7_pointer (*read_name)(s7_scheme *sc, s7_pointer port);               /* internal get-next-name reader */
  s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer port);              /* internal get-next-sharp-constant reader */
  s7_pointer (*read_line)(s7_scheme *sc, s7_pointer port, bool eol_case);/* function to read a string up to \n */
  void (*displayer)(s7_scheme *sc, const char *s, s7_pointer port);      /* (display s pt) -- port_write_string without strlen?? */
  void (*close_port)(s7_scheme *sc, s7_pointer port);                    /* close-in|output-port */
} port_functions_t;

typedef struct {
  bool needs_free, is_closed;
  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 {Oft_d_v, Oft_d_vd, Oft_d_vdd, Oft_d_vid, Oft_d_id, Oft_d_7pi, Oft_d_7pii, Oft_d_7piid,
	      Oft_d_ip, Oft_d_pd, Oft_d_7p, Oft_d_7pid, Oft_d, Oft_d_d, Oft_d_dd, Oft_d_7dd, Oft_d_ddd, Oft_d_dddd,
	      Oft_i_i, Oft_i_7i, Oft_i_ii, Oft_i_7ii, Oft_i_iii, Oft_i_7pi, Oft_i_7pii, Oft_i_7piii, Oft_d_p,
	      Oft_b_p, Oft_b_7p, Oft_b_pp, Oft_b_7pp, Oft_b_pp_unchecked, Oft_b_pi, Oft_b_ii, Oft_b_7ii, Oft_b_dd,
	      Oft_p, Oft_p_p, Oft_p_ii, Oft_p_d, Oft_p_dd, Oft_i_7d, Oft_i_7p, Oft_d_7d, Oft_p_pp, Oft_p_ppp, Oft_p_pi, Oft_p_pi_unchecked,
	      Oft_p_ppi, Oft_p_i, Oft_p_pii, Oft_p_pip, Oft_p_pip_unchecked, Oft_p_piip, Oft_b_i, Oft_b_d} opt_func_t;

typedef struct opt_funcs_t {
  opt_func_t typ;
  void *func;
  struct opt_funcs_t *next;
} opt_funcs_t;

typedef struct {
  const char *name;
  int32_t name_length;
  uint32_t class_id;     /* can't use "class" -- confuses g++ */
  const char *doc;
  opt_funcs_t *opt_data; /* vunion-functions (see below) */
  s7_pointer generic_ff, setter, signature, pars, let;
  s7_chooser chooser;
  /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */
  union {
    s7_pointer *arg_defaults;
    s7_pointer bool_setter;
  } dam;
  union {
    s7_pointer *arg_names;
    s7_pointer c_sym;
  } sam;
  union {
    s7_pointer call_args;
    void (*marker)(s7_pointer p, s7_int len);
  } cam;
} c_proc_t; /* 104 = sizeof(c_proc_t), add 8 if wrappers */


typedef struct {
  s7_int type, outer_type;
  s7_pointer scheme_name, getter, setter;
  void (*mark)(void *val);
  void (*free)(void *value);
  bool (*eql)(void *val1, void *val2);
#if !Disable_Deprecated
  char *(*print)(s7_scheme *sc, void *value);
#endif
  s7_pointer (*equal)      (s7_scheme *sc, s7_pointer args);
  s7_pointer (*equivalent) (s7_scheme *sc, s7_pointer args);
  s7_pointer (*ref)        (s7_scheme *sc, s7_pointer args);
  s7_pointer (*set)        (s7_scheme *sc, s7_pointer args);
  s7_pointer (*length)     (s7_scheme *sc, s7_pointer args);
  s7_pointer (*reverse)    (s7_scheme *sc, s7_pointer args);
  s7_pointer (*copy)       (s7_scheme *sc, s7_pointer args);
  s7_pointer (*fill)       (s7_scheme *sc, s7_pointer args);
  s7_pointer (*to_list)    (s7_scheme *sc, s7_pointer args);
  s7_pointer (*to_string)  (s7_scheme *sc, s7_pointer args);
  s7_pointer (*gc_mark)    (s7_scheme *sc, s7_pointer args);
  s7_pointer (*gc_free)    (s7_scheme *sc, s7_pointer args);
} c_object_t;


typedef s7_uint (*hash_map_t)(s7_scheme *sc, s7_pointer table, s7_pointer key);         /* hash-table object->location mapper */
typedef hash_entry_t *(*hash_check_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object equality function */
static hash_map_t default_hash_map[Num_Types];

typedef s7_int (*s7_i_7pi_t)(s7_scheme *sc, s7_pointer p, s7_int i1);
typedef s7_int (*s7_i_7pii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2);
typedef s7_int (*s7_i_7piii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3);
typedef s7_int (*s7_i_iii_t)(s7_int i1, s7_int i2, s7_int i3);
typedef s7_int (*s7_i_7i_t)(s7_scheme *sc, s7_int i1);
typedef s7_int (*s7_i_7ii_t)(s7_scheme *sc, s7_int i1, s7_int i2);
typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2);
typedef bool (*s7_b_7pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2);
typedef bool (*s7_b_7p_t)(s7_scheme *sc, s7_pointer p1);
typedef bool (*s7_b_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i2);
typedef bool (*s7_b_d_t)(s7_double p1);
typedef bool (*s7_b_i_t)(s7_int p1);
typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2);
typedef bool (*s7_b_7ii_t)(s7_scheme *sc, s7_int p1, s7_int p2);
typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2);
typedef s7_pointer (*s7_p_t)(s7_scheme *sc);
typedef s7_pointer (*s7_p_ppi_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1);
typedef s7_pointer (*s7_p_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i1);
typedef s7_pointer (*s7_p_pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2);
typedef s7_pointer (*s7_p_pip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2);
typedef s7_pointer (*s7_p_piip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3);
typedef s7_pointer (*s7_p_i_t)(s7_scheme *sc, s7_int i);
typedef s7_pointer (*s7_p_ii_t)(s7_scheme *sc, s7_int i1, s7_int i2);
typedef s7_pointer (*s7_p_dd_t)(s7_scheme *sc, s7_double x1, s7_double x2);
typedef s7_double (*s7_d_7d_t)(s7_scheme *sc, s7_double p1);
typedef s7_double (*s7_d_7dd_t)(s7_scheme *sc, s7_double p1, s7_double p2);
typedef s7_double (*s7_d_7p_t)(s7_scheme *sc, s7_pointer p1);
typedef s7_double (*s7_d_7pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2);
typedef s7_double (*s7_d_7piid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_double x1);

typedef struct opt_info opt_info;

typedef union {
  s7_int i;
  s7_double x;
  s7_pointer p;
  void *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);
} vunion;
/* libgsl 15 d_i */

#define Num_Vunions 15
struct opt_info {
  vunion v[Num_Vunions];
  s7_scheme *sc;
};

#define q_temp(P) P->v[Num_Vunions - 1]

#if With_Gmp
#define Mpfr_Rndn MPFR_RNDN

typedef struct bigint {mpz_t n; struct bigint *nxt;} bigint;
typedef struct bigrat {mpq_t q; struct bigrat *nxt;} bigrat;
typedef struct bigflt {mpfr_t x; struct bigflt *nxt;} bigflt;
typedef struct bigcmp {mpc_t z; struct bigcmp *nxt;} bigcmp;

typedef struct {
  mpfr_t error, ux, x0, x1;
  mpz_t i, i0, i1, n;
  mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1;
  mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p;
  mpq_t q;
} rat_locals_t;
#endif

typedef intptr_t opcode_t;

typedef struct unlet_entry_t {
  s7_pointer symbol;
  struct unlet_entry_t *next;
} unlet_entry_t;


/* -------------------------------- s7_cell struct -------------------------------- */

typedef struct s7_cell {
  union {
    s7_uint u64_type;             /* type info */
    s7_int s64_type;
    uint8_t type_field;
    struct {
      uint16_t low_bits;          /* 8 bits for type (type_field above, pair?/string? etc, 6 bits in use), 8 flag bits */
      uint16_t mid_bits;          /* 16 more flag bits */
      uint16_t opt_bits;          /* 16 bits for opcode (eval choice), 10 in use) */
      uint16_t high_bits;         /* 16 more flag bits */
    } bits;
  } tf;
  union {

    union {
      s7_int integer_value;       /* integers */
      s7_double real_value;       /* floats */

      struct {                    /* ratios */
	s7_int numerator;
	s7_int denominator;
      } fraction_value;

      union {
#if !WITH_CLANG_PP
	s7_complex z;
#endif
	struct {                  /* complex numbers */
	  s7_double rl;
	  s7_double im;
	} complex_value;
      } cz;

#if With_Gmp
      bigint *bgi;                /* bignums (integer) */
      bigrat *bgr;                /*         (ratio) */
      bigflt *bgf;                /*         (float) */
      bigcmp *bgc;                /*         (complex) */
#endif
    } number;

    struct {                      /* ports */
      port_t *port;
      uint8_t *data;
      s7_int size, point;
      block_t *block;
    } prt;

    struct{                       /* characters */
      uint8_t c, up_c;
      int32_t length;
      bool alpha_c, digit_c, space_c, upper_c, lower_c;
      char c_name[12];
    } chr;

    struct {                      /* c-pointers */
      void *c_pointer;
      s7_pointer c_type, info, weak1, weak2;
    } cptr;

    struct {                      /* vectors */
      s7_int length;
      union {
	s7_pointer *objects;
	s7_int *ints;
	s7_double *floats;
	s7_complex *complexes;
	uint8_t *bytes;
      } elements;
      block_t *block;
      s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_int loc);
      union {
	s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val);
	s7_pointer fset;
      } setv;
    } vector;

    struct {                        /* stacks (internal) struct must match vector above for length/objects/block */
      s7_int length;                /* unused via stk, but punned to vector so not actually unused */
      s7_pointer *objects;
      block_t *block;               /* same as length */
      s7_int top, flags;
    } stk;

    struct {                        /* hash-tables */
      s7_uint mask;
      hash_entry_t **elements;      /* a pointer into block below: takes up a field in object.hasher but is faster (50 in thash) */
      hash_check_t hash_func;
      hash_map_t *loc;
      block_t *block;
    } hasher;

    struct {                        /* iterators */
      s7_pointer seq, cur;
      union {
	s7_int loc;
	s7_pointer slot;            /* let iterator current slow */
      } lc;
      union {
	s7_int len;
	s7_pointer slow;            /* pair iterator cycle check */
	hash_entry_t *entry;        /* hash-table iterator current entry */
      } lw;
      s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator);
    } iter;

    struct {
      c_proc_t *c_proc;             /* C functions, macros */
      s7_function ff;
      s7_int required_args, optional_args, all_args; /* these could be uint32_t */
    } fnc;

    struct {                        /* pairs */
      s7_pointer car, cdr, opt1;
      union
      {
	s7_pointer opt2;
	s7_int n;
      } o2;
      union {
	s7_pointer opt3;
	s7_int n;
	uint8_t opt_type;
      } o3;
    } cons;

    struct {                       /* special purpose pairs (symbol-table etc) */
      s7_pointer unused_car, unused_cdr;
      s7_uint hash;
      const char *fstr;
      s7_uint location;            /* line/file/position, also used in symbol_table as raw_len */
    } sym_cons;

    struct {                       /* scheme functions */
      s7_pointer args, body, 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;
    } string;

    struct {                       /* symbols */
      s7_pointer name, global_slot, local_slot;
      s7_int id;                   /* which let last bound the symbol -- for faster symbol lookup */
      uint32_t ctr;                /* how many times has symbol been bound */
      uint32_t small_symbol_tag;   /* symbol as member of a (small) set (tree-set-memq etc), assumed to be uint32_t in clear_small_symbol_set */
    } sym;
    /* ctr really only has 3 values, 0=declared but no associated value, 1=has first value, >1=given various values
     *   and it's possible to free this field by using 2 bits in the type field (T_Location and T_High_Has_Let_File), but it's slightly slower using bits
     */

    struct {                       /* syntax */
      s7_pointer symbol;
      opcode_t op;
      int32_t min_args, max_args;
      const char *documentation;
      /* 1 unused */
    } syn;

    struct {                       /* slots (bindings) */
      s7_pointer sym, val, nxt, pending_value, expr;  /* pending_value is also the setter field which works by a whisker */
    } slt;

    struct {                       /* lets (environments) */
      s7_pointer slots, nxt;
      s7_int id;                   /* id of rootlet is -1 */
      union {
	struct {
	  s7_pointer function;     /* *function* (symbol) if this is a funclet */
	  uint32_t line, file;     /* *function* location if it is known */
	} efnc;
	struct {
	  s7_pointer dox1, dox2;   /* do loop variables */
	} dox;
	s7_int key;                /* sc->baffle_ctr type */
      } edat;
    } let;

    struct {                       /* special stuff like #<unspecified> */
      s7_pointer car, cdr;         /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */
      s7_int unused_let_id;
      const char *name;
      s7_int len;
    } unq;

    struct {                        /* #<...> */
      char *name;                   /* not const because the GC frees it */
      s7_int len;
      /* 3 unused */
    } undef;

    struct {                        /* #<eof> */
      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 */
    } ctr;

    struct {                        /* random-state */
#if With_Gmp
      gmp_randstate_t state;
#else
      s7_uint seed, carry;
      /* for 64-bit floats we probably need 4 state fields */
#endif
    } rng;

    struct {                        /* additional object types (C) */
      s7_int type;
      void *value;                  /* the value the caller associates with the c_object */
      s7_pointer let;               /* the method list, if any (openlet) */
      s7_scheme *sc;
      /* 1 unused */
    } c_obj;

    struct {                        /* continuations */
      block_t *block;
      s7_pointer stack, op_stack;
      s7_pointer *stack_start, *stack_end;
    } cwcc;

    struct {                        /* call-with-exit */
      s7_uint goto_loc, op_stack_loc;
      bool active;
      s7_pointer name;
      /* 1 unused */
    } rexit;

    struct {                        /* catch */
      s7_uint goto_loc, op_stack_loc;
      s7_pointer tag;
      s7_pointer handler;
      Jmp_Buf *cstack;
    } rcatch; /* C++ reserves "catch" I guess */

    struct {                       /* dynamic-wind */
      s7_pointer in, out, body;
      dwind_t state;               /* this could be three bits in the type field (init, body, finish) */
      /* 1 unused */
    } winder;
  } object;

#if s7_Debugging
  int32_t alloc_line, uses, gc_line, holders, carrier_line;
  s7_int alloc_type, debugger_bits;
  const char *alloc_func, *gc_func, *root;
  s7_pointer holder;
#endif
} s7_cell;


typedef struct s7_big_cell {
  s7_cell cell;
  s7_int big_hloc;
} s7_big_cell;
typedef struct s7_big_cell *s7_big_pointer;

typedef struct heap_block_t {
  intptr_t start, end;
  s7_int offset;
  struct heap_block_t *next;
} heap_block_t;

typedef struct {
  s7_pointer *objs;
  int32_t size, top, ref, size2;
  bool has_hits;
  int32_t *refs;
  s7_pointer cycle_port, init_port;
  s7_int cycle_loc, init_loc, ctr;
  bool *defined;
} shared_info_t;

typedef struct {
  s7_int loc, curly_len, ctr;
  char *curly_str;
  s7_pointer args, orig_str, curly_arg, port, strport;
} format_data_t;

typedef struct gc_obj_t {
  s7_pointer p;
  struct gc_obj_t *nxt;
} gc_obj_t;

typedef struct {
  s7_pointer *list;
  s7_int size, loc;
} gc_list_t;

typedef struct {
  s7_int size, top, excl_size, excl_top;
  s7_pointer *funcs, *let_names, *files;
  s7_int *timing_data, *excl, *lines;
} profile_data_t;

typedef enum {No_Jump, Call_With_Exit_Jump, Throw_Jump, Catch_Jump, Error_Jump, Error_Quit_Jump} jump_loc_t;
typedef enum {No_Set_Jump, Read_Set_Jump, Load_Set_Jump, Dynamic_Wind_Set_Jump, s7_Call_Set_Jump, Eval_Set_Jump} setjmp_loc_t;
#if Eval_Print
  static const char *jump_string[6] = {"No_Jump", "Call_With_Exit_Jump", "Throw_Jump", "Catch_Jump", "Error_Jump", "Error_Quit_Jump"};
#endif


/* -------------------------------- s7_scheme struct -------------------------------- */
struct s7_scheme {
  s7_pointer code;    /* layout of first 4 entries should match stack frame layout */
  s7_pointer curlet;
  s7_pointer args;
  opcode_t cur_op;

  s7_pointer value, cur_code;
  s7_pointer nil;                     /* empty list */
  s7_pointer T;                       /* #t */
  s7_pointer F;                       /* #f */
  s7_pointer undefined;               /* #<undefined> */
  s7_pointer unspecified;             /* #<unspecified> */
  s7_pointer no_value;                /* the (values) value */
  s7_pointer unused;                  /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */

  s7_pointer stack;                   /* stack is a vector */
  uint32_t stack_size;
  s7_pointer *stack_start, *stack_end, *stack_resize_trigger;

  s7_pointer *op_stack, *op_stack_now, *op_stack_end;
  uint32_t op_stack_size, max_stack_size;

  s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top;
  s7_int heap_size, gc_freed, gc_total_freed, max_heap_size, gc_temps_size;
  s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction;
  s7_int gc_calls, gc_total_time, gc_start, gc_end, gc_true_calls, gc_true_total_time;
  heap_block_t *heap_blocks;

#if With_History
  s7_pointer eval_history1, eval_history2, error_history, history_sink, history_pairs, old_cur_code;
  bool using_history1;
#endif

#if With_Multithread_Checks
  int32_t lock_count;
  pthread_mutex_t lock;
#endif

  gc_obj_t *semipermanent_objects, *semipermanent_lets;
  s7_pointer protected_objects, protected_setters, protected_setter_symbols;  /* vectors of gc-protected objects */
  s7_int *protected_objects_free_list;    /* to avoid a linear search for a place to store an object in sc->protected_objects */
  s7_int protected_objects_size, protected_setters_size, protected_setters_loc;
  s7_int protected_objects_free_list_loc;

  s7_pointer symbol_table;
  s7_pointer rootlet, rootlet_slots, shadow_rootlet;
  unlet_entry_t *unlet_entries;       /* original bindings of predefined functions */

  s7_pointer input_port;              /* current-input-port */
  s7_pointer *input_port_stack;       /*   input port stack (load and read internally) */
  uint32_t input_port_stack_size, input_port_stack_loc;

  s7_pointer output_port;             /* current-output-port */
  s7_pointer error_port;              /* current-error-port */
  s7_pointer owlet;                   /* owlet */
  s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */
  s7_pointer standard_input, standard_output, standard_error;

  s7_pointer sharp_readers;           /* the binding pair for the global *#readers* list */
  s7_pointer load_hook;               /* *load-hook* hook object */
  s7_pointer autoload_hook;           /* *autoload-hook* hook object */
  s7_pointer unbound_variable_hook;   /* *unbound-variable-hook* hook object */
  s7_pointer missing_close_paren_hook, rootlet_redefinition_hook;
  s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */
  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 got_tc, got_rec, not_tc, muffle_warnings, symbol_quote, reset_error_hook;
  s7_int rec_tc_args;
  s7_int let_number;
  unsigned char number_separator;
  s7_double default_rationalize_error, equivalent_float_epsilon;
  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, do_unspecified, 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;

  int32_t float_format_precision;
  vdims_t *wrap_only;

  char *typnam;
  int32_t typnam_len, print_width;
  s7_pointer *singletons;
  block_t *unentry;                   /* hash-table lookup failure indicator */

  #define Initial_File_Names_Size 8
  s7_pointer *file_names;
  int32_t file_names_size, file_names_top;

  #define Initial_Strbuf_Size 1024
  s7_int strbuf_size;
  char *strbuf;

  char *read_line_buf;
  s7_int read_line_buf_size;

#define WITH_T4_N false /* is sc->t4* independent of sc->t3*? */

  s7_pointer v, w, x, y, z;
  s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, read_dims;
  s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, t4_1, u1_1;
#if WITH_T4_N
  s7_pointer t4_2, t4_3, t4_4;
#else
  #define t4_2 t3_1
  #define t4_3 t3_2
  #define t4_4 t3_3
#endif
  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 */

  Jmp_Buf *Goto_Start;
  bool longjmp_ok;
  setjmp_loc_t setjmp_loc;

  void (*begin_hook)(s7_scheme *sc, bool *val);
  opcode_t begin_op;

  bool debug_or_profile, profiling_gensyms;
  s7_int current_line, s7_call_line, debug, profile, profile_position;
  s7_pointer profile_prefix;
  profile_data_t *profile_data;
  const char *current_file, *s7_call_file, *s7_call_name;

  shared_info_t *circle_info;
  format_data_t **fdats;
  int32_t num_fdats, safety;
  gc_list_t *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables;
  gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, *weak_hash_iterators, *opt1_funcs;
#if With_Gmp
  gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes, *big_random_states;
  mpz_t mpz_1, mpz_2, mpz_3, mpz_4;
  mpq_t mpq_1, mpq_2, mpq_3;
  mpfr_t mpfr_1, mpfr_2, mpfr_3;
  mpc_t mpc_1, mpc_2;
  rat_locals_t *ratloc;
  bigint *bigints;
  bigrat *bigrats;
  bigflt *bigflts;
  bigcmp *bigcmps;
#endif
  s7_pointer *setters;
  s7_int setters_size, setters_loc;
  s7_pointer *tree_pointers;
  int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, num_to_str_size;
  s7_pointer format_ports;
  uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k, 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;
  const char *big_symbol_set_func, *small_symbol_set_func;
#endif
  int32_t bignum_precision;
  s7_int baffle_ctr, map_call_ctr;
  s7_pointer default_random_state;

  s7_pointer sort_body, sort_begin, sort_v1, sort_v2;
  opcode_t sort_op;
  s7_int sort_body_len;
  s7_b_7pp_t sort_f;
  opt_info *sort_o;
  bool (*sort_fb)(opt_info *o);

  #define Int_To_Str_Size 32
  char int_to_str1[Int_To_Str_Size], int_to_str2[Int_To_Str_Size], int_to_str3[Int_To_Str_Size], int_to_str4[Int_To_Str_Size], int_to_str5[Int_To_Str_Size];

  s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, apply_values_symbol, arity_symbol,
             ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol, autoload_symbol, autoloader_symbol,
             bacro_symbol, bacro_star_symbol, bignum_symbol, byte_vector_symbol, byte_vector_ref_symbol, byte_vector_set_symbol, byte_vector_to_string_symbol,
             c_pointer_symbol, c_pointer_info_symbol, c_pointer_to_list_symbol, c_pointer_type_symbol, c_pointer_weak1_symbol, c_pointer_weak2_symbol,
             caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol,
             caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol,
             call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol,
             call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol,
             catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol,
             cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol,
             ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol,
             char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol,
             close_output_port_symbol, complex_symbol, complex_vector_ref_symbol, complex_vector_set_symbol, complex_vector_symbol,
             cond_expand_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol,
             curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol, cyclic_sequences_symbol,
             denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol,
             num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exit_symbol,
             exp_symbol, expansion_symbol, expansion_star_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, goto_is_active_symbol, gt_symbol,
             hash_table_entries_symbol, hash_table_key_typer_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol,
             hash_table_value_typer_symbol, help_symbol, hook_functions_symbol,
             imag_part_symbol, immutable_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol,
             integer_decode_float_symbol, integer_to_char_symbol,
             is_aritable_symbol, is_bignum_symbol, is_boolean_symbol, is_byte_symbol, is_byte_vector_symbol,
             is_c_object_symbol, c_object_let_symbol, c_object_type_symbol, is_c_pointer_symbol,
             is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol, is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol,
             is_complex_symbol, is_complex_vector_symbol, is_constant_symbol,
             is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol,
             is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_funclet_symbol,
             is_gensym_symbol, is_goto_symbol, is_hash_table_symbol, is_immutable_symbol,
             is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol,
             is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_equivalent_symbol, is_nan_symbol, is_negative_symbol,
             is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol,
             is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol,
             is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_subvector_symbol,
             is_symbol_symbol, is_syntax_symbol, is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol,
             is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol, is_integer_or_number_at_end_symbol,
             is_unspecified_symbol, is_undefined_symbol,
             iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol,
             keyword_to_symbol_symbol,
             lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol,
             let_set_symbol, let_temporarily_symbol, libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, list_values_symbol,
             load_path_symbol, load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol,
             local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol,
             macro_symbol, macro_star_symbol, magnitude_symbol,
             make_byte_vector_symbol, make_complex_vector_symbol, make_float_vector_symbol, make_hash_table_symbol,
             make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_symbol, make_list_symbol, make_string_symbol,
             make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol, multiply_symbol,
             name_symbol, nan_symbol, nan_payload_symbol, newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol,
             object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_function_symbol, open_input_string_symbol,
             open_output_file_symbol, open_output_function_symbol, open_output_string_symbol, openlet_symbol, outlet_symbol, owlet_symbol,
             pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol,
             port_file_symbol, port_position_symbol, port_string_symbol, procedure_source_symbol, provide_symbol,
             qq_append_symbol, quotient_symbol,
             random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol, read_bytes_symbol,
             read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, reader_cond_symbol, real_part_symbol, remainder_symbol,
             require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol,
             setter_symbol, set_car_symbol, set_cdr_symbol,
             set_current_error_port_symbol, set_current_input_port_symbol, set_current_output_port_symbol,
             signature_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol,
             stacktrace_symbol, string_append_symbol, string_copy_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol,
             string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol,
             string_set_symbol, string_symbol, string_to_keyword_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol,
             sublet_symbol, substring_symbol, substring_uncopied_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol,
             symbol_symbol, symbol_to_dynamic_value_symbol, symbol_initial_value_symbol,
             symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol,
             tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol,
             tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol, type_name_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_bytes_symbol, write_char_symbol, write_string_symbol, write_symbol;
  s7_pointer hash_code_symbol, dummy_equal_hash_table, features_setter;
#if !With_Pure_s7
  s7_pointer char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, char_ci_leq_symbol, char_ci_lt_symbol, integer_length_symbol,
             is_char_ready_symbol, let_to_list_symbol, list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, string_ci_eq_symbol,
             string_ci_geq_symbol, string_ci_gt_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_length_symbol,
             string_to_list_symbol, vector_length_symbol, vector_to_list_symbol;
#endif
#if With_r7rs
  s7_pointer unlink_symbol, access_symbol, time_symbol, clock_gettime_symbol, getenvs_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,
             global_string_copy, initial_string_copy, global_delay, initial_delay, delay_symbol, saved_sharp_readers;

  /* 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, duplicate_identifier_symbol, else_symbol, feed_to_symbol, format_error_symbol, if_keyword, if_symbol, immutable_error_symbol,
             invalid_exit_function_symbol, io_error_symbol, lambda_star_symbol, lambda_symbol, let_star_symbol, let_symbol,
             letrec_star_symbol, letrec_symbol, macroexpand_symbol, missing_method_symbol, no_setter_symbol, number_to_real_symbol, or_symbol,
             out_of_memory_symbol, out_of_range_symbol, profile_in_symbol, quasiquote_function, quasiquote_symbol, quote_function, quote_symbol,
             read_error_symbol, readable_keyword, rest_keyword, set_symbol, string_read_error_symbol, symbol_table_symbol,
             syntax_error_symbol, trace_in_symbol, type_symbol, unbound_variable_symbol, unless_symbol,
             unquote_symbol, value_symbol, when_symbol, with_baffle_symbol, with_let_symbol, write_keyword,
             wrong_number_of_args_symbol, wrong_type_arg_symbol;

  /* signatures of sequences used as applicable objects: ("hi" 1) */
  s7_pointer  byte_vector_signature, c_object_signature, float_vector_signature, hash_table_signature, int_vector_signature,
             let_signature, pair_signature, string_signature, vector_signature, complex_vector_signature;
  /* common signatures */
  s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_f, pcl_i, pcl_n, pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, pl_nn;

  /* optimizer s7_functions */
  s7_pointer add_1x, add_2, add_2_ints, add_3, add_4, add_i_random, add_x1, append_2, ash_ic, ash_ii, bv_ref_2, bv_ref_3, bv_set_3,
             cdr_let_ref, cdr_let_set, char_equal_2, char_greater_2, char_less_2, char_position_csi, complex_wrapped, curlet_ref, cv_ref_2, cv_set_3,
             display_2, display_f, dynamic_wind_body, dynamic_wind_init, dynamic_wind_unchecked,
             format_as_objstr, format_f, format_just_control_string, format_no_column, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, gcd_2, 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, write_char_c;

  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, fileno_symbol, function_symbol, info_symbol,
             is_mutable_symbol, line_symbol, open_symbol, original_vector_symbol, pointer_symbol, port_type_symbol, position_symbol,
             sequence_symbol, setters_symbol, size_symbol, source_symbol, weak_symbol;

  s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol, getenv_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;

  #define Num_Safe_Prelists 8
  #define Num_Safe_Lists 32               /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test, > 16 doesn't happen much */
  s7_pointer safe_lists[Num_Safe_Lists];
  int32_t current_safe_list;
#if s7_Debugging
  s7_int safe_list_uses[Num_Safe_Lists];
  int32_t *tc_rec_calls;
  bool printing_gc_info;
  s7_int blocks_allocated, format_ports_allocated, c_functions_allocated;
  s7_int blocks_borrowed[Num_Block_Lists], blocks_freed[Num_Block_Lists], blocks_mallocated[Num_Block_Lists];
  s7_int string_wrapper_allocs, integer_wrapper_allocs, real_wrapper_allocs, complex_wrapper_allocs, c_pointer_wrapper_allocs, let_wrapper_allocs, slot_wrapper_allocs;
#endif

  int32_t **current_distance; /* levenshtein data */
  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;

  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 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? */


static no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info);
static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len);
static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1);


#if s7_Debugging
  static void gdb_break(void) {};
#endif

#ifndef DISABLE_FILE_OUTPUT
  #define DISABLE_FILE_OUTPUT 0
#endif
#define Disable_File_Output DISABLE_FILE_OUTPUT

#if s7_Debugging || Disable_File_Output || Pointer_32
  static s7_scheme *cur_sc = NULL;
#endif
#if s7_Debugging || ((Disable_File_Output || Pointer_32) && (!WITH_GCC))
  static s7_scheme *original_cur_sc = NULL;
#endif

#if Disable_File_Output
static FILE *old_fopen(const char *pathname, const char *mode) {return(fopen(pathname, mode));}

#if !WITH_GCC
/* I assume that MS C can't handle the ({...}) business (WITH_GCC include clang and tinyc) */
#define fwrite local_fwrite
static size_t local_fwrite(const void *ptr, size_t size, size_t nmemb, FILE *stream)
{
  error_nr(cur_sc, cur_sc->io_error_symbol,
	   set_elist_1(cur_sc, wrap_string(cur_sc, "writing a file is not allowed in this version of s7", 51)));
  return(0);
}
static FILE *local_fopen(const char *pathname, const char *mode)
{
  if ((mode[0] == 'w') || (mode[0] == 'a'))
    error_nr(cur_sc, cur_sc->io_error_symbol,
	     set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51)));
  return(old_fopen(pathname, mode));
}
#else
#define fwrite(Ptr, Size, N, Stream) ({error_nr(sc, sc->io_error_symbol, set_elist_1(sc, wrap_string(sc, "writing a file is not allowed in this version of s7", 51))); 0;})
#define fopen(Path, Mode) \
  ({if ((Mode[0] == 'w') || (Mode[0] == 'a')) \
      error_nr(sc, sc->io_error_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51))); \
    old_fopen(Path, Mode);})
#endif
#endif /* Disable_File_Output */

#if Pointer_32
/* passing in sc here gloms up the 64-bit code intolerably -- 32-bit users will just have to live with cur_sc! */
static void *Malloc(size_t bytes)
{
  void *p = malloc(bytes);
  if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "malloc failed", 13)));
  return(p);
}

static void *Calloc(size_t nmemb, size_t size)
{
  void *p = calloc(nmemb, size);
  if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "calloc failed", 13)));
  return(p);
}

static void *Realloc(void *ptr, size_t size)
{
  void *p = realloc(ptr, size);
  if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "realloc failed", 14)));
  return(p);
}
#else
#define Malloc(Size)       malloc(Size)
#define Calloc(N, Size)    calloc(N, Size)
#define Realloc(Ptr, Size) realloc(Ptr, Size)
#endif


/* -------------------------------- mallocate -------------------------------- */
static void add_saved_pointer(s7_scheme *sc, void *p)
{
  if (sc->saved_pointers_loc == sc->saved_pointers_size)
    {
      sc->saved_pointers_size *= 2;
      sc->saved_pointers = (void **)Realloc(sc->saved_pointers, sc->saved_pointers_size * sizeof(void *));
    }
  sc->saved_pointers[sc->saved_pointers_loc++] = p;
}

#define Intlen_Bits_Size 256
static const int32_t intlen_bits[Intlen_Bits_Size] =
  {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
   6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
   7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
   7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
   8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
   8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
   8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
   8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8};

static void memclr(void *s, size_t n)
{
  uint8_t *s2;
#if s7_Aligned
  s2 = (uint8_t *)s;
#else
#if (defined(__x86_64__) || defined(__i386__))
  if (n >= 8)
    {
      s7_int *s1 = (s7_int *)s;
      size_t n8 = n >> 3;
      do {*s1++ = 0;} while (--n8 > 0); /* Loop_4 here is slower */
      n &= 7;
      s2 = (uint8_t *)s1;
    }
  else s2 = (uint8_t *)s;
#else
  s2 = (uint8_t *)s;
#endif
#endif
  while (n > 0)
    {
      *s2++ = 0;
      n--;
    }
}

#define Loop_4(Code) do {Code; Code; Code; Code;} while (0)
#define Loop_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0)
#define Step_8(Var) (((Var) & 0x7) == 0)
#define Step_64(Var) (((Var) & 0x3f) == 0)

#if Pointer_32
#define memclr64 memclr
#else
static Vectorized void memclr64(void *p, size_t bytes)
{
  const size_t n = bytes >> 3;
  s7_int *vals = (s7_int *)p;
  for (size_t i = 0; i < n; )
    Loop_8(vals[i++] = 0);
}
#endif

static void init_block_lists(s7_scheme *sc)
{
  for (int32_t i = 0; i < Num_Block_Lists; i++)
    sc->block_lists[i] = NULL;
#if s7_Debugging
  sc->blocks_allocated = 0;
  for (int32_t i = 0; i < Num_Block_Lists; i++)
    sc->blocks_borrowed[i] = 0;
#endif
}

static inline void liberate(s7_scheme *sc, block_t *blk)
{
#if s7_Debugging
  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;
	}
      block_next(blk) = (struct block_t *)sc->block_lists[Block_List];
      sc->block_lists[Block_List] = blk;
    }
}

static inline 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;
}

static void fill_block_list(s7_scheme *sc)
{
  #define Block_Malloc_Size 256
  block_t *b = (block_t *)Malloc(Block_Malloc_Size * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */
#if s7_Debugging
  sc->blocks_allocated += Block_Malloc_Size;
#endif
  add_saved_pointer(sc, b);
  sc->block_lists[Block_List] = b;
  for (int32_t i = 0; i < Block_Malloc_Size - 1; b++, i++)
    block_next(b) = (block_t *)(b + 1);
  block_next(b) = NULL;
}

static inline block_t *mallocate_block(s7_scheme *sc)
{
  block_t *p;
  if (!sc->block_lists[Block_List])
    fill_block_list(sc);                /* this is much faster than allocating blocks as needed */
  p = sc->block_lists[Block_List];
  sc->block_lists[Block_List] = (block_t *)(block_next(p));
  block_set_index(p, Block_List);
  return(p);
}

static inline char *permalloc(s7_scheme *sc, size_t len)
{
  #define Alloc_String_Size (65536 * 8) /* going up to 16 made no difference in timings */
  #define Alloc_Max_String (512 * 8)    /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */
  size_t next_k;

  len = (len + 7) & (~7);               /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */
  next_k = sc->alloc_string_k + len;
  if (next_k > Alloc_String_Size)
    {
      if (len >= Alloc_Max_String)
	{
	  char *result = (char *)Malloc(len);
	  add_saved_pointer(sc, result);
	  return(result);
	}
      sc->alloc_string_cells = (char *)Malloc(Alloc_String_Size); /* get a new block */
      add_saved_pointer(sc, sc->alloc_string_cells);
      sc->alloc_string_k = 0;
      next_k = len;
    }
  {
    char *result = &(sc->alloc_string_cells[sc->alloc_string_k]);
    sc->alloc_string_k = next_k;
    return(result);
  }
}

static Inline block_t *inline_mallocate(s7_scheme *sc, size_t bytes)
{
  block_t *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 <= Intlen_Bits_Size)
	    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]++;
#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.
		   */
#if s7_Debugging
		  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);
#if s7_Debugging
	  sc->blocks_mallocated[index]++;
#endif
	}}
  else
    {
#if s7_Debugging
      sc->blocks_mallocated[Block_List]++;
#endif
      blk = mallocate_block(sc);
    }
  block_set_size(blk, bytes);
  return(blk);
}

static block_t *mallocate(s7_scheme *sc, size_t bytes) {return(inline_mallocate(sc, bytes));}

static block_t *callocate(s7_scheme *sc, size_t bytes)
{
  block_t *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);
}

static 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
 */


/* -------------------------------------------------------------------------------- */
typedef enum {p_Display, p_Write, p_Readable, p_Key, p_Code} use_write_t;

/* these are constants (hence the upper case) */
static s7_pointer Too_Many_Arguments_String, Not_Enough_Arguments_String, Cant_Bind_Immutable_String,
  A_Boolean_String, A_Byte_Vector_String, A_Format_Port_String, A_Let_String, A_List_String, A_Non_Constant_Symbol_String,
  A_Non_Negative_Integer_String, A_Normal_Procedure_String, A_Normal_Real_String, A_Number_String, A_Procedure_String, A_Procedure_Or_A_Macro_String,
  A_Proper_List_String, A_Random_State_Object_String, A_Rational_String, A_Sequence_String, A_Symbol_String, A_Thunk_String, A_Valid_Radix_String,
  An_Association_List_String, An_Eq_Func_String, An_Input_File_Port_String, An_Input_Port_String, An_Input_String_Port_String, An_Open_Input_Port_String,
  An_Open_Output_Port_String, An_Output_Port_Or_F_String, An_Output_File_Port_String, An_Output_Port_String, An_Output_String_Port_String,
  An_Unsigned_Byte_String, Caaar_A_List_String, Caadr_A_List_String, Caar_A_List_String, Cadar_A_List_String, Caddr_A_List_String,
  Cadr_A_List_String, Car_A_List_String, Cdaar_A_List_String, Cdadr_A_List_String, Cdar_A_List_String, Cddar_A_List_String,
  Cdddr_A_List_String, Cddr_A_List_String, Cdr_A_List_String, Immutable_Error_String, It_Is_Infinite_String, It_Is_Nan_String,
  It_Is_Negative_String, It_Is_Too_Large_String, It_Is_Too_Small_String, Parameter_Set_Twice_String, Result_Is_Too_Large_String,
  Something_Applicable_String, Too_Many_Indices_String, Intermediate_Too_Large_String,
  Format_String_1, Format_String_2, Format_String_3, Format_String_4, Keyword_Value_Missing_String;

static bool t_number_p[Num_Types], t_small_real_p[Num_Types], t_rational_p[Num_Types], t_real_p[Num_Types], t_big_number_p[Num_Types];
static bool t_simple_p[Num_Types], t_structure_p[Num_Types], t_immutable_p[Num_Types], t_procedure_p[Num_Types], t_applicable_p[Num_Types];
static bool t_simpler_p[Num_Types], t_any_macro_p[Num_Types], t_any_closure_p[Num_Types], t_has_closure_let[Num_Types];
static bool t_mappable_p[Num_Types], t_sequence_p[Num_Types], t_vector_p[Num_Types], t_ignores_immutable_p[Num_Types];
#if s7_Debugging
static bool t_ext_p[Num_Types], t_exs_p[Num_Types];    /* make sure internal types don't leak out */
#endif

static void init_types(void)
{
  for (int32_t i = 0; i < Num_Types; i++)
    {
      t_any_closure_p[i] = false;
      t_any_macro_p[i] = false;
      t_applicable_p[i] = false;
      t_has_closure_let[i] = false;
      t_immutable_p[i] = true;
      t_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_simpler_p[i] = false;
      t_small_real_p[i] = false;
      t_structure_p[i] = false;
      t_vector_p[i] = false;
      t_ignores_immutable_p[i] = false;
#if s7_Debugging
      t_ext_p[i] = false;
      t_exs_p[i] = false;
#endif
    }
  {
    const int32_t nums[8] = {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX};
    for (int32_t i = 0; i < 8; i++) t_number_p[nums[i]] = true;
  }

  t_rational_p[T_INTEGER] = true;
  t_rational_p[T_RATIO] = true;
  t_rational_p[T_BIG_INTEGER] = true;
  t_rational_p[T_BIG_RATIO] = true;

  t_small_real_p[T_INTEGER] = true;
  t_small_real_p[T_RATIO] = true;
  t_small_real_p[T_REAL] = true;

  t_real_p[T_INTEGER] = true;
  t_real_p[T_RATIO] = true;
  t_real_p[T_REAL] = true;
  t_real_p[T_BIG_INTEGER] = true;
  t_real_p[T_BIG_RATIO] = true;
  t_real_p[T_BIG_REAL] = true;

  t_big_number_p[T_BIG_INTEGER] = true;
  t_big_number_p[T_BIG_RATIO] = true;
  t_big_number_p[T_BIG_REAL] = true;
  t_big_number_p[T_BIG_COMPLEX] = true;

  {
    const int32_t recs[8] = {T_PAIR, T_VECTOR, T_HASH_TABLE, T_SLOT, T_LET, T_ITERATOR, T_C_OBJECT, T_C_POINTER};
    for (int32_t i = 0; i < 8; i++) t_structure_p[recs[i]] = true;
  }
  {
    const int32_t seqs[11] = {
      T_NIL, T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_C_OBJECT};
    /* this assumes the object has a length method? */
    for (int32_t i = 0; i < 11; i++) t_sequence_p[seqs[i]] = true;
  }
  {
    const int32_t maps[18] = {
      T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE,
      T_LET, T_C_OBJECT, T_ITERATOR, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, T_CLOSURE, T_CLOSURE_STAR};
    for (int32_t i = 0; i < 18; i++) t_mappable_p[maps[i]] = true;
  }
  {
    const int32_t appls[24] = {
      T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR,
      T_HASH_TABLE, T_ITERATOR, T_LET, T_C_OBJECT, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR,
      T_SYNTAX, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION,
      T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION};
    for (int32_t i = 0; i < 24; i++) t_applicable_p[appls[i]] = true;
  }
  {
    const int32_t immuts[15] = {
      T_PAIR, T_UNDEFINED, T_SYMBOL, T_STRING, T_C_OBJECT, T_C_POINTER, T_VECTOR, T_FLOAT_VECTOR, T_INT_VECTOR,
      T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_SLOT, T_RANDOM_STATE};
    for (int32_t i = 0; i < 15; i++) t_immutable_p[immuts[i]] = false;
    /* T_ITERATOR, T_INPUT_PORT, T_OUTPUT_PORT ?? */
  }
  {
    const int32_t vecs[5] = {T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR};
    for (int32_t i = 0; i < 5; i++) t_vector_p[vecs[i]] = true;
  }
  {
    const int32_t procs[7] = {T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION};
    for (int32_t i = 0; i < 7; i++) t_procedure_p[procs[i]] = true;
  }
  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 #<undefined> itself will work with eq? */
  /* T_LET needs let_equal in member et al, 29-Nov-22.  Also not sure about ports. */
  {
    const int32_t simps[12] = {T_NIL, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYMBOL, T_SYNTAX,
			       T_C_MACRO, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_INPUT_PORT, T_OUTPUT_PORT};
    for (int32_t i = 0; i < 12; i++) {t_simple_p[simps[i]] = true; t_simpler_p[simps[i]] = true;}
    t_simpler_p[T_UNSPECIFIED] = true;
  }

  t_ignores_immutable_p[T_ITERATOR] = true;
  for (int32_t i = T_OUTPUT_PORT; i < Num_Types; i++) t_ignores_immutable_p[i] = true;
  /* (define (f x) (+ x 1)) (immutable! f) (set! f 3), now f is 3. (immutable! 'f) to block (set! f 3)
   *   maybe this is a bug, but what about generators?  random-state objects and iterators ignore it...
   */

#if s7_Debugging
  t_ext_p[T_UNUSED] = true;
  t_ext_p[T_SLOT] = true;
  t_ext_p[T_STACK] = true;
  t_ext_p[T_DYNAMIC_WIND] = true;
  t_ext_p[T_CATCH] = true;
  t_ext_p[T_COUNTER] = true;
#if !With_Gmp
  t_ext_p[T_BIG_INTEGER] = true;
  t_ext_p[T_BIG_RATIO] = true;
  t_ext_p[T_BIG_REAL] = true;
  t_ext_p[T_BIG_COMPLEX] = true;
#endif
  /* these cases are errors (null pointer, T_FREE checked by check_nref called by check_ref_exs) */
  t_exs_p[T_STACK] = true;
  t_exs_p[T_DYNAMIC_WIND] = true;
  t_exs_p[T_CATCH] = true;
  t_exs_p[T_COUNTER] = true;
#if !With_Gmp
  t_exs_p[T_BIG_INTEGER] = true;
  t_exs_p[T_BIG_RATIO] = true;
  t_exs_p[T_BIG_REAL] = true;
  t_exs_p[T_BIG_COMPLEX] = true;
#endif
#endif
}


#if With_History
#define current_code(Sc)               car(Sc->cur_code)
#define set_current_code(Sc, Code)     do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, Code);} while (0)
#define replace_current_code(Sc, Code) set_car(Sc->cur_code, Code)
#define mark_current_code(Sc)          do {int32_t _i_; s7_pointer _p_; for (_p_ = Sc->cur_code, _i_ = 0; _i_ < Sc->history_size; _i_++, _p_ = cdr(_p_)) gc_mark(car(_p_));} while (0)
#else
#define current_code(Sc)               Sc->cur_code
#define set_current_code(Sc, Code)     Sc->cur_code = Code
#define replace_current_code(Sc, Code) Sc->cur_code = Code
#define mark_current_code(Sc)          gc_mark(Sc->cur_code)
#endif

#define full_type(P)     ((P)->tf.u64_type)
#define low_type_bits(P) ((P)->tf.bits.low_bits)
#define Type_Mask        0xff

#if s7_Debugging
  static void print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32_t line);
  static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2);
  static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line);
  static s7_pointer check_opcode(s7_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_ = (P)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= Num_Types))) print_gc_info(cur_sc, P, __func__, __LINE__); _t_;})
#else
  #define type(P) (P)->tf.type_field
#endif

  #define set_full_type(P, F) set_type_1(P, F, __func__, __LINE__)
  /* these check most s7_cell field references (and many type bits) for consistency */
  #define T_App(P) check_ref_app(P,                      __func__, __LINE__)                /* applicable or #f */
  #define T_Arg(P) check_ref_arg(P,                      __func__, __LINE__)                /* closure arg (list, symbol) */
  #define T_BVc(P) check_ref_one(P, T_BYTE_VECTOR,       __func__, __LINE__, "sweep", NULL)
  #define T_Bgf(P) check_ref_one(P, T_BIG_RATIO,         __func__, __LINE__, "sweep", "free_big_ratio")
  #define T_Bgi(P) check_ref_one(P, T_BIG_INTEGER,       __func__, __LINE__, "sweep", "free_big_integer")
  #define T_Bgr(P) check_ref_one(P, T_BIG_REAL,          __func__, __LINE__, "sweep", "free_big_real")
  #define T_Bgz(P) check_ref_one(P, T_BIG_COMPLEX,       __func__, __LINE__, "sweep", "free_big_complex")
  #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 #<unused> and slot are ok */
  #define T_Ext(P) check_ref_ext(P,                      __func__, __LINE__)                /* not an internal type */
  #define T_Fnc(P) check_ref_fnc(P,                      __func__, __LINE__)                /* any c_function|c_macro */
  #define T_Frc(P) check_ref_two(P, T_RATIO, T_INTEGER,  __func__, __LINE__, NULL, NULL)
  #define T_Fst(P) check_ref_one(P, T_C_FUNCTION_STAR,   __func__, __LINE__, NULL, NULL)
  #define T_Fvc(P) check_ref_one(P, T_FLOAT_VECTOR,      __func__, __LINE__, "sweep", NULL)
  #define T_Got(P) check_ref_one(P, T_GOTO,              __func__, __LINE__, NULL, NULL)
  #define T_Hsh(P) check_ref_one(P, T_HASH_TABLE,        __func__, __LINE__, "sweep", "free_hash_table")
  #define T_Int(P) check_ref_one(P, T_INTEGER,           __func__, __LINE__, NULL, NULL)
  #define T_Itr(P) check_ref_one(P, T_ITERATOR,          __func__, __LINE__, "sweep", "process_iterator")
  #define T_Ivc(P) check_ref_one(P, T_INT_VECTOR,        __func__, __LINE__, "sweep", NULL)
  #define T_Key(P) check_ref_key(P,                      __func__, __LINE__)                /* keyword */
  #define T_Let(P) check_ref_one(P, T_LET,               __func__, __LINE__, NULL, NULL)
  #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_MSet(P) check_ref_mset(P,                    __func__, __LINE__)                /* type >= T_CLOSURE, setter is a macro */
  #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_SetNmv(P) check_set_nmv(P,                   __func__, __LINE__)                /* same for slot_set_value */
  #define T_Num(P) check_ref_num(P,                      __func__, __LINE__)                /* any number (not bignums) */
  #define T_Nvc(P) check_ref_one(P, T_VECTOR,            __func__, __LINE__, "sweep", NULL)
  #define T_Obj(P) check_ref_one(P, T_C_OBJECT,          __func__, __LINE__, "sweep", "s7_c_object_value")
  #define T_Op(P)  check_opcode(P,                       __func__, __LINE__)
  #define T_Out(P) check_ref_out(P,                      __func__, __LINE__)                /* let or NULL */
  #define T_Pair(P) check_ref_one(P, T_PAIR,             __func__, __LINE__, NULL, NULL)
  #define T_Pcs(P) check_ref_two(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL)
  #define T_Pos(P) check_nref(P,                         __func__, __LINE__)                /* not free */
  #define T_Prc(P) check_ref_prc(P,                      __func__, __LINE__)                /* any procedure (3-arg setters) or #f|#t */
  #define T_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, #<undefined> 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_MSet(P) P
  #define T_Muti(P) P
  #define T_Nmv(P)  P
  #define T_SetNmv(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_big_number(P)               t_big_number_p[type(P)]
#define is_t_integer(P)                (type(P) == T_INTEGER)
#define is_t_ratio(P)                  (type(P) == T_RATIO)
#define is_t_real(P)                   (type(P) == T_REAL)
#define is_t_complex(P)                (type(P) == T_COMPLEX)
#define is_t_big_integer(P)            (type(P) == T_BIG_INTEGER)
#define is_t_big_ratio(P)              (type(P) == T_BIG_RATIO)
#define is_t_big_real(P)               (type(P) == T_BIG_REAL)
#define is_t_big_complex(P)            (type(P) == T_BIG_COMPLEX)

#define is_boolean(P)                  (type(P) == T_BOOLEAN)

#define is_free(P)                     (type_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 is_simpler(P)                  t_simpler_p[type(P)]
#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 (leave low bits alone) */

#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)
#if s7_Debugging
  #define set_safe_list_in_use(Sc, P)   do {set_low_type_bit(T_Pair(P), T_Safe_List_In_Use); P->carrier_line = __LINE__;} while (0)
  #define clear_safe_list_in_use(Sc, P) do {clear_low_type_bit(T_Pair(P), T_Safe_List_In_Use); P->carrier_line = 0; Sc->current_safe_list = 0;} while (0)
#else
  #define set_safe_list_in_use(Sc, P)   set_low_type_bit(P, T_Safe_List_In_Use)
  #define clear_safe_list_in_use(Sc, P) do {clear_low_type_bit(P, T_Safe_List_In_Use); Sc->current_safe_list = 0;} while (0)
#endif

#define T_One_Form                     T_Simple_Arg_Defaults
#define set_closure_has_one_form(P)    set_low_type_bit(T_Clo(P), T_One_Form)
#define T_Multiform                    (1 << (8 + 0))
#define set_closure_has_multiform(P)   set_low_type_bit(T_Clo(P), T_Multiform)
#define T_One_Form_Fx_Arg              (T_One_Form | T_Multiform)
#define set_closure_one_form_fx_arg(P) set_low_type_bit(T_Clo(P), T_One_Form_Fx_Arg)
/* can't use T_Has_Fx here because closure_is_ok wants to examine low_type_bits */

#define T_Optimized                    (1 << (8 + 3))
#define set_optimized(P)               set_low_type_bit(T_Pair(P), T_Optimized)
#define clear_optimized(P)             clear_low_type_bit(T_Pair(P), T_Optimized | T_Syntactic | T_Has_Fx | T_Has_Fn)
#define is_optimized(P)                (low_type_bits(T_Ext(P)) == (uint16_t)(T_PAIR | T_Optimized))
/* optimizer flag for an expression that has optimization info, it should be in the second byte */

#define T_Scope_Safe                   T_Optimized
#define is_scope_safe(P)               has_low_type_bit(T_Fnc(P), T_Scope_Safe)
#define set_scope_safe(P)              set_low_type_bit(T_Fnc(P), T_Scope_Safe)

#define T_Safe_Closure                 (1 << (8 + 4))
#define is_safe_closure(P)             has_low_type_bit(T_Clo(P), T_Safe_Closure)
#define set_safe_closure(P)            set_low_type_bit(T_Clo(P), T_Safe_Closure)
#define is_safe_closure_body(P)        has_low_type_bit(T_Pair(P), T_Safe_Closure)
#define set_safe_closure_body(P)       set_low_type_bit(T_Pair(P), T_Safe_Closure)
#define clear_safe_closure_body(P)     clear_low_type_bit(T_Pair(P), T_Safe_Closure)

/* optimizer flag for a closure body that is completely simple (every expression is safe)
 *   set_safe_closure happens in define_funchcecked letrec_setup_closures etc, clear only in procedure_source, bits only here
 *   this has to be separate from T_Safe_Procedure, and should be in the second byte (closure_is_ok_1 checks low_type_bits).
 * define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let
 *   similarly, named let -> optimize_lambda, then let creates the let if safe
 *   thereafter, optimizer uses OP_Safe_Closure* which calls update_let*
 */

#define T_Dont_Eval_Args               (1 << (8 + 5))
#define dont_eval_args(P)              has_low_type_bit(T_Ext(P), T_Dont_Eval_Args)
/* this marks things that don't evaluate their arguments */

#define T_Expansion                    (1 << (8 + 6))
#define is_expansion(P)                has_low_type_bit(T_Ext(P), T_Expansion)
#define set_is_expansion(P)            set_low_type_bit(T_Sym(P), T_Expansion)
#define clear_is_expansion(P)          clear_low_type_bit(T_Sym(P), T_Expansion)
/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */

#define T_Multiple_Value               (1 << (8 + 7))
#define is_multiple_value(P)           has_low_type_bit(T_Exs(P), T_Multiple_Value) /* not T_Ext -- can be a slot */
#if s7_Debugging
  #define set_multiple_value(P)        do {if (!in_heap(P)) {fprintf(stderr, "%s[%d] (from set_multiple_value): arg not in heap\n", __func__, __LINE__); abort();} set_low_type_bit(T_Pair(P), T_Multiple_Value);} while (0)
#else
  #define set_multiple_value(P)        set_low_type_bit(T_Pair(P), T_Multiple_Value)
#endif
#define clear_multiple_value(P)        clear_low_type_bit(T_Pair(P), T_Multiple_Value)
#define multiple_value(P)              P
/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */

#define T_Matched                      T_Multiple_Value
#define is_matched_pair(P)             has_low_type_bit(T_Pair(P), T_Matched)
#define clear_match_pair(P)            clear_low_type_bit(T_Pair(P), T_Matched)
#define set_match_pair(P)              set_low_type_bit(T_Pair(P), T_Matched)
#define set_match_symbol(P)            set_low_type_bit(T_Sym(P), T_Matched)
#define is_matched_symbol(P)           has_low_type_bit(T_Sym(P), T_Matched)
#define clear_match_symbol(P)          clear_low_type_bit(T_Sym(P), T_Matched)

/* -------- mid type bits -------- */

#define T_Unsafe_Do                    (1 << (16 + 0))
#define T_Mid_Unsafe_Do                (1 << 0)
#define is_unsafe_do(P)                has_mid_type_bit(T_Pair(P), T_Mid_Unsafe_Do)
#define set_unsafe_do(P)               set_mid_type_bit(T_Pair(P), T_Mid_Unsafe_Do)
/* marks do-loops that resist optimization */

#define T_Mid_Dox_Slot1                T_Mid_Unsafe_Do
#define has_dox_slot1(P)               has_mid_type_bit(T_Let(P), T_Mid_Dox_Slot1)
#define set_has_dox_slot1(P)           set_mid_type_bit(T_Let(P), T_Mid_Dox_Slot1)
/* marks a let that includes the dox_slot1 */

#define T_Mid_Even_Args                T_Mid_Unsafe_Do
#define has_even_args(P)               has_mid_type_bit(T_CFn(P), T_Mid_Even_Args)
#define set_has_even_args(P)           set_mid_type_bit(T_CFn(P), T_Mid_Even_Args)

#define T_Mid_Maybe_Shadowed           T_Mid_Unsafe_Do
#define is_maybe_shadowed(P)           has_mid_type_bit(T_Sym(P), T_Mid_Maybe_Shadowed)
#define set_is_maybe_shadowed(P)       set_mid_type_bit(T_Sym(P), T_Mid_Maybe_Shadowed)

#define T_Mid_String_Port              T_Mid_Unsafe_Do
#define is_string_port(P)              has_mid_type_bit(T_Prt(P), T_Mid_String_Port)
#define set_is_string_port(P)          set_mid_type_bit(T_Prt(P), T_Mid_String_Port)

#define T_Collected                    (1 << (16 + 1))
#define T_Mid_Collected                (1 << 1)
#define is_collected(P)                has_mid_type_bit(T_Seq(P), T_Mid_Collected)
#define is_collected_unchecked(P)      has_mid_type_bit(P, T_Mid_Collected)
#define set_collected(P)               set_mid_type_bit(T_Seq(P), T_Mid_Collected)
/* #define clear_collected(P)          clear_mid_type_bit(T_Seq(p), T_Mid_Collected) */
/* this is a transient flag used by the printer to catch cycles.  It affects only objects that have structure.
 *   We can't use a low bit (bit 7 for example), because collect_shared_info inspects the object's type.
 */

#define T_Location                     (1 << (16 + 2))
#define T_Mid_Location                 (1 << 2)
#define has_location(P)                has_mid_type_bit(T_Pair(P), T_Mid_Location)
#define set_has_location(P)            set_mid_type_bit(T_Pair(P), T_Mid_Location)
/* pair in question has line/file/position info added during read, or the environment has function placement info
 *   this bit should not be in the first byte -- Syntactic_Pair ignores it.
 */

#define T_Loader_Port                  T_Mid_Location
#define is_loader_port(P)              has_mid_type_bit(T_Pri(P), T_Loader_Port)
#define set_loader_port(P)             set_mid_type_bit(T_Pri(P), T_Loader_Port)
#define clear_loader_port(P)           clear_mid_type_bit(T_Pri(P), T_Loader_Port)
/* this bit marks a port used by the loader so that random load-time reads do not screw up the load process */

#define T_Has_Setter                   T_Mid_Location
#define slot_has_setter(P)             has_mid_type_bit(T_Slt(P), T_Has_Setter)
#define set_slot_has_setter(P)         set_mid_type_bit(T_Slt(P), T_Has_Setter)
#define clear_slot_has_setter(P)       clear_mid_type_bit(T_Slt(P), T_Has_Setter)
/* marks a slot that has a setter */

#define T_With_Let_Let                 T_Mid_Location
#define is_with_let_let(P)             has_mid_type_bit(T_Let(P), T_With_Let_Let)
#define set_with_let_let(P)            set_mid_type_bit(T_Let(P), T_With_Let_Let)
/* marks a let that is the argument to with-let (but not rootlet in its uses) */

#define T_Simple_Defaults              T_Mid_Location
#define c_func_has_simple_defaults(P)  has_mid_type_bit(T_Fst(P), T_Simple_Defaults)
#define c_func_set_simple_defaults(P)  set_mid_type_bit(T_Fst(P), T_Simple_Defaults)
#define c_func_clear_simple_defaults(P) clear_mid_type_bit(T_Fst(P), T_Simple_Defaults)
/* flag c_func_star arg defaults that need GC protection */

#define T_No_Setter                    T_Mid_Location
#define closure_no_setter(P)           has_mid_type_bit(T_Clo(P), T_No_Setter)
#define closure_set_no_setter(P)       set_mid_type_bit(T_Clo(P), T_No_Setter)

#define T_Shared                       (1 << (16 + 3))
#define T_Mid_Shared                   (1 << 3)
#define is_shared(P)                   has_mid_type_bit(T_Seq(P), T_Mid_Shared)
#define set_shared(P)                  set_mid_type_bit(T_Seq(P), T_Mid_Shared)
#define is_collected_or_shared(P)      has_mid_type_bit(T_Seq(P), T_Mid_Collected | T_Mid_Shared)
#define clear_collected_and_shared(P)  clear_mid_type_bit(T_Seq(P), T_Mid_Collected | T_Mid_Shared) /* this can clear free cells = calloc */

#define T_Low_Count                    (1 << (16 + 4))
#define T_Mid_Low_Count                (1 << 4)
#define has_low_count(P)               has_mid_type_bit(T_Pair(P), T_Low_Count)
#define set_has_low_count(P)           set_mid_type_bit(T_Pair(P), T_Low_Count)

#define T_Tc                           T_Mid_Low_Count
#define has_tc(P)                      has_mid_type_bit(T_Pair(P), T_Tc)
#define set_has_tc(P)                  set_mid_type_bit(T_Pair(P), T_Tc)

#define T_Initial_Value                T_Mid_Low_Count
#define is_initial_value(P)            has_mid_type_bit(P, T_Initial_Value)
#define set_is_initial_value(P)        set_mid_type_bit(P, T_Initial_Value) /* this marks the value, not the symbol */
#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" */
/* see also T_No_Float_Opt below */

#define T_Clean_Symbol                 T_Mid_Unsafe
#define is_clean_symbol(P)             has_mid_type_bit(T_Sym(P), T_Clean_Symbol)
#define set_clean_symbol(P)            set_mid_type_bit(T_Sym(P), T_Clean_Symbol)
/* set if we know the symbol name can be printed without quotes (slashification) */

#define T_Has_Stepper                  T_Mid_Unsafe
#define has_stepper(P)                 has_mid_type_bit(T_Slt(P), T_Has_Stepper)
#define set_has_stepper(P)             set_mid_type_bit(T_Slt(P), T_Has_Stepper)

#define T_Dox_Slot2                    T_Mid_Unsafe
#define has_dox_slot2(P)               has_mid_type_bit(T_Let(P), T_Dox_Slot2)
#define set_has_dox_slot2(P)           set_mid_type_bit(T_Let(P), T_Dox_Slot2)
/* marks a let that includes the dox_slot2 */

#define T_Mid_File_Port                T_Mid_Unsafe
#define is_file_port(P)                has_mid_type_bit(T_Prt(P), T_Mid_File_Port)
#define set_is_file_port(P)            set_mid_type_bit(T_Prt(P), T_Mid_File_Port)

#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)
#define ignores_immutable(P)           t_ignores_immutable_p[type(P)]
/* T_Immutable is compatible with T_Mutable -- the latter is an internal bit for locally mutable numbers */

#define T_Allow_Other_Keys             (1 << (16 + 9))
#define T_Mid_Allow_Other_Keys         (1 << 9)
#define set_allow_other_keys(P)        set_mid_type_bit(T_Pair(P), T_Mid_Allow_Other_Keys)
#define allows_other_keys(P)           has_mid_type_bit(T_Pair(P), T_Mid_Allow_Other_Keys)
#define c_function_set_allow_other_keys(P) set_mid_type_bit(T_Fst(P), T_Mid_Allow_Other_Keys)
#define c_function_allows_other_keys(P)    has_mid_type_bit(T_Fst(P), T_Mid_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_Mid_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_Mid_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_Mid_Function_Port            T_Mid_Allow_Other_Keys
#define is_function_port(P)            has_mid_type_bit(T_Prt(P), T_Mid_Function_Port)
#define set_is_function_port(P)        set_mid_type_bit(T_Prt(P), T_Mid_Function_Port)

#define T_Mutable                      (1 << (16 + 10)) /* many use T_Mid_Mutable below */
#define T_Mid_Mutable                  (1 << 10)

#define has_macro_setter(P)            ((has_mid_type_bit(P, T_Mid_Mutable)) && (is_any_procedure(P)))
#define set_has_macro_setter(P)        set_mid_type_bit(T_MSet(P), T_Mid_Mutable)
#define clear_has_macro_setter(P)      clear_mid_type_bit(T_MSet(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(P, T_Mid_Mutable)) && (is_t_integer(P)))
#if s7_Debugging
#define clear_mutable_number(P)        do {check_mutable_bit(P); clear_mid_type_bit(T_Num(P), T_Mid_Mutable);} while (0)
#define clear_mutable_integer(P)       do {check_mutable_bit(P); clear_mid_type_bit(T_Int(P), T_Mid_Mutable);} while (0)
#else
#define clear_mutable_number(P)        clear_mid_type_bit(T_Num(P), T_Mid_Mutable)
#define clear_mutable_integer(P)       clear_mid_type_bit(T_Int(P), T_Mid_Mutable)
#endif
/* used for mutable numbers, can occur with T_Immutable (outside view vs inside) */

#define T_Has_Keyword                  T_Mid_Mutable
#define has_keyword(P)                 has_mid_type_bit(T_Sym(P), T_Has_Keyword)
#define set_has_keyword(P)             set_mid_type_bit(T_Sym(P), T_Has_Keyword)

#define T_Mark_Seq                     T_Mid_Mutable
#define has_carrier(P)                 has_mid_type_bit(T_Itr(P), T_Mark_Seq)
#if s7_Debugging
  #define set_has_carrier(P)           do {set_mid_type_bit(T_Itr(P), T_Mark_Seq); P->carrier_line = __LINE__;} while (0)
#else
  #define set_has_carrier(P)           set_mid_type_bit(T_Itr(P), T_Mark_Seq)
#endif
/* used in iterators for GC mark of sequence */

#define T_Has_Loop_End                 T_Mid_Mutable
#define has_loop_end(P)                has_mid_type_bit(T_Slt(P), T_Has_Loop_End)
#define loop_end_fits(Slot, Len)       ((has_loop_end(Slot)) && (denominator(slot_value(Slot)) <= Len))
#define set_has_loop_end(P)            set_mid_type_bit(T_Slt(P), T_Has_Loop_End)
/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */

#define T_No_Cell_Opt                  T_Mid_Mutable
#define set_no_cell_opt(P)             set_mid_type_bit(T_Pair(P), T_No_Cell_Opt)
#define no_cell_opt(P)                 has_mid_type_bit(T_Pair(P), T_No_Cell_Opt)

#define T_Is_Elist                     T_Mutable
#define T_Mid_Is_Elist                 T_Mid_Mutable
#define set_is_elist(P)                set_mid_type_bit(T_Lst(P), T_Mid_Is_Elist)
#define is_elist(P)                    has_mid_type_bit(T_Lst(P), T_Mid_Is_Elist)

#define T_No_Int_Opt                   T_Mid_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_Mid_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_is_safe_stepper(P)         set_mid_type_bit(T_Slt(P), T_Mid_Safe_Stepper)
#define clear_is_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_is_safe_stepper_expr(P)    set_mid_type_bit(T_Pair(P), T_Mid_Safe_Stepper)

#define T_Wrapper                      T_Safe_Stepper
#define T_Mid_Wrapper                  T_Mid_Safe_Stepper
#define is_wrapper(P)                  has_mid_type_bit(T_Str(P), T_Mid_Wrapper)
/* string_wrapper only currently, all numbers and c_pointer ok, let|slot are taken */

#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_is_funclet(P)              set_mid_type_bit(T_Let(P), T_Mid_Funclet)
/* this marks a funclet */

#define T_Hash_Chosen                  T_Mid_Gensym
#define hash_chosen(P)                 has_mid_type_bit(T_Hsh(P), T_Hash_Chosen)
#define hash_set_chosen(P)             set_mid_type_bit(T_Hsh(P), T_Hash_Chosen)
#define hash_clear_chosen(P)           clear_mid_type_bit(T_Hsh(P), T_Hash_Chosen)

#define T_Documented                   T_Mid_Gensym
#define is_documented(P)               has_mid_type_bit(T_Str(P), T_Documented)
#define set_documented(P)              set_mid_type_bit(T_Str(P), T_Documented)
/* this marks a symbol that has documentation (bit is set on name cell) */

#define T_Fx_Treed                     T_Mid_Gensym
#define is_fx_treed(P)                 has_mid_type_bit(T_Pair(P), T_Fx_Treed)
#define set_fx_treed(P)                set_mid_type_bit(T_Pair(P), T_Fx_Treed)

#define T_Subvector                    T_Gensym
#define T_Mid_Subvector                T_Mid_Gensym
#define is_subvector(P)                has_mid_type_bit(T_Vec(P), T_Mid_Subvector)

#define T_Has_Pending_Value            T_Mid_Gensym
#define slot_set_has_pending_value(P)  set_mid_type_bit(T_Slt(P), T_Has_Pending_Value)
#define slot_has_pending_value(P)      has_mid_type_bit(T_Slt(P), T_Has_Pending_Value)
#define slot_clear_has_pending_value(P) do {clear_mid_type_bit(T_Slt(P), T_Has_Pending_Value); slot_set_pending_value(P, sc->F);} while (0)
#define slot_has_setter_or_pending_value(P) has_mid_type_bit(T_Slt(P), T_Has_Setter | T_Has_Pending_Value)

#define T_Has_Methods                  (1 << (16 + 14))
#define T_Mid_Has_Methods              (1 << 14)
#define has_methods(P)                 has_mid_type_bit(T_Exs(P), T_Mid_Has_Methods) /* display slot hits T_Ext here */
#define has_methods_unchecked(P)       has_mid_type_bit(P, T_Mid_Has_Methods)
#define is_openlet(P)                  has_mid_type_bit(T_Let(P), T_Mid_Has_Methods)
#define has_active_methods(Sc, P)      ((has_mid_type_bit(T_Ext(P), T_Mid_Has_Methods)) && (Sc->has_openlets)) /* g_char #<eof> */
#define set_has_methods(P)             set_mid_type_bit(T_Met(P), T_Mid_Has_Methods)
#define clear_has_methods(P)           clear_mid_type_bit(T_Met(P), T_Mid_Has_Methods)
/* this marks 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)


/* -------- high type bits -------- */
/* it's faster here to use the high_bits bits rather than typeflag bits */
#define T_Symcons                      (1LL << (48 + 0))
#define T_High_Symcons                 (1 << 0)
#define is_possibly_constant(P)        has_high_type_bit(T_Sym(P), T_High_Symcons)
#define set_possibly_constant(P)       set_high_type_bit(T_Sym(P), T_High_Symcons)
#define is_probably_constant(P)        has_type_bit(T_Sym(P), (T_Symcons | T_Immutable))

#define T_Has_Let_Arg                  T_High_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_High_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_High_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_High_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_High_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_Has_Let_File                 (1LL << (48 + 1))
#define T_High_Has_Let_File            (1 << 1)
#define has_let_file(P)                has_high_type_bit(T_Let(P), T_High_Has_Let_File)
#define set_has_let_file(P)            set_high_type_bit(T_Let(P), T_High_Has_Let_File)
#define clear_has_let_file(P)          clear_high_type_bit(T_Let(P), T_High_Has_Let_File)

#define T_Typed_Vector                 T_High_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_High_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_High_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_High_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_High_No_Defaults             T_High_Has_Let_File
#define has_no_defaults(P)             has_high_type_bit(T_Pcs(P), T_High_No_Defaults)
#define set_has_no_defaults(P)         set_high_type_bit(T_Pcs(P), T_High_No_Defaults)
/* pair=closure* body, transferred to closure* */

#define T_Definer                      (1LL << (48 + 2))
#define T_High_Definer                 (1 << 2)
#define is_definer(P)                  has_high_type_bit(T_Sym(P), T_High_Definer)
#define set_is_definer(P)              set_high_type_bit(T_Sym(P), T_High_Definer)
#define is_func_definer(P)             has_high_type_bit(T_CFn(P), T_High_Definer)
#define set_func_is_definer(P)         do {set_high_type_bit(T_CFn(initial_value(P)), T_High_Definer); set_high_type_bit(T_Sym(P), T_High_Definer);} while (0)
#define is_syntax_definer(P)           has_high_type_bit(T_Syn(P), T_High_Definer)
#define set_syntax_is_definer(P)       do {set_high_type_bit(T_Syn(initial_value(P)), T_High_Definer); set_high_type_bit(T_Sym(P), T_High_Definer);} while (0)
/* this marks "definers" like define and define-macro */

#define T_Maclet                       T_High_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_High_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_High_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_High_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_High_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_Binder                       (1LL << (48 + 3))
#define T_High_Binder                  (1 << 3)
#define set_syntax_is_binder(P)        do {set_high_type_bit(T_Syn(initial_value(P)), T_High_Binder); set_high_type_bit(T_Sym(P), T_High_Binder);} while (0)
#define is_definer_or_binder(P)        has_high_type_bit(T_Sym(P), T_High_Definer | T_High_Binder)
/* this marks "binders" like let */

#define T_Semisafe                     T_High_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_High_Tree_Collected          T_High_Binder
#define tree_is_collected(P)           has_high_type_bit(T_Pair(P), T_High_Tree_Collected)
#define tree_set_collected(P)          set_high_type_bit(T_Pair(P), T_High_Tree_Collected)
#define tree_clear_collected(P)        clear_high_type_bit(T_Pair(P), T_High_Tree_Collected)

#define T_Simple_Values                T_High_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_High_Very_Safe_Closure       (1 << 4)
#define is_very_safe_closure(P)        has_high_type_bit(T_Clo(P), T_High_Very_Safe_Closure)
#define set_very_safe_closure(P)       set_high_type_bit(T_Clo(P), T_High_Very_Safe_Closure)
#define closure_bits(P)                (full_type(T_Pair(P)) & (T_Safe_Closure | T_Very_Safe_Closure | T_No_Defaults))
#define is_very_safe_closure_body(P)   has_high_type_bit(T_Pair(P), T_High_Very_Safe_Closure)
#define set_very_safe_closure_body(P)  set_high_type_bit(T_Pair(P), T_High_Very_Safe_Closure)

#define T_Baffle_Let                   T_High_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_High_Cyclic                  (1 << 5)
#define is_cyclic(P)                   has_high_type_bit(T_Seq(P), T_High_Cyclic)
#define set_cyclic(P)                  set_high_type_bit(T_Seq(P), T_High_Cyclic)

#define T_Cyclic_Set                   (1LL << (48 + 6))
#define T_High_Cyclic_Set              (1 << 6)
#define is_cyclic_set(P)               has_high_type_bit(T_Seq(P), T_High_Cyclic_Set)
#define set_cyclic_set(P)              set_high_type_bit(T_Seq(P), T_High_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_High_Keyword                 (1 << 7)
#define is_keyword(P)                  has_high_type_bit(T_Sym(P), T_High_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_High_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_Simple_Elements              (1LL << (48 + 8))
#define T_High_Simple_Elements         (1 << 8)
#define has_simple_elements(P)         has_high_type_bit(T_Nvc(P), T_High_Simple_Elements)
#define set_has_simple_elements(P)     set_high_type_bit(T_Nvc(P), T_High_Simple_Elements)
#define clear_has_simple_elements(P)   clear_high_type_bit(T_Nvc(P), T_High_Simple_Elements)
#define c_function_has_simple_elements(P)     has_high_type_bit(T_CFn(P), T_High_Simple_Elements)
#define c_function_set_has_simple_elements(P) set_high_type_bit(T_CFn(P), T_High_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_High_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_High_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_High_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_Case_Key                     (1LL << (48 + 9))
#define T_High_Case_Key                (1 << 9)
#define is_case_key(P)                 has_high_type_bit(T_Ext(P), T_High_Case_Key)
#define set_case_key(P)                set_high_type_bit(T_Sym(P), T_High_Case_Key)

#define T_Opt1_Func_Listed             T_High_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_True_Is_Done                 (1LL << (48 + 10))
#define T_High_True_Is_Done            (1 << 10)
#define true_is_done(P)                has_high_type_bit(T_Pair(P), T_High_True_Is_Done)
#define set_true_is_done(P)            set_high_type_bit(T_Pair(P), T_High_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_Is_Saver                     T_High_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_Unknopt                      (1LL << (48 + 11))
#define T_High_Unknopt                 (1 << 11)
#define is_unknopt(P)                  has_high_type_bit(T_Pair(P), T_High_Unknopt)
#define set_is_unknopt(P)              set_high_type_bit(T_Pair(P), T_High_Unknopt)

#define T_Is_Translucent               T_High_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_High_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_Safety_Checked               (1LL << (48 + 12))
#define T_High_Safety_Checked          (1 << 12)
#define is_safety_checked(P)           has_high_type_bit(T_Pair(P), T_High_Safety_Checked)
#define set_safety_checked(P)          do {if (in_heap(P)) set_high_type_bit(T_Pair(P), T_High_Safety_Checked);} while (0)

#define T_Setter                       T_High_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_Has_Fn                       (1LL << (48 + 13))
#define T_High_Has_Fn                  (1 << 13)
#define set_has_fn(P)                  set_high_type_bit(T_Pair(P), T_High_Has_Fn)
#define has_fn(P)                      has_high_type_bit(T_Pair(P), T_High_Has_Fn)
#define clear_has_fn(P)                clear_high_type_bit(T_Pair(P), T_High_Has_Fn)

#define T_Is_Escaper                   T_High_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_High_Unheap                  (1 << 14)
#define in_heap(P)                     (((T_Pos(P))->tf.bits.high_bits & T_High_Unheap) == 0) /* can be slot, make_starlet let_set_slot */
#define unheap(P)                      set_high_type_bit(T_Ext(P), T_High_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)

#if MS_Windows
  static s7_pointer make_boolean(s7_scheme *sc, bool val) {if (val) return(sc->T); return(sc->F);}
#else
  #define make_boolean(Sc, Val)        ((Val) ? Sc->T : Sc->F)
#endif

#define is_pair(P)                     (type(P) == T_PAIR)
#define is_mutable_pair(P)             ((is_pair(P)) && (!is_immutable(P)))
   /* same speed: ((full_type(P) & (Type_Mask | T_Immutable)) == T_PAIR), list-set! set-car! set-cdr! */
#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))

#if !s7_Debugging
#define pair_location(P)               (P)->object.sym_cons.location
#define pair_set_location(P, X)        (P)->object.sym_cons.location = X
#define pair_raw_hash(P)               (P)->object.sym_cons.hash
#define pair_set_raw_hash(P, X)        (P)->object.sym_cons.hash = X
#define pair_raw_len(P)                (P)->object.sym_cons.location
#define pair_set_raw_len(P, X)         (P)->object.sym_cons.location = X
#define pair_raw_name(P)               (P)->object.sym_cons.fstr
#define pair_set_raw_name(P, X)        (P)->object.sym_cons.fstr = X
/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */

#define opt1(P, R)                     ((P)->object.cons.opt1)
#define set_opt1(P, X, R)              (P)->object.cons.opt1 = X
#define opt2(P, R)                     ((P)->object.cons.o2.opt2)
#define set_opt2(P, X, R)              (P)->object.cons.o2.opt2 = (s7_pointer)(X)
#define opt2_n(P, R)                   ((P)->object.cons.o2.n)
#define set_opt2_n(P, X, R)            (P)->object.cons.o2.n = X
#define opt3(P, R)                     ((P)->object.cons.o3.opt3)
#define set_opt3(P, X, R)              do {(P)->object.cons.o3.opt3 = X; clear_type_bit(P, T_Location);} while (0)
#define opt3_n(P, R)                   ((P)->object.cons.o3.n)
#define set_opt3_n(P, X, R)            do {(P)->object.cons.o3.n = X; clear_type_bit(P, T_Location);} while (0)

#else

/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways.
 * the bits and funcs here try to track each such use, and report any cross-talk or collisions.
 * all of this machinery vanishes if debugging is turned off.
 */
#define Opt1_Set                       (1 << 0)
#define Opt2_Set                       (1 << 1)
#define Opt3_Set                       (1 << 2)

#define Opt1_Fast                      (1 << 3)   /* fast list in member/assoc circular list check */
#define Opt1_Cfunc                     (1 << 4)   /* c-function */
#define Opt1_Clause                    (1 << 5)   /* case clause */
#define Opt1_Lambda                    (1 << 6)   /* lambda(*) */
#define Opt1_Sym                       (1 << 7)   /* symbol */
#define Opt1_Pair                      (1 << 8)   /* pair */
#define Opt1_Con                       (1 << 9)   /* constant from eval's point of view */ /* 10 was opt1_goto, unused */
#define Opt1_Any                       (1 << 11)  /* anything -- deliberate unchecked case */
#define Opt1_Hash                      (1 << 12)  /* hash code used in the symbol table (pair_raw_hash) */
#define Opt1_Mask                      (Opt1_Fast | Opt1_Cfunc | Opt1_Clause | Opt1_Lambda | Opt1_Sym | Opt1_Pair | Opt1_Con | Opt1_Any | Opt1_Hash)

#define opt1_is_set(P)                 (((T_Pair(P))->debugger_bits & Opt1_Set) != 0)
#define set_opt1_is_set(P)             (T_Pair(P))->debugger_bits |= Opt1_Set
#define opt1_role_matches(P, Role)     (((T_Pair(P))->debugger_bits & Opt1_Mask) == Role)
#define set_opt1_role(P, Role)         (T_Pair(P))->debugger_bits = (Role | ((P)->debugger_bits & ~Opt1_Mask))
#define opt1(P, Role)                  opt1_1(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(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__) /* sc as par and below */
#define opt2_n(P, Role)                opt2_n_1(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(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(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(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(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(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(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 #<unused> */
#define opt1_any(P)                    opt1(P,                      Opt1_Any)    /* can be free in closure_is_ok */
#define set_opt1_any(P, X)             set_opt1(P, X,               Opt1_Any)

#define opt2_any(P)                    opt2(P,                      Opt2_Key)
#define set_opt2_any(P, X)             set_opt2(P, X,               Opt2_Key)
#define opt2_int(P)                    opt2_n(P,                    Opt2_Int)
#define set_opt2_int(P, X)             set_opt2_n(P, X,             Opt2_Int)
#define opt2_slow(P)                   T_Lst(opt2(P,                Opt2_Slow))
#define set_opt2_slow(P, X)            set_opt2(P, T_Pair(X),       Opt2_Slow)
#define opt2_sym(P)                    T_Sym(opt2(P,                Opt2_Sym))
#define set_opt2_sym(P, X)             set_opt2(P, T_Sym(X),        Opt2_Sym)
#define opt2_pair(P)                   T_Lst(opt2(P,                Opt2_Pair))
#define set_opt2_pair(P, X)            set_opt2(P, T_Lst(X),        Opt2_Pair)
#define opt2_con(P)                    T_Exs(opt2(P,                Opt2_Con))
#define set_opt2_con(P, X)             set_opt2(P, T_Exs(X),        Opt2_Con)
#define opt2_lambda(P)                 T_Pair(opt2(P,               Opt2_Lambda))
#define set_opt2_lambda(P, X)          set_opt2(P, T_Pair(X),       Opt2_Lambda)
#define opt2_direct(P)                 opt2(P,                      Opt2_Direct)
#define set_opt2_direct(P, X)          set_opt2(P, (s7_pointer)(X), Opt2_Direct)

#define opt3_arglen(P)                 opt3_n(P,                    Opt3_Arglen)
#define set_opt3_arglen(P, X)          set_opt3_n(P, X,             Opt3_Arglen)
#define opt3_int(P)                    opt3_n(P,                    Opt3_Int)
#define set_opt3_int(P, X)             set_opt3_n(P, X,             Opt3_Int)
#define opt3_sym(P)                    T_Sym(opt3(P,                Opt3_Sym))
#define set_opt3_sym(P, X)             set_opt3(P, T_Sym(X),        Opt3_Sym)
#define opt3_con(P)                    T_Exs(opt3(P,                Opt3_Con))
#define set_opt3_con(P, X)             set_opt3(P, T_Exs(X),        Opt3_Con)
#define opt3_pair(P)                   T_Pair(opt3(P,               Opt3_And))
#define set_opt3_pair(P, X)            set_opt3(P, T_Pair(X),       Opt3_And)
#define opt3_any(P)                    opt3(P,                      Opt3_Any)
#define set_opt3_any(P, X)             set_opt3(P, X,               Opt3_Any)   /* 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(T_Pair(P), Opt3_Byte, __func__, __LINE__)
#define set_opt3_byte(P, X)            set_opt3_byte_1(T_Pair(P), X, Opt3_Byte, __func__, __LINE__)
#else
#define opt3_byte(P)                   T_Pair(P)->object.cons.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */
#define set_opt3_byte(P, X)            do {T_Pair(P)->object.cons.o3.opt_type = X; clear_type_bit(P, T_Location);} while (0)
#endif

#define pair_macro(P)                  opt2_sym(P)
#define set_pair_macro(P, Name)        set_opt2_sym(P, Name)

#define fn_proc(F)                     ((s7_function)(opt2(F, Opt2_Fn)))
#define fx_proc(F)                     ((s7_function)(opt2(F, Opt2_Fx)))
#define fn_proc_unchecked(F)           ((s7_function)(T_Pair(F)->object.cons.o2.opt2))

#define set_fx(F, _X_)                 do {s7_pointer X = (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 = (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
  /* make sure sc->code and sc->args are not changed by fx_call or fn_call (sc->value is changed by fx_tc_* via tc_z) */
  #define fx_call(Sc, F)               ({s7_pointer _P_ = F, _C_ = Sc->code, _V_, _A_ = Sc->args; _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); if (Sc->args != _A_) fprintf(stderr, "%s%s[%d]: %s clobbered sc->args%s\n", Bold_Text, __func__, __LINE__, display(_A_), Unbold_Text); _V_;})
  #define fn_call(Sc, F)               ({s7_pointer _P_ = F, _C_ = Sc->code, _V_, _A_ = Sc->args; _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); if (Sc->args != _A_) fprintf(stderr, "%s%s[%d]: %s clobbered sc->args%s\n", Bold_Text, __func__, __LINE__, display(_A_), Unbold_Text); _V_;})
#else
  #define fx_call(Sc, F)               ({s7_pointer _P_ = F; fx_proc(_P_)(Sc, car(_P_));})
  #define fn_call(Sc, F)               ({s7_pointer _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));})
#endif
#else
  #define fx_call(Sc, F)               fx_proc(F)(Sc, car(F))
  #define fn_call(Sc, F)               fn_proc(F)(Sc, cdr(F))
#endif
/* fx_call can affect the stack and sc->value */

#define car(P)                         (T_Pair(P))->object.cons.car
#define car_unchecked(P)               (T_Pos(P))->object.cons.car
#define set_car(P, Val)                car(P) = T_Pos(Val)            /* Val can be a slot or #<unused> or #<catch> etc */

#define cdr(P)                         (T_Pair(P))->object.cons.cdr
#define set_cdr_unchecked(P, Val)      cdr(P) = T_Exs(Val)            /* #<unused> in g_gc */
#define cdr_unchecked(P)               (T_Exs(P))->object.cons.cdr
#if s7_Debugging
  static void checked_set_cdr(s7_pointer p, s7_pointer Val, const char *func, int32_t line);
  #define set_cdr(P, Val)              checked_set_cdr(P, Val, __func__, __LINE__)
#else
  #define set_cdr(P, Val)              cdr(P) = T_Ext(Val)
#endif

#define caar(P)                        car(car(P))
#define cadr(P)                        car(cdr(P))
#define set_cadr(P, Val)               car(cdr(P)) = T_Exs(Val) /* #<unused> 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_ = A, _B_; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_Safe_Procedure); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;})
#else
  #define cons(Sc, A, B)               s7_cons(Sc, A, B)
#endif

#define list_1(Sc, A)                  cons(Sc, A, Sc->nil)
#define list_1_unchecked(Sc, A)        cons_unchecked(Sc, A, Sc->nil)
#define list_2(Sc, A, B)               cons_unchecked(Sc, A, cons(Sc, B, Sc->nil))
#define list_2_unchecked(Sc, A, B)     cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil))
#define list_3(Sc, A, B, C)            cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil)))
#define list_4(Sc, A, B, C, D)         cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil))))
#define with_list_t1(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 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, Slot) s7_t_slot_1(Sc, Slot, __func__, __LINE__)
const char *display(s7_pointer obj);
static s7_pointer s7_t_slot_1(s7_scheme *sc, s7_pointer symbol, const char *func, int line)
{
  s7_pointer slot = s7_slot(sc, symbol);
  if (type(slot) == T_SLOT) return(slot);
  fprintf(stderr, "%s[%d] (via s7_t_slot): symbol: %s, slot: %s\n", func, line, display(symbol), display(slot));
  return(slot);
}
#else
#define s7_t_slot(Sc, Slot) s7_slot(Sc, Slot)
#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, Id) (T_Sym(P))->object.sym.id = Id
#if s7_Debugging
static 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, Id)            (T_Sym(P))->object.sym.id = Id
#endif
/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate
 *    callgrind says this is faster than a uint32_t!
 */
#define symbol_info(P)                 (symbol_name_cell(P))->object.string.block
#define symbol_type(P)                 (block_size(symbol_info(P)) & 0xff)                    /* boolean function bool type, block_size is an s7_int */
#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)) = T_FREE
#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_category(P)             ((uint8_t)((block_size(symbol_info(P)) >> 16) & 0xff))
#define symbol_set_category(P, Type)   block_size(symbol_info(P)) = ((block_size(symbol_info(P)) & ~0xff0000) | (((Type) & 0xff) << 16))

#define REPORT_ROOTLET_REDEF 0
#if REPORT_ROOTLET_REDEF
  /* to find who is stomping on our symbols: */
  static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line);
  #define set_local(Symbol)            set_local_1(sc, T_Sym(Symbol), __func__, __LINE__)
#else
  #define set_local(P)                 full_type(T_Sym(P)) &= ~(T_Dont_Eval_Args | T_Syntactic)
  /* if symbol_increment_ctr, local shadowing value is not found? same if {} */
#endif
#define is_global(P)                   (symbol_id(P) == 0)
#define is_defined_global(P)           ((is_slot(global_slot(P))) && (symbol_id(P) == 0))

#define global_slot(P)                 T_Sld((T_Sym(P))->object.sym.global_slot)
#define set_global_slot(P, Val)        (T_Sym(P))->object.sym.global_slot = T_Sld(Val) /* #<undefined> 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 slot_set_value(P, Val)         (T_Slt(P))->object.slt.val = T_SetNmv(Val)
#define slot_set_value_unchecked(P, Val) (T_Slt(P))->object.slt.val = 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_SetNmv(Value)); else slot_set_value(T_Slt(Slot), Value);} while (0)
#define next_slot(P)                   T_Sln((T_Slt(P))->object.slt.nxt)
#define slot_set_next(P, Val)          (T_Slt(P))->object.slt.nxt = T_Sln(Val)
#define slot_set_pending_value(P, Val) do {(T_Slt(P))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(P);} while (0)
#define slot_simply_set_pending_value(P, Val) (T_Slt(P))->object.slt.pending_value = T_Nmv(Val)
#if s7_Debugging
static s7_pointer slot_pending_value(s7_pointer p) \
  {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "%s[%d]: slot: no pending value\n", __func__, __LINE__); abort(); return(NULL);}
static s7_pointer slot_expression(s7_pointer p)    \
  {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); abort(); return(NULL);}
#else
#define slot_pending_value(P)          (T_Slt(P))->object.slt.pending_value
#define slot_expression(P)             (T_Slt(P))->object.slt.expr
#endif
#define slot_pending_value_unchecked(P) (T_Slt(P))->object.slt.pending_value

#define slot_set_expression(P, Val)    do {(T_Slt(P))->object.slt.expr = T_Ext(Val); slot_set_has_expression(P);} while (0)
#define slot_just_set_expression(P, Val) (T_Slt(P))->object.slt.expr = T_Ext(Val)
#define slot_setter(P)                 T_Prc((T_Slt(P)->object.slt.pending_value))
#define slot_set_setter_1(P, Val)      (T_Slt(P))->object.slt.pending_value = T_Prc(Val)

#if s7_Debugging
  #define is_slot_checked(P)           ((P) && (T_Slt(P)))
#else
  #define is_slot_checked(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_slot_checked(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); 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
#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 set_curlet_unchecked(Sc, P)    Sc->curlet = 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) /* #<undefined> 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 is_numeric_vector(P)           ((t_vector_p[type(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 vector_bytes_unchecked(P)      (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]     /* vdims_dims(P) is p->dx.i_ptr */
#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 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__)
#else
  #define T_Itr_Pos(P)                 P
  #define T_Itr_Len(P)                 P
  #define T_Itr_Hash(P)                P
  #define T_Itr_Let(P)                 P
  #define T_Itr_Pair(P)                P
#endif

#define is_iterator(P)                 (type(P) == T_ITERATOR)
#define iterator_sequence(P)           (T_Itr(P))->object.iter.seq
#define iterator_position(P)           (T_Itr_Pos(P))->object.iter.lc.loc
#define iterator_length(P)             (T_Itr_Len(P))->object.iter.lw.len
#define iterator_next(P)               (T_Itr(P))->object.iter.next
#define iterator_current(P)            (T_Itr(P))->object.iter.cur
#define iterator_carrier(P)            (T_Itr(P))->object.iter.cur
#define iterator_is_at_end(P)          (!iter_ok(P))                /* ((full_type(T_Itr(p)) & T_Iter_Ok) == 0) */
#define iterator_at_end_value(Sc)      Sc->iterator_at_end_value

#define pair_iterator_slow(P)          T_Lst((T_Itr_Pair(P))->object.iter.lw.slow) /* applies only to pairs */
#define pair_iterator_set_slow(P, Val) (T_Itr_Pair(P))->object.iter.lw.slow = T_Lst(Val)
#define hash_iterator_entry(P)         (T_Itr_Hash(P))->object.iter.lw.entry       /* applies only to hash-tables */
#define let_iterator_slot(P)           T_Sln((T_Itr_Let(P))->object.iter.lc.slot)  /* applies only to lets */
#define let_iterator_set_slot(P, Val)  (T_Itr_Let(P))->object.iter.lc.slot = T_Sln(Val)

#define is_input_port(P)               (type(P) == T_INPUT_PORT)
#define is_output_port(P)              (type(P) == T_OUTPUT_PORT)
#define port_port(P)                   (T_Prt(P))->object.prt.port
#define is_any_port(P)                 ((is_input_port(P)) || (is_output_port(P)))
#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_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)  do {c_function_data(F)->setter = T_Prc(Val); if (is_any_macro(Val)) set_has_macro_setter(F); else clear_has_macro_setter(F);} while (0)
#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(P)                (T_CMac(P))->object.fnc.c_proc
#define c_macro_call(P)                (T_CMac(P))->object.fnc.ff
#define c_macro_name(P)                c_macro_data(P)->name
#define c_macro_name_length(P)         c_macro_data(P)->name_length
#define c_macro_min_args(P)            (T_CMac(P))->object.fnc.required_args
#define c_macro_max_args(P)            (T_CMac(P))->object.fnc.all_args
#define c_macro_setter(P)              T_Prc(c_macro_data(P)->setter)
#define c_macro_set_setter(P, Val)     do {c_macro_data(P)->setter = T_Prc(Val); if (is_any_macro(Val)) set_has_macro_setter(P); else clear_has_macro_setter(P);} while (0)

#define is_random_state(P)             (type(P) == T_RANDOM_STATE)
#define random_gmp_state(P)            (P)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */
#define random_seed(P)                 (T_Ran(P))->object.rng.seed
#define random_carry(P)                (T_Ran(P))->object.rng.carry

#define continuation_block(P)          (T_Con(P))->object.cwcc.block
#define continuation_stack(P)          T_Stk(T_Con(P)->object.cwcc.stack)
#define continuation_set_stack(P, Val) (T_Con(P))->object.cwcc.stack = T_Stk(Val)
#define continuation_stack_end(P)      (T_Con(P))->object.cwcc.stack_end
#define continuation_stack_start(P)    (T_Con(P))->object.cwcc.stack_start
#define continuation_stack_top(P)      (continuation_stack_end(P) - continuation_stack_start(P))
#define continuation_op_stack(P)       (T_Con(P))->object.cwcc.op_stack
#define continuation_stack_size(P)     continuation_block(P)->nx.ix.i1
#define continuation_op_loc(P)         continuation_block(P)->nx.ix.i2
#define continuation_op_size(P)        continuation_block(P)->ln.iter_or_size
#define continuation_key(P)            continuation_block(P)->ex.ckey
/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */
#define continuation_name(P)           continuation_block(P)->dx.d_ptr

#define call_exit_goto_loc(P)          (T_Got(P))->object.rexit.goto_loc
#define call_exit_op_loc(P)            (T_Got(P))->object.rexit.op_stack_loc
#define call_exit_active(P)            (T_Got(P))->object.rexit.active
#define call_exit_name(P)              (T_Got(P))->object.rexit.name

#define is_continuation(P)             (type(P) == T_CONTINUATION)
#define is_goto(P)                     (type(P) == T_GOTO)
#define is_macro(P)                    (type(P) == T_MACRO)
#define is_macro_star(P)               (type(P) == T_MACRO_STAR)
#define is_bacro(P)                    (type(P) == T_BACRO)
#define is_bacro_star(P)               (type(P) == T_BACRO_STAR)
#define is_either_macro(P)             ((is_macro(P)) || (is_macro_star(P)))
#define is_either_bacro(P)             ((is_bacro(P)) || (is_bacro_star(P)))

#define is_closure(P)                  (type(P) == T_CLOSURE)
#define is_closure_star(P)             (type(P) == T_CLOSURE_STAR)
#define closure_pars(P)                T_Arg((T_Clo(P))->object.func.args)
#define closure_set_pars(P, Val)       (T_Clo(P))->object.func.args = T_Arg(Val)
#define closure_body(P)                (T_Pair((T_Clo(P))->object.func.body))
#define closure_set_body(P, Val)       (T_Clo(P))->object.func.body = T_Pair(Val)
#define closure_let(P)                 T_Let((T_Clo(P))->object.func.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)     do {(T_Clo(P))->object.func.setter = T_Prc(Val); if (is_any_macro(Val)) set_has_macro_setter(P); else clear_has_macro_setter(P);} while (0)
#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) do {T_Clo(P)->object.func.setter = Val; if (is_any_macro(Val)) set_has_macro_setter(P); else clear_has_macro_setter(P);} while (0)
/* closure_map_list refers to a cyclic list detector in map */

#define Closure_Arity_Not_Set          0x40000000
#define MaxArity                       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
#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)

#if s7_Debugging
#define begin_temp(P, Val)             do {s7_pointer __val__ = Val; begin_temp_1(sc, P, __func__, __LINE__); P = __val__;} while (0)
static void begin_temp_1(s7_scheme *sc, s7_pointer p, 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);
      /* abort(); */ /* this happens when an error interrupts a loop (for-each etc) so end_temp is missed */
    }
  if (p == sc->y) sc->y_line = line;
  else
    if (p == sc->v) sc->v_line = line;
    else
      if (p == sc->x) sc->x_line = line;
      else sc->t_line = line;
}
#else
#define begin_temp(P, Val)              P = Val
#endif
#define end_temp(P)                     P = sc->unused
#define return_with_end_temp(Temp)      do {s7_pointer Result = Temp; end_temp(Temp); return(Result);} while (0)

#if __cplusplus && Have_Complex_Numbers
  static s7_double Real(complex<s7_double> x) {return(real(x));} /* protect the C++ name */
  static s7_double Imag(complex<s7_double> x) {return(imag(x));}
#endif

#define integer(P)                     (T_Int(P))->object.number.integer_value
#define set_integer(P, X)              integer(P) = X
#define real(P)                        (T_Rel(P))->object.number.real_value
#define set_real(P, X)                 real(P) = X
#define numerator(P)                   (T_Frc(P))->object.number.fraction_value.numerator
#define set_numerator(P, X)            numerator(P) = X
#define denominator(P)                 (T_Frc(P))->object.number.fraction_value.denominator
#define set_denominator(P, X)          denominator(P) = X
#define fraction(P)                    (((long_double)numerator(P)) / ((long_double)denominator(P)))
#define inverted_fraction(P)           (((long_double)denominator(P)) / ((long_double)numerator(P)))
#define real_part(P)                   (T_Cmp(P))->object.number.cz.complex_value.rl
#define set_real_part(P, X)            real_part(P) = X
#define imag_part(P)                   (T_Cmp(P))->object.number.cz.complex_value.im
#define set_imag_part(P, X)            imag_part(P) = X
#if WITH_CLANG_PP
#define a_bi(P)                        CMPLX((T_Cmp(P))->object.number.cz.complex_value.rl, p->object.number.cz.complex_value.im)
#else
#define a_bi(P)                        (T_Cmp(P))->object.number.cz.z
#define set_a_bi(P, X)                 a_bi(P) = X
#endif
#if Have_Complex_Numbers
  #define to_c_complex(P)              CMPLX(real_part(P), imag_part(P))
#endif

#if With_Gmp
#define big_integer(P)                 ((T_Bgi(P))->object.number.bgi->n)
#define big_integer_nxt(P)             (T_Bgi(P))->object.number.bgi->nxt
#define big_integer_bgi(P)             (T_Bgi(P))->object.number.bgi
#define big_ratio(P)                   ((T_Bgf(P))->object.number.bgr->q)
#define big_ratio_nxt(P)               (T_Bgf(P))->object.number.bgr->nxt
#define big_ratio_bgr(P)               (T_Bgf(P))->object.number.bgr
#define big_real(P)                    ((T_Bgr(P))->object.number.bgf->x)
#define big_real_nxt(P)                (T_Bgr(P))->object.number.bgf->nxt
#define big_real_bgf(P)                (T_Bgr(P))->object.number.bgf
#define big_complex(P)                 ((T_Bgz(P))->object.number.bgc->z)
#define big_complex_nxt(P)             (T_Bgz(P))->object.number.bgc->nxt
#define big_complex_bgc(P)             (T_Bgz(P))->object.number.bgc
#endif


#if s7_Debugging
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);
}
#define B_Print 1
#define BP(Obj) if (B_Print) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(Obj));
#else
#define B_Print 0
#define BP(Obj)
#define display(Obj) string_value(s7_object_to_string(sc, Obj, false))
#endif
#define display_truncated(Obj) string_value(object_to_string_truncated(sc, Obj))

#if s7_Debugging
static void check_mutable_bit(s7_pointer p)
{
  if ((is_number(p)) && (!is_mutable_number(p))) /* includes integer case */
    fprintf(stderr, "%s[%d]: mutable cleared already?\n", p->gc_func, p->gc_line);
}

static void set_alloc_info(s7_pointer p, const char *func, int32_t line)
{
  p->alloc_line = line;
  p->alloc_func = func;
}

static void set_type_1(s7_pointer p, s7_uint typ, const char *func, int32_t line)
{
  p->alloc_line = line;
  p->alloc_func = func;
  p->alloc_type = typ;
  p->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;
}
#else
  #define set_alloc_info(P, Func, Line)
#endif

static int32_t s7_int_digits_by_radix[17];

#define s7_Int_Bits 63

#define s7_Int64_Max 9223372036854775807LL
/* #define s7_Int64_Min -9223372036854775808LL */   /* why is this disallowed in C? "warning: integer constant is so large that it is unsigned" */
#define s7_Int64_Min (int64_t)(-s7_Int64_Max - 1LL) /* in gcc 9 we had to assign this to an s7_int, then use that! */

#define s7_Int32_Max 2147483647LL
#define s7_Int32_Min (-s7_Int32_Max - 1LL)

static void init_int_limits(void)
{
#if With_Gmp
  #define s7_Log_Int64_Max 36.736800
#else
  /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */
  #define s7_Log_Int64_Max 43.668274
#endif
  s7_int_digits_by_radix[0] = 0;
  s7_int_digits_by_radix[1] = 0;
  for (int32_t i = 2; i < 17; i++)
    s7_int_digits_by_radix[i] = (int32_t)(floor(s7_Log_Int64_Max / log((double)i)));
}

static s7_pointer make_permanent_integer(s7_int i)
{
  const 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_alloc_info(p, __func__, __LINE__);
  set_integer(p, i);
  return(p);
}

#define Num_Chars 256
#ifndef NUM_SMALL_INTS
  #define NUM_SMALL_INTS 8192
#else
#if (NUM_SMALL_INTS < Num_Chars) /* g_char_to_integer assumes this is at least Num_Chars, as does the byte_vector stuff (256) */
  #error NUM_SMALL_INTS is less than Num_Chars which will not work
#endif
#endif
/* if NUM_SMALL_INTS 256: tvect +240, trclo +200, tfft +170, trec +300, etc -- mostly gc + various adds */
/*                 16384: tvect 0,    trclo -20,  tfft 0,    trec -50 */
#define Num_Small_Ints NUM_SMALL_INTS

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, Num_Small_Ints needs to be a power of 2 */

/* these are constants */
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 */
  /* we only use 16 bytes of s7_cell for integers and floats, but if we used s7_small_cell here we'd need a ton of casts and repetitive
   *   functions (using s7_small_pointer not s7_pointer, etc);  the gain in space might be 256k bytes -- not worth the complexity.
   *   we could I suppose preset these built-in ints/floats at compile-time -- too ugly.
   */
  for (int32_t i = 0; i < Num_Small_Ints; i++)
    {
      const s7_pointer p = &small_ints[i];
      full_type(p) = T_Immutable | T_INTEGER | T_Unheap;
      set_integer(p, i);
      set_alloc_info(p, __func__, __LINE__);
    }
  /* 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); set_alloc_info(Ptr, __func__, __LINE__);} while (0)
  #define init_real(Ptr, Num) \
    do {full_type(Ptr) = T_REAL | T_Immutable | T_Unheap; set_real(Ptr, Num); set_alloc_info(Ptr, __func__, __LINE__);} 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); set_alloc_info(Ptr, __func__, __LINE__);} 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, MaxArity);
  Minus_One = &cells[8]; init_integer(Minus_One, -1);
  Minus_Two = &cells[9]; init_integer(Minus_Two, -2);
  Int_Zero = &small_ints[0];
  Int_One = &small_ints[1];
  Int_Two = &small_ints[2];
  Int_Three = &small_ints[3];

  MostFix = make_permanent_integer(s7_Int64_Max);
  LeastFix = make_permanent_integer(s7_Int64_Min);
  for (int32_t i = 0; i < Num_Chars; i++) t_number_separator_p[i] = true;
  t_number_separator_p[(uint8_t)'i'] = false;
  t_number_separator_p[(uint8_t)'+'] = false;
  t_number_separator_p[(uint8_t)'-'] = false;
  t_number_separator_p[(uint8_t)'/'] = false;
  t_number_separator_p[(uint8_t)'@'] = false;
  t_number_separator_p[(uint8_t)'.'] = false;
  t_number_separator_p[(uint8_t)'e'] = false;
  t_number_separator_p[(uint8_t)'E'] = false;
}

#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len))


/* -------------------------------------------------------------------------------- */
#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__))
  static inline s7_int my_clock(void)
  {
    struct timespec ts;
    clock_gettime(CLOCK_MONOTONIC, &ts);
    /* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17
     *   FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither
     *   clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec
     *   MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime
     *     apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12
     *   Windows has QueryPerformanceCounter or something
     * maybe just check for POSIX compatibility?
     */
    return(ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */
  }

  static s7_int ticks_per_second(void)
  {
    struct timespec ts;
    clock_getres(CLOCK_MONOTONIC, &ts);
    return((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec));
  }
#else
  #include <time.h>
  #define my_clock clock /* this is cpu time */
  #define ticks_per_second() CLOCKS_PER_SEC
#endif

#ifndef GC_TRIGGER_SIZE
  #define GC_TRIGGER_SIZE 64
#endif
#define Gc_Trigger_Size GC_TRIGGER_SIZE

#if s7_Debugging
  static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line);
  #define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__)
#else
  static void try_to_call_gc(s7_scheme *sc);
#endif

#define Gc_Stats 1
#define Heap_Stats 2
#define Stack_Stats 4
#define Protected_Objects_Stats 8

#define show_gc_stats(Sc)                ((Sc->gc_stats & Gc_Stats) != 0)
#define show_stack_stats(Sc)             ((Sc->gc_stats & Stack_Stats) != 0)
#define show_heap_stats(Sc)              ((Sc->gc_stats & Heap_Stats) != 0)
#define show_protected_objects_stats(Sc) ((Sc->gc_stats & Protected_Objects_Stats) != 0)


/* new_cell has to include the new cell's type.  In the free list, it is 0 (T_FREE).  If we remove it here,
 *   but then hit some error before setting the type, the GC sweep thinks it is a free cell already and
 *   does not return it to the free list: a memory leak.
 */
#if !s7_Debugging
#define new_cell(Sc, Obj, Type)			\
  do {						\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
    Obj = (*(--(Sc->free_heap_top))); \
    set_full_type(Obj, Type);	      \
    } while (0)

#define new_cell_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 Cell_Field_Init 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 = Cell_Field_Init; Obj->object.cons.cdr = Cell_Field_Init; \
    Obj->object.cons.opt1 = Cell_Field_Init; Obj->object.cons.o2.opt2 = Cell_Field_Init; Obj->object.cons.o3.opt3 = Cell_Field_Init; \
    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 = Cell_Field_Init; Obj->object.cons.cdr = Cell_Field_Init; \
    Obj->object.cons.opt1 = Cell_Field_Init; Obj->object.cons.o2.opt2 = Cell_Field_Init; Obj->object.cons.o3.opt3 = Cell_Field_Init; \
    set_full_type(Obj, Type);						\
    } while (0)
#endif

/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */


#if WITH_GCC
#define make_integer(Sc, N) \
  ({ s7_int _N_ = N; (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; (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_ = I; if (_im_ == 0.0) fprintf(stderr, "%s[%d]: make_complex i: %f\n", __func__, __LINE__, _im_); \
     ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}); })
#else
#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;})
#endif
#define make_complex(Sc, R, I) \
  ({ s7_double _im_ = 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_ = 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; ((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; ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : (s7_double)fraction(_x_)); })

#else

#define make_integer(Sc, N)              s7_make_integer(Sc, N)
#define make_integer_unchecked(Sc, N)    s7_make_integer(Sc, N)
#define make_real(Sc, X)                 s7_make_real(Sc, X)
#define make_real_unchecked(Sc, X)       s7_make_real(Sc, X)
#define make_complex(Sc, R, I)           s7_make_complex(Sc, R, I)
#define make_complex_unchecked(Sc, R, I) s7_make_complex(Sc, R, I)
#define make_complex_not_0i(Sc, R, I)    s7_make_complex(Sc, R, I)
#define real_to_double(Sc, X, Caller)    s7_number_to_real_with_caller(Sc, X, Caller)
#define rational_to_double(Sc, X)        s7_number_to_real(Sc, X)
#endif


/* --------------------------------------------------------------------------------
 * local versions of some standard C library functions
 * timing tests involving these are very hard to interpret, local_memset is faster using s7_int than int32_t
 * but don't replace local_memset and memclr64 with memset! tbig -> 208! (if aligned, other timings go up or down by 1-2%, no obvious winner)
 *   [tmac +55, tstar +40, concordance +40, tlist -30, tgc -40, tset -40, tform -20, tmv +0.2, tbig +63.1!]
 */

static void local_memset(void *s, uint8_t val, size_t n)
{
  uint8_t *s2;
#if s7_Aligned
  s2 = (uint8_t *)s;
#else
#if (defined(__x86_64__) || defined(__i386__))
  if (n >= 8)
    {
      s7_int *s1 = (s7_int *)s;
      size_t n8 = n >> 3;
      s7_int ival = val | (val << 8) | (val << 16) | (((s7_uint)val) << 24); /* s7_uint casts make gcc/clang/fsanitize happy */
      ival = (((s7_uint)ival) << 32) | ival;
      if ((n8 & 0x3) == 0)
	while (n8 > 0) {Loop_4(*s1++ = ival); n8 -= 4;}
      else do {*s1++ = ival;} while (--n8 > 0);
      n &= 7;
      s2 = (uint8_t *)s1;
    }
  else s2 = (uint8_t *)s;
#else
  s2 = (uint8_t *)s;
#endif
#endif
  while (n > 0)
    {
      *s2++ = val;
      n--;
    }
}

static inline s7_int safe_strlen(const char *str) /* this is safer than strlen, and slightly faster */
{
  const char *tmp = str;
  /* if ((!tmp) || (!*tmp)) return(0); */ /* removing *tmp check doesn't save any time, but looks better? */
  if (!tmp) return(0);
  for (; *tmp; ++tmp);
  return(tmp - str);
}

static char *copy_string_with_length(const char *str, s7_int len)
{
  char *newstr;
#if s7_Debugging
  if ((len <= 0) || (!str))
    {fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str); abort();}
#endif
  if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */
  newstr = (char *)Malloc(len + 1);
  memcpy((void *)newstr, (const void *)str, len); /* we check len != 0 above -- 24-Jan-22 */
  newstr[len] = '\0';
  return(newstr);
}

static char *copy_string(const char *str) {return(copy_string_with_length(str, safe_strlen(str)));}

#define local_strcmp(S1, S2) (strcmp(S1, S2) == 0)
#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2))  /* scheme strings can have embedded nulls */

static bool safe_strcmp(const char *s1, const char *s2)
{
  if ((!s1) || (!s2)) return(s1 == s2);
  return(local_strcmp(s1, s2));
}

static bool local_strncmp(const char *s1, const char *s2, size_t n) /* not strncmp because scheme strings can have embedded nulls */
{
#if ((!s7_Aligned) && (defined(__x86_64__) || defined(__i386__)))   /* unaligned accesses are safe on i386 hardware, sez everyone */
  if (n >= 8)
    {
      size_t n8 = n >> 3;
      s7_int *is1 = (s7_int *)s1, *is2 = (s7_int *)s2;
      do {if (*is1++ != *is2++) return(false);} while (--n8 > 0); /* in tbig Loop_4 is slower? */
      s1 = (const char *)is1;
      s2 = (const char *)is2;
      n &= 7;
    }
#endif
  while (n > 0)
    {
      if (*s1++ != *s2++) return(false); /* 45B in tbig!! v-big38 */
      n--;
    }
  return(true);
}

#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len))

static Sentinel size_t catstrs(char *dst, size_t len, ...) /* NULL-terminated arg list */
{
  const char *dend = (const char *)(dst + len - 1); /* -1 for null at end? */
  char *d = dst;
  va_list ap;
  while ((*d) && (d < dend)) d++; /* stop at NULL or end-of-buffer */
  va_start(ap, len);
  for (const char *s = va_arg(ap, const char *); s != NULL; s = va_arg(ap, const char *))
    while ((*s) && (d < dend)) {*d++ = *s++;}
  *d = '\0';
  va_end (ap);
  return(d - dst);
}

static Sentinel size_t catstrs_direct(char *dst, const char *str1, ...)
{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */
  char *d = dst;
  va_list ap;
  va_start(ap, str1);
  for (const char *s = str1; s != NULL; s = va_arg(ap, const char *))
    while (*s) {*d++ = *s++;}
  *d = '\0';
  va_end (ap);
  return(d - dst);
}

static char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc)
{
  char *p = (char *)(sc->int_to_str3 + Int_To_Str_Size - 1); /* str[31] */
  char *op = p;
  if ((s7_Debugging) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); abort();}
  *p-- = '\0';
  if (endc != '\0') *p-- = endc;
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  (*len) = op - p;           /* this includes the trailing #\null */
  return((char *)(p + 1));
}

static char *pos_int_to_str_direct(s7_scheme *sc, s7_int num)
{
  char *p = (char *)(sc->int_to_str4 + Int_To_Str_Size - 1);
  if ((s7_Debugging) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); abort();}
  *p-- = '\0';
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  return((char *)(p + 1));
}

static char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num)
{
  char *p = (char *)(sc->int_to_str5 + Int_To_Str_Size - 1);
  *p-- = '\0';
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  return((char *)(p + 1));
}

#if WITH_GCC
  #if s7_Debugging
    static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol);
    #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, T_Sym(Sym)), Sym, __LINE__, __func__)
    static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func);
    #define lookup_unexamined(Sc, Sym) lookup_1(Sc, T_Sym(Sym))
    #define lookup_checked(Sc, Sym) ({s7_pointer _x_ = lookup_1(Sc, T_Sym(Sym)); ((_x_) ? _x_ : unbound_variable(Sc, T_Sym(Sym)));})
  #else
    static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol);
    #define lookup_unexamined(Sc, Sym) lookup(Sc, Sym)
    #define lookup_checked(Sc, Sym) ({s7_pointer _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
  #endif
#else
  static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol);
  #define lookup_unexamined(Sc, Sym) s7_symbol_value(Sc, Sym)  /* changed 3-Nov-22 -- we're using lookup_unexamined below to avoid the unbound_variable check */
  #define lookup_checked(Sc, Sym) lookup(Sc, Sym)
#endif
static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let);
static inline s7_pointer lookup_slot_from(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_SPS, HOP_SAFE_C_SPS, OP_SAFE_C_AAP, HOP_SAFE_C_AAP,
      OP_SAFE_C_3P, HOP_SAFE_C_3P, OP_ANY_C_NP, HOP_ANY_C_NP,

      OP_THUNK, HOP_THUNK, OP_THUNK_O, HOP_THUNK_O, OP_THUNK_C, HOP_THUNK_C, 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_PAIR_S, 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_EXPANSION, OP_EXPANSION_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_MV,
      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_SP_1,
      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_T_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_T_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_T_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_IS_TYPE_S_A_P, OP_IF_IS_TYPE_T_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_SPS_1, OP_SAFE_C_AAP_1, OP_SAFE_C_AAP_2,
      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;

#if s7_Debugging
static const char *op_names[Num_Ops] =
     {"unopt", "gc_protect",

      "safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s",
      "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq",
      "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css",
      "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", "safe_c_ccs", "h_safe_c_ccs",
      "safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq", "safe_c_opsq", "h_safe_c_opsq",
      "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq",
      "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq",
      "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq",
      "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c",
      "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq",
      "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq",
      "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq",
      "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c",
      "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", "h_safe_c_op_opsqq",
      "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs",

      "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", "h_safe_c_sa", "safe_c_as", "h_safe_c_as",
      "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa", "h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a",
      "safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca",
      "safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas", "safe_c_saa", "h_safe_c_saa",
      "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", "safe_c_ass", "h_safe_c_ass",
      "safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg",
      "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq",
      "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", "safe_c_s_opaaq", "h_safe_c_s_opaaq",
      "safe_c*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_na", "h_safe_c*_na",

      "safe_c_p", "h_safe_c_p", "safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff", "safe_c_sp", "h_safe_c_sp",
      "safe_c_cp", "h_safe_c_cp", "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", "safe_c_ps", "h_safe_c_ps",
      "safe_c_pc", "h_safe_c_pc", "safe_c_sps", "h_safe_c_sps", "safe_c_aap", "h_safe_c_aap",
      "safe_c_3p", "h_safe_c_3p", "any_c_np", "h_any_c_np",

      "thunk", "h_thunk", "thunk_o", "h_thunk_o", "thunk_c", "h_thunk_c", "thunk_any", "h_thunk_any",
      "safe_thunk", "h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a", "safe_thunk_any", "h_safe_thunk_any",

      "closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o",
      "closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o", "closure_p", "h_closure_p",
      "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp",
      "closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss", "closure_ss_o", "h_closure_ss_o",
      "closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o",
      "closure_3s", "h_closure_3s", "closure_3s_o", "h_closure_3s_o", "closure_4s", "h_closure_4s", "closure_4s_o", "h_closure_4s_o", "closure_5s", "h_closure_5s",
      "closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o", "closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a",
      "closure_na", "h_closure_na", "closure_ass", "h_closure_ass", "closure_sas", "h_closure_sas ","closure_aas", "h_closure_aas",
      "closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa", "closure_ns", "h_closure_ns",

      "safe_closure_s", "h_safe_closure_s", "safe_closure_s_o", "h_safe_closure_s_o",
      "safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc",
      "safe_closure_p", "h_safe_closure_p", "safe_closure_p_a", "h_safe_closure_p_a",
      "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp",
      "safe_closure_a", "h_safe_closure_a", "safe_closure_a_o", "h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a",
      "safe_closure_a_to_sc", "h_safe_closure_a_to_sc",
      "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o", "h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a",
      "safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o", "h_safe_closure_sc_o",
      "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o", "h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a",
      "safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa", "h_safe_closure_ssa",
      "safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a", "h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na",
      "safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns", "h_safe_closure_ns",
      "safe_closure_3s_a", "h_safe_closure_3s_a",

      "any_closure_3p", "h_any_closure_3p", "any_closure_4p", "h_any_closure_4p", "any_closure_np", "h_any_closure_np",
      "any_closure_sym", "h_any_closure_sym", "any_closure_a_sym", "h_any_closure_a_sym",

      "closure*_a", "h_closure*_a", "closure*_na", "h_closure*_na",
      "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa",
      "safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1", "h_safe_closure*_a1",
      "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a",
      "safe_closure*_na", "h_safe_closure*_na", "safe_closure*_na_0", "h_safe_closure*_na_0",
      "safe_closure*_na_1", "h_safe_closure*_na_1", "safe_closure*_na_2", "h_safe_closure*_na_2",

      "c_ss", "h_c_ss", "c_s", "h_c_s", "c_sc", "h_c_sc", "read_s", "h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap",
      "c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_nc", "h_c_nc", "c_na", "h_c_na",

      "cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa", "h_cl_aa",
      "cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas",

      "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d",
      "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string",
      "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "a_sc", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa",
      "f", "f_a", "f_aa", "f_np", "f_np_1",

      "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate",
      "implicit_vector_ref_a", "implicit_vector_ref_aa",
      "implicit_string_ref_a", "implicit_c_object_ref_a", "implicit_pair_ref_a", "implicit_pair_ref_aa",
      "implicit_hash_table_ref_a", "implicit_hash_table_ref_aa",
      "implicit_let_ref_c", "implicit_let_ref_a", "implicit_*s7*_ref_s", "implicit_*s7*_set_s",
      "unknown_thunk", "unknown_ns", "unknown_na", "unknown_s", "unknown_gg", "unknown_a", "unknown_aa", "unknown_np",

      "symbol", "constant", "pair_sym", "pair_pair", "pair_pair_s", "pair_any", "h_hash_table_increment", "clear_opts",

      "read_internal", "eval", "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5",
      "eval_set1_no_mv", "eval_set2", "eval_set2_mv", "eval_set2_no_mv", "eval_set3", "eval_set3_mv", "eval_set3_no_mv",
      "apply", "eval_macro", "lambda", "quote", "quote_unchecked", "macroexpand", "call/cc", "call_with_exit", "call_with_exit_o",
      "c_catch", "c_catch_all", "c_catch_all_o", "c_catch_all_a",

      "define", "define1", "begin", "begin_hook", "begin_no_hook", "begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa",
      "if", "if1", "when", "unless", "set", "set1", "set2",
      "let", "let1", "let*", "let*1", "let*2", "let*-shadowed",
      "letrec", "letrec1", "letrec*", "letrec*1",
      "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1",
      "let_temp_s7", "let_temp_na", "let_temp_a", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind",
      "let_temp_a_a", "let_temp_s7_openlets", "let_temp_s7_openlets_unwind",
      "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_o", "cond1_simple_o",
      "and", "or",
      "define_macro", "define_macro*", "define_expansion", "define_expansion*", "macro", "macro*",
      "expansion", "expansion*",
      "case", "read_list", "read_next", "read_dot", "read_quote", "read_quasiquote", "read_unquote", "read_apply_values",
      "read_vector", "read_byte_vector", "read_int_vector", "read_float_vector", "read_complex_vector", "read_done",
      "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "splice_values", "no_values",
      "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", "profile_in",
      "define_constant", "define_constant1",
      "do", "do_end", "do_end1", "do_step", "do_step2", "do_init",
      "define*", "lambda*", "lambda*_default", "error_quit", "unwind_input", "unwind_output", "error_hook_quit",
      "with_let", "with_let1", "with_let_unchecked", "with_let_s",
      "with_baffle", "with_baffle_unchecked", "expansion_mv",
      "for_each", "for_each_1", "for_each_2", "for_each_3",
      "map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2", "map_gather_3", "map_unwind",
      "barrier", "deactivate_goto",
      "define_bacro", "define_bacro*", "bacro", "bacro*",
      "get_output_string",
      "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", "sort_string_end",
      "eval_string", "member_if", "assoc_if", "member_if1", "assoc_if1",
      "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all",
      "set_unchecked", "set_s_c", "set_s_s", "set_s_p", "set_s_a",
      "set_normal", "set_opsq_a", "set_opsaq_a", "set_opsaq_p", "set_opsaq_p_1", "set_opsaaq_a", "set_opsaaq_p", "set_opsaaq_p_1",
      "set_from_setter", "set_from_let_temp", "set_sp_1",
      "increment_1", "decrement_1", "increment_ss", "increment_sa", "increment_saa", "set_cons",
      "letrec_unchecked", "letrec*_unchecked", "cond_unchecked",
      "lambda*_unchecked", "do_unchecked", "define_unchecked", "define*_unchecked", "define_funchecked", "define_constant_unchecked",
      "define_with_setter",

      "let_no_vars", "named_let", "named_let_no_vars", "named_let_a", "named_let_aa", "named_let_na", "named_let*",
      "let_na_old", "let_na_new", "let_2a_old", "let_2a_new", "let_3a_old", "let_3a_new",
      "let_opassq_old", "let_opassq_new", "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new",
      "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1",
      "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new",
      "let_a_a_old", "let_a_a_new", "let_a_na_old", "let_a_na_new", "let_a_old_2", "let_a_new_2",
      "let*_na", "let*_na_a",

      "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_g",
      "case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g",
      "case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g",
      "case_a_i_s_a", "case_a_e_s_a", "case_a_g_s_a", "case_a_s_g_a",

      "if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p",
      "and_safe_p1", "and_safe_p2", "and_safe_p3", "and_safe_p_rest", "and_2a", "and_3a", "and_n", "and_s_2",
      "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", "or_s_type_2",
      "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", "when_and_3a", "unless_s", "unless_a", "unless_p",

      "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a",
      "if_b_a", "if_b_p", "if_b_r",  "if_b_a_p", "if_b_p_a", "if_b_p_p", "if_b_n_n",
      "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_s_a_p", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n",
      "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n",
      "if_is_type_s_p", "if_is_type_t_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_t_r", "if_is_type_s_n", "if_is_type_s_n_n",
      "if_is_type_s_p_a", "if_is_type_t_p_a", "if_is_type_s_a_a", "if_is_type_s_a_p", "if_is_type_t_a_p",
      "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n",
      "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n",
      "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n",
      "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n",
      "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n",
      "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n",
      "if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n",
      "if_pp", "if_ppp", "if_pn", "if_pr", "if_prr", "when_pp", "unless_pp",

      "cond_na_na", "cond_na_np", "cond_na_np_1", "cond_na_2e", "cond_na_3e", "cond_na_np_o",
      "cond_feed", "cond_feed_1",

      "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_o",
      "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", "dox_no_body", "dox_pending_no_body", "dox_init",
      "dotimes_p", "dotimes_step_o",
      "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1",
      "do_no_body_na_vars", "do_no_body_na_vars_step", "do_no_body_na_vars_step_1",

      "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5",
      "safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv", "safe_c_3p_2_mv", "safe_c_3p_3_mv",
      "safe_c_sp_1", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_c_ps_1", "safe_c_pc_1",
      "eval_macro_mv", "macroexpand_1", "apply_lambda",
      "any_c_np_1", "any_c_np_mv", "safe_c_sps_1", "safe_c_aap_1", "safe_c_aap_2",
      "c_p_1", "c_ap_1", "any_c_np_2", "safe_c_pa_1",
      "set_with_let_1", "set_with_let_2",

      "closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1",
      "safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_1",
      "any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3", "any_closure_np_1",
      "any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3", "any_closure_4p_4", "any_closure_np_2",

      "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_l2a", "tc_or_a_and_a_l2a", "tc_and_a_or_a_l3a", "tc_or_a_and_a_l3a",
      "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la",
      "tc_when_la", "tc_when_l2a", "tc_when_l3a", "tc_let_when_l2a",
      "tc_cond_a_z_a_l2a_l2a", "tc_let_cond", "tc_cond_n",
      "tc_if_a_z_la", "tc_if_a_z_l2a", "tc_if_a_z_l3a",
      "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_l2a", "tc_if_a_z_if_a_l2a_z",
      "tc_if_a_z_if_a_z_l3a", "tc_if_a_z_if_a_l3a_z", "tc_if_a_z_if_a_l3a_l3a",
      "tc_let_if_a_z_la", "tc_let_if_a_z_l2a", "if_a_z_let_if_a_z_l2a",
      "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z",
      "tc_case_la", "tc_case_l2a", "tc_case_l3a",

      "recur_if_a_a_opla_laq", "recur_if_a_a_opl2a_l2aq", "recur_if_a_a_opl3a_l3aq",
      "recur_if_a_a_opa_laq", "recur_if_a_a_opa_l2aq", "recur_if_a_a_opa_l3aq",
      "recur_if_a_a_opla_la_laq", "recur_if_a_a_and_a_l2a_l2a", "recur_if_a_a_opa_la_laq",
      "recur_if_a_a_if_a_a_opla_laq", "recur_if_a_a_if_a_a_opl2a_l2aq", "recur_if_a_a_if_a_a_opl3a_l3aq",
      "recur_if_a_a_if_a_l2a_opa_l2aq", "recur_cond_a_a_a_a_opa_l2aq",
      "recur_cond_a_a_a_l2a_lopa_l2aq", "recur_and_a_or_a_l2a_l2a"
};
#endif

#define is_safe_c_op(Op)            ((Op >= OP_SAFE_C_NC) && (Op < OP_THUNK))
#define is_safe_closure_op(Op)      ((Op >= OP_SAFE_CLOSURE_S) && (Op < OP_ANY_CLOSURE_3P))
#define is_safe_closure_star_op(Op) ((Op >= OP_SAFE_CLOSURE_STAR_A) && (Op < OP_C_SS))
#define is_unknown_op(Op)           ((Op >= OP_UNKNOWN) && (Op <= OP_UNKNOWN_NP))
#define is_h_safe_c_nc(P)           (optimize_op(P) == HOP_SAFE_C_NC)
#define is_safe_c_s(P)              ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S))
#define is_h_safe_c_s(P)            (optimize_op(P) == HOP_SAFE_C_S)
#define First_Unhoppable_Op OP_APPLY_SS

static bool is_h_optimized(s7_pointer p)
{
  return((is_optimized(p)) &&
	 (op_has_hop(p)) &&
	 (optimize_op(p) < First_Unhoppable_Op) &&  /* was OP_S? */
	 (optimize_op(p) > OP_GC_PROTECT));
}

/* if this changes, remember to change lint.scm */
typedef enum {sl_No_Field=0, sl_Accept_All_Keyword_Arguments, sl_Autoloading, sl_Bignum_Precision, sl_Catches, sl_Cpu_Time, sl_C_Types,
	      sl_Debug, sl_Default_Hash_Table_Length, sl_Default_Random_State, sl_Default_Rationalize_Error, sl_Equivalent_Float_Epsilon,
	      sl_Expansions, sl_Filenames, sl_File_Names, sl_Float_Format_Precision, sl_Free_Heap_Size, sl_gc_Freed, sl_Gc_Info,
	      sl_Gc_Protected_Objects, sl_Gc_Resize_Heap_By_4_Fraction, sl_Gc_Resize_Heap_Fraction, sl_Gc_Stats, sl_Gc_Temps_Size,
	      sl_Gc_Total_Freed, sl_Hash_Table_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?", "bignum-precision", "catches", "cpu-time", "c-types",
   "debug", "default-hash-table-length", "default-random-state", "default-rationalize-error", "equivalent-float-epsilon",
   "expansions?", "filenames", "file-names", "float-format-precision", "free-heap-size", "gc-freed", "gc-info",
   "gc-protected-objects", "gc-resize-heap-by-4-fraction", "gc-resize-heap-fraction", "gc-stats", "gc-temps-size",
   "gc-total-freed", "hash-table-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);
static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article);
static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b);
static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); /* see lookup_checked */


#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 */

#define Num_String_Wrappers 8
#define Num_Integer_Wrappers 8
#define Num_Real_Wrappers 8
#define Num_Complex_Wrappers 8
#define Num_Let_Wrappers 4
#define Num_Slot_Wrappers 4
#define Num_C_Pointer_Wrappers 16 /* need at least 9 for gsl */


/* -------------------------------- 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 <signal.h>
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 */
{
  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);
  {
    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);
#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 TRAP_SEGFAULT
      signal(SIGSEGV, old_segv);
    }
  else result = false;
  can_jump = 0;
#endif
  return(result);
}

#define safe_print(Code)	   \
  do {				   \
    bool _Old_Open_ = sc->has_openlets;  \
    sc->has_openlets = false;      \
    Code;			   \
    sc->has_openlets = _Old_Open_;   \
  } while (0)

void s7_show_history(s7_scheme *sc);
void s7_show_history(s7_scheme *sc)
{
#if With_History
  if (sc->cur_code == sc->history_sink)
    fprintf(stderr, "history diabled\n");
  else
    {
      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));
#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" :
						     ((is_any_port(obj)) ? " string-port" :
						      " ?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-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" :
						     ((is_any_port(obj)) ? " file-port" :
						      " ?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" :
						       ((is_any_port(obj)) ? " function-port" :
							" ?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" :
						       ((is_any_procedure(obj)) ? " has-macro-setter" : /* is_any_procedure is type >= T_CLOSURE */
							" ?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" :
							((is_string(obj)) ? " wrapper" :
							 " ?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_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_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_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_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_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_Case_Key) != 0) ?       ((is_symbol(obj)) ? " case-key" :  /* T_Ext */
						  ((is_pair(obj)) ? " opt1-func-listed" :
						   " ?33?")) : "",
	  /* bit 34+24 */
	  ((full_typ & T_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_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_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_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 Bits_Bufsize 1024
    char *buf = (char *)Malloc(Bits_Bufsize);
    snprintf(buf, Bits_Bufsize, "%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);
    /* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */
    return(buf);
  }
}

void s7_decode_type(s7_pointer p, s7_uint new_type);
void s7_decode_type(s7_pointer p, s7_uint new_type) /* just pass any valid s7_pointer! This is for GC debugging (in gdb primarily). */
{
  const s7_uint old_type = p->tf.u64_type;
  char *str;
  p->tf.u64_type = new_type;
  str = describe_type_bits(cur_sc, p);
  p->tf.u64_type = old_type;
  fprintf(stderr, "%s\n", str);
  free(str);
}

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)) && (!is_any_port(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)) && (!is_any_port(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_Case_Key) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true);
  if (((full_typ & T_Unknopt) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_c_function(obj))) return(true);
  if (((full_typ & T_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_Allow_Other_Keys) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj)) &&
      (!is_let(obj)) && (!is_any_port(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_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_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_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_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_string(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)) && (!is_any_procedure(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_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_Has_Fn) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_syntax(obj)) && (!is_c_function(obj))) return(true);
  if (((full_typ & T_True_Is_Done) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_c_function(obj))) return(true);
  if (is_symbol(obj))
    {
      if (((block_size(symbol_info(obj))) & ~0xffffff) != 0) /* boolean function bool type, *s7*_let field id, symbol_catetgory */
	return(true);
      if ((uint8_t)(symbol_type(obj) & 0xff) >= Num_Types)
	return(true);
      if (symbol_category(obj) > 14) /* e_boolean see init_rootlet */
	return(true);
      if (starlet_symbol_id(obj) >= sl_Num_Fields)
	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);}
    }
  /* all the hash_table bits seem to be compatible, symbols? (all_float/all_integer only apply to sc->divide_symbol et al at init time) */
  return(false);
}

void s7_show_let(s7_scheme *sc);
void s7_show_let(s7_scheme *sc) /* debugging convenience */
{
  for (s7_pointer 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!");
}

#if REPORT_ROOTLET_REDEF
static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line)
{
  if (is_defined_global(symbol))
    fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, Bold_Text, display(symbol), Unbold_Text, display_truncated(sc->cur_code));
  full_type(symbol) = (full_type(symbol) & ~(T_Dont_Eval_Args | T_Syntactic));
}
#endif

static char *object_raw_type_to_string(s7_pointer p)
{
  #define Raw_Bufsize 128
  char *buf = (char *)Malloc(Raw_Bufsize);
  snprintf(buf, Raw_Bufsize, "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);
  abort();
}

static char *show_debugger_bits(s7_pointer p)
{
  #define Show_Bufsize 512
  char *bits_str = (char *)Malloc(Show_Bufsize);
  const s7_int bits = p->debugger_bits;
  snprintf(bits_str, Show_Bufsize, " %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); abort();}
  {
    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);
	    abort();
	  }
	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); abort();}
      }}
  return(p);
}

static 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 is not in the heap, but slot is\n", func, line); */
  /*   probably a let wrapper */
  if ((let == sc->rootlet) && (slot != Slot_End)) {fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line); 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_set(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_ref_one(p, T_LET, func, line, NULL, NULL);
  p->debugger_bits &= (~L_Mask);
  p->debugger_bits |= (L_Hit | role);
  return(p);
}

static s7_pointer check_ref_two(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2)
{
  if (!p)
    fprintf(stderr, "%s[%d]: null pointer passed to check_ref_two\n", func, line);
  else
    {
      uint8_t typ = 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);
  if ((typ != T_PAIR) && (p != cur_sc->F))
    complain(cur_sc, "%s%s[%d]: not a pair or #f, but %s (%s)%s\n", p, func, line, typ);
  return(p);
}

static s7_pointer check_ref_prt(s7_pointer p, const char *func, int32_t line)
{
  uint8_t typ = 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);
}

static s7_pointer check_ref_pri(s7_pointer p, const char *func, int32_t line)
{
  const 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);
}

static s7_pointer check_ref_pro(s7_pointer p, const char *func, int32_t line)
{
  const 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);
}

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_mset(s7_pointer p, const char *func, int32_t line)
{
  uint8_t typ = type_unchecked(p);
  if (typ < T_CLOSURE) complain(cur_sc, "%s%s[%d]: not any procedure (type >= T_CLOSURE, from T_MSet), 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)
{
  const 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)
{
  const 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)
{
  const 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)
{
  const 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_app(s7_pointer p, const char *func, int32_t line)
{
  const 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_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 #<undefined> */
    complain(cur_sc, "%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ);
  return(p);
}

static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line)
{
  uint8_t typ;
  if (!p) return(NULL);
  typ = 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;
	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);
	sc->printing_gc_info = false;
	full_type(obj) = free_type;
	fprintf(stderr, "%s%p is free (%s[%d], alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], gc: %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->gc_func, obj->gc_line, obj->uses, Unbold_Text);
	fprintf(stderr, "\n");
	free(bits);
      }
  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); abort();}
  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); 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);
      abort();
    }
  return(p);
}

static const char *pointer_to_name(s7_scheme *sc, s7_pointer p, const char *func)
{
  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");

  if (p == sc->v)       return("sc->v");
  if (p == sc->y)       return("sc->v");
  if ((strcmp(func, "make_sharp_constant") != 0) && (p == sc->w)) return("sc->w");
  if (p == sc->x)       return("sc->x");
  if (p == sc->z)       return("sc->z");
  if (p == sc->temp1)   return("sc->temp1");
  if (p == sc->temp2)   return("sc->temp2");
  if (p == sc->temp3)   return("sc->temp3");
  if (p == sc->temp4)   return("sc->temp4");
  if (p == sc->temp5)   return("sc->temp5");
  if (p == sc->temp6)   return("sc->temp6");
  if (p == sc->temp7)   return("sc->temp7");
  if (p == sc->temp8)   return("sc->temp8");
  if (p == sc->temp9)   return("sc->temp9");

  if (p == sc->t1_1)    return("sc->t1_1");
  if (p == sc->t2_1)    return("sc->t2_1");
  if (p == sc->t2_2)    return("sc->t2_2");
  if (p == sc->t3_1)    return("sc->t3_1");
  if (p == sc->t3_2)    return("sc->t3_2");
  if (p == sc->t3_3)    return("sc->t3_3");
  if (p == sc->t4_1)    return("sc->t4_1");
  if (p == sc->u1_1)    return("sc->u1_1");

  if (p == sc->elist_1) return("sc->elist_1");
  if (p == sc->elist_2) return("sc->elist_2");
  if (p == sc->elist_3) return("sc->elist_3");
  if (p == sc->elist_4) return("sc->elist_4");
  if (p == sc->elist_5) return("sc->elist_5");
  if (p == sc->elist_6) return("sc->elist_6");
  if (p == sc->elist_7) return("sc->elist_7");

  if (p == sc->plist_1) return("sc->plist_1");
  if (p == sc->plist_2) return("sc->plist_2");
  if (p == sc->plist_3) return("sc->plist_3");
  if (p == sc->plist_4) return("sc->plist_4");
  if (p == sc->qlist_2) return("sc->qlist_2");
  if (p == sc->qlist_3) return("sc->qlist_3");
  if (p == sc->clist_1) return("sc->clist_1");
  if (p == sc->clist_2) return("sc->clist_2");
  if (p == sc->dlist_1) return("sc->dlist_1");
  if (p == sc->mlist_1) return("sc->mlist_1");
  if (p == sc->mlist_2) return("sc->mlist_2");

  return(NULL);
}

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); abort();}
  return(p);
}

static s7_pointer check_set_nmv(s7_pointer p, const char *func, int32_t line)
{
#if 0
  const char *named_pointer = pointer_to_name(cur_sc, p, func);
  check_ref_nmv(p, func, line);
  if (named_pointer)
    fprintf(stderr, "%s[%d]: set slot value to %s\n", func, line, named_pointer);
#else
  check_ref_nmv(p, func, line);
#endif
  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);
	  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_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); abort();}
  return(p);
}

static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line)
{
  uint8_t typ;
  check_nref(p, func, line);
  typ = 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); abort();}
  return(p);
}

static s7_pointer check_opcode(s7_pointer p, const char *func, int32_t line)
{
  const 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); abort();}
  return(p);
}

static void checked_set_cdr(s7_pointer p, s7_pointer val, const char *func, int32_t line)
{
  if ((is_immutable(p)) && (!in_heap(p)))
    {fprintf(stderr, "%s[%d]: set-cdr! target is immutable and not in the heap, %p %s\n", func, line, p, display(p)); 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_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);
      abort();
    }
  return(p->object.cons.opt1);
}

static void base_opt1(s7_pointer p, s7_uint role)
{
  set_opt1_role(p, role);
  set_opt1_is_set(p);
}

static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, s7_uint role, const char *func, int32_t line)
{
  if (((p->debugger_bits & Opt1_Mask) != role) &&
      ((p->debugger_bits & Opt1_Mask) == Opt1_Lambda) &&
      (role != Opt1_Cfunc))
    fprintf(stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n    %s\n",
	    func, line, opt1_role_name(role),
	    (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt",
	    display(x), display(p));
  p->object.cons.opt1 = x;
  base_opt1(p, role);
  return(x);
}

static s7_uint opt1_hash_1(s7_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);
      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_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); abort();}
  if ((!opt2_is_set(p)) ||
      (!opt2_role_matches(p, role)))
    {
      show_opt2_bits(p, func, line, role);
      abort();
    }
}

static s7_pointer opt2_1(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_opt2_bits(p, role, func, line);
  return(p->object.cons.o2.opt2);
}

static s7_int opt2_n_1(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_opt2_bits(p, role, func, line);
  return(p->object.cons.o2.n);
}

static void base_opt2(s7_pointer p, s7_uint role)
{
  set_opt2_role(p, role);
  set_opt2_is_set(p);
}

static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, s7_uint role, const char *func, int32_t line)
{
  if ((role == Opt2_Fx) &&
      (x == NULL) &&
      (f_call_func_mismatch(func)))
    fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", func, line,
	    string_value(object_to_string_truncated(sc, p)),
	    ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? Bold_Text : "",
	    op_names[optimize_op(car(p))],
	    ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? Unbold_Text : "");
  if ((role != Opt2_Fx) && (role != Opt2_Direct) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */
    {fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_truncated(p)); 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)); 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_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);
      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_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); abort();}
  if ((!opt3_is_set(p)) ||
      (!opt3_role_matches(p, role)))
    {
      show_opt3_bits(p, func, line, role);
      abort();
    }
}

static s7_pointer opt3_1(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_opt3_bits(p, role, func, line);
  return(p->object.cons.o3.opt3);
}

static s7_int opt3_n_1(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_opt3_bits(p, role, func, line);
  return(p->object.cons.o3.n);
}

static void base_opt3(s7_pointer p, s7_uint role)
{
  set_opt3_role(p, role);
  set_opt3_is_set(p);
}

static void set_opt3_1(s7_pointer p, s7_pointer x, s7_uint role)
{
  clear_type_bit(p, T_Location);
  p->object.cons.o3.opt3 = x;
  base_opt3(p, role);
}

static void set_opt3_n_1(s7_pointer p, s7_int x, s7_uint role)
{
  clear_type_bit(p, T_Location);
  p->object.cons.o3.n = x;
  base_opt3(p, role);
}

static uint8_t opt3_byte_1(s7_pointer p, s7_uint role, const char *func, int32_t line)
{
  check_opt3_bits(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_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);
      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_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);
      abort();
    }
  return(p->object.sym_cons.location);
}

static void set_opt3_len_1(s7_pointer p, s7_uint x)
{
  clear_type_bit(p, T_Location);
  p->object.sym_cons.location = x;
  (p)->debugger_bits = (Opt3_Len | (p->debugger_bits & ~(Opt3_Location)));
  set_opt3_is_set(p);
}

static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  /* show current state, current allocated state */
  char *allocated_bits;
  const s7_int save_full_type = full_type(obj);
  set_full_type(obj, obj->alloc_type);
  allocated_bits = describe_type_bits(sc, obj);
  set_full_type(obj, save_full_type);
  {
    const char *excl_name = (is_free(obj)) ? "free cell!" : "unknown object!";
    char *current_bits = describe_type_bits(sc, obj);
    const s7_int len = safe_strlen(excl_name) + safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(obj->alloc_func) + 512;
    s7_int nlen;
    block_t *b = mallocate(sc, len);
    char *str = (char *)block_data(b);

    nlen = snprintf(str, len, "\n<%s %s,\n  alloc: %s[%d] %s, uses: %d>", 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) /* the result of lookup_1 */
    {
      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");
      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 */
{
  /* using circular lists here is much faster than using an array of s7_cells and an integer location */
  const 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));
  sc->integer_wrapper_allocs++;
#endif
  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_real(s7_scheme *sc, s7_double x)
{
  const 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));
  sc->real_wrapper_allocs++;
#endif
  set_real(wrapped_real, x);
  sc->real_wrappers = cdr(sc->real_wrappers);
  return(wrapped_real);
}

s7_pointer s7_wrap_real(s7_scheme *sc, s7_double x)
{
  const s7_pointer wrapped_real = car(sc->real_wrappers);
  set_real(wrapped_real, x);
  sc->real_wrappers = cdr(sc->real_wrappers);
  return(wrapped_real);
}

#if !With_Gmp
static s7_pointer wrap_complex(s7_scheme *sc, s7_double rl, s7_double im)
{
  const 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));
  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);
}

static s7_pointer wrap_real_or_complex(s7_scheme *sc, s7_double rl, s7_double im)
{
  if (im == 0.0) return(wrap_real(sc, rl));
  return(wrap_complex(sc, rl, im));
}
#else
#define wrap_complex(Sc, A, B) make_complex(Sc, A, B)
#define wrap_real_or_complex(Sc, A, B) make_complex(Sc, A, B)
#endif

static s7_pointer wrap_let(s7_scheme *sc, s7_pointer old_let)
{
  const s7_pointer wrapped_let = car(sc->let_wrappers);
#if s7_Debugging
  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);
}

static s7_pointer wrap_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
{
  const s7_pointer wrapped_slot = car(sc->slot_wrappers);
#if s7_Debugging
  sc->slot_wrapper_allocs++;
#endif
  slot_set_symbol_and_value(wrapped_slot, symbol, value);
  sc->slot_wrappers = cdr(sc->slot_wrappers);
  return(wrapped_slot);
}

/* -------- prebuilt lists -------- */
static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1)
{
  set_car(sc->elist_1, x1);
  return(sc->elist_1);
}

static s7_pointer set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
{
  set_car(sc->elist_2, x1);
  set_cadr(sc->elist_2, x2);
  return(sc->elist_2);
}

static s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3)
{
  s7_pointer p = sc->elist_3;
  set_car(p, x1); p = cdr(p);
  set_car(p, x2); p = cdr(p);
  set_car(p, x3);
  return(sc->elist_3);
}

static s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
{
  s7_pointer p = sc->elist_4;
  set_car(p, x1); p = cdr(p);
  set_car(p, x2); p = cdr(p);
  set_car(p, x3); p = cdr(p);
  set_car(p, x4);
  return(sc->elist_4);
}

static s7_pointer set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5)
{
  set_car(sc->elist_5, x1);
  set_elist_4(sc, x2, x3, x4, x5);
  return(sc->elist_5);
}

static s7_pointer set_elist_6(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6)
{
  set_car(sc->elist_6, x1);
  set_elist_5(sc, x2, x3, x4, x5, x6);
  return(sc->elist_6);
}

static s7_pointer set_elist_7(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7)
{
  set_car(sc->elist_7, x1);
  set_elist_6(sc, x2, x3, x4, x5, x6, x7);
  return(sc->elist_7);
}

static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3)
{
  s7_pointer p = lst;
  set_car(p, x1); p = cdr(p);
  set_car(p, x2); p = cdr(p);
  set_car(p, x3);
  return(lst);
}

static s7_pointer set_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
{
  s7_pointer p = lst;
  set_car(p, x1); p = cdr(p);
  set_car(p, x2); p = cdr(p);
  set_car(p, x3); p = cdr(p);
  set_car(p, x4);
  return(lst);
}

static s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1)
{
  set_car(sc->mlist_1, x1);
  return(sc->mlist_1);
}

static s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */
{
  set_car(sc->mlist_2, x1);
  set_cadr(sc->mlist_2, x2);
  return(sc->mlist_2);
}

static s7_pointer set_plist_1(s7_scheme *sc, s7_pointer x1)
{
  set_car(sc->plist_1, x1);
  return(sc->plist_1);
}

static s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
{
  set_car(sc->plist_2, x1);
  set_car(sc->plist_2_2, x2);
  return(sc->plist_2);
}

static s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3)
{
  return(set_wlist_3(sc->plist_3, x1, x2, x3));
}

static s7_pointer set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
{
  return(set_wlist_4(sc->plist_4, x1, x2, x3, x4));
}

static s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */
{
  set_car(sc->qlist_2, x1);
  set_cadr(sc->qlist_2, x2);
  return(sc->qlist_2);
}

static s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */
{
  return(set_wlist_3(sc->qlist_3, x1, x2, x3));
}

static s7_pointer set_clist_1(s7_scheme *sc, s7_pointer x1) /* for c_object length method etc, a "weak" list */
{
  set_car(sc->clist_1, x1);
  return(sc->clist_1);
}

static s7_pointer set_clist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* for c_object equal method etc, a "weak" list */
{
  set_car(sc->clist_2, x1);
  set_cadr(sc->clist_2, x2);
  return(sc->clist_2);
}

static s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1) /* another like clist: temp usage, "weak" (not gc_marked), but semipermanent list */
{
  set_car(sc->dlist_1, x1);
  return(sc->dlist_1);
}

static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
{
  set_car(sc->u1_1, x1);
  set_cdr_unchecked(sc->u1_1, x2);
  return(sc->u1_1);
}


/* ---------------- error handlers ---------------- */
static const char *make_type_name(s7_scheme *sc, const char *name, article_t article)
{
  s7_int i;
  const s7_int slen = safe_strlen(name);
  const s7_int len = slen + 8;
  if (len > sc->typnam_len)
    {
      if (sc->typnam) free(sc->typnam);
      sc->typnam = (char *)Malloc(len);
      sc->typnam_len = len;
    }
  if (article == Indefinite_Article)
    {
      i = 1;
      sc->typnam[0] = 'a';
      if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u'))
	sc->typnam[i++] = 'n';
      sc->typnam[i++] = ' ';
    }
  else i = 0;
  memcpy((void *)(sc->typnam + i), (const void *)name, slen);
  sc->typnam[i + slen] = '\0';
  return(sc->typnam);
}

static const char *type_name_from_type(int32_t typ, article_t article)
{
  static const char *articled[] =
    {"a free cell", "a pair", "nil", "the unused object", "an undefined object", "the unspecified object", "the end-of-file object",
     "boolean", "a character", "syntactic", "a symbol", "an integer", "a ratio", "a real", "a complex number", "a big integer",
     "a big ratio", "a big real", "a big complex number", "a string", "a c-object", "a vector", "an int-vector", "a float-vector",
     "a byte-vector", "a complex-vector", "a catch", "a dynamic-wind", "a hash-table", "a let", "an iterator", "a stack",
     "an internal-counter", "a slot (variable binding)", "a c-pointer", "an output-port", "an input-port", "a random-state",
     "a continuation", "a goto (from call-with-exit)", "a function", "a function*", "a macro", "a macro*", "a bacro", "a bacro*",
     "a c-macro", "a c-function*", "a c-function", "a c-function"};

  static const char *unarticled[] =
    {"free-cell", "pair", "nil", "#<unused>", "#<undefined>", "#<unspecified>", "#<eof>",
     "boolean", "character", "syntax", "symbol", "integer", "ratio", "real", "complex-number", "big-integer",
     "big-ratio", "big-real", "big-complex-number", "string", "c-object", "vector", "int-vector", "float-vector",
     "byte-vector", "complex-vector", "catch", "dynamic-wind", "hash-table", "let", "iterator", "stack",
     "internal-counter", "slot", "c-pointer", "output-port", "input-port", "random-state",
     "continuation", "goto", "function", "function*", "macro", "macro*", "bacro", "bacro*",
     "c-macro", "c-function*", "c-function", "c-function"};

  if (typ >= Num_Types) return(NULL);
  return((article == No_Article) ? unarticled[typ] : articled[typ]);
}

static s7_pointer find_let(s7_scheme *sc, s7_pointer obj)
{
  if ((s7_Debugging) && (is_let(obj))) {fprintf(stderr, "let passed to find_let: %s\n", display(obj)); abort();}
  if (has_closure_let(obj)) return(closure_let(obj)); /* some of these are immutable -- they hold the parameter names */
  switch (type(obj))
    {
    case T_C_OBJECT:
      if (is_let(c_object_let(obj))) return(c_object_let(obj));
      return(sc->rootlet);
    case T_C_POINTER:
      if (is_let(c_pointer_info(obj))) return(c_pointer_info(obj));
      return(sc->rootlet);
    case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION:
      return(c_function_let(obj));
    }
  return(sc->nil);
}

s7_pointer s7_function_let(s7_scheme *sc, s7_pointer obj) {return(c_function_let(obj));}

static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
{
  s7_pointer slot;
  if (is_global(symbol)) /* this means the symbol has never been bound locally, so how can it be a method? */
    return(sc->undefined);
  slot = lookup_slot_from(symbol, let);
  if (slot != global_slot(symbol))
    return(slot_value(slot));
  return(sc->undefined);
}

static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
{
  if (!is_let(let)) let = find_let(sc, let);
  return(find_method(sc, let, symbol));
}

static s7_pointer find_method_with_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer symbol)
{
  s7_pointer let = c_object_let(c_obj);
  return(find_method(sc, (is_let(let)) ? let : sc->rootlet, symbol));
}

static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article)
{
  switch (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 s7_pointer object_type_name(s7_scheme *sc, s7_pointer obj) /* used only by the error handlers */
{
  if (has_active_methods(sc, obj))
    {
      const s7_pointer func = find_method_with_let(sc, obj, sc->class_name_symbol);
      if (is_symbol(func)) /* in mockery.scm, the class-name field value is a symbol */
	return(symbol_name_cell(func));
      if (func != sc->undefined)
	return(s7_apply_function(sc, func, set_plist_1(sc, obj)));
    }
  {
    const uint8_t typ = type(obj);
    if (typ < Num_Types)
      {
	if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, obj));
	return(sc->type_names[typ]);
      }}
  return(wrap_string(sc, "unknown type!", 13));
}

static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg)
{
  if (type(arg) < Num_Types)
    {
      s7_pointer p = sc->type_names[type(arg)]; /* these use Indefinite_Article */
      if (is_string(p)) return(p);
    }
  return(s7_make_string_wrapper(sc, type_name(sc, arg, Indefinite_Article)));
}


/* -------- errors -------- */
static no_return void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ)
{
  set_wlist_4(cdr(sc->sole_arg_wrong_type_info), caller, arg, object_type_name(sc, arg), typ);
  error_nr(sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info);
}

static /* Inline */ no_return void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ)
{
  s7_pointer p = cdr(sc->wrong_type_arg_info);  /* info list is '(format_string caller arg_n arg type_name descr) */
  set_car(p, caller);                    p = cdr(p);
  set_car(p, (is_small_int(arg_num)) ? small_int(arg_num) : wrap_integer(sc, arg_num)); p = cdr(p);
  set_car(p, arg);                       p = cdr(p);
  set_car(p, object_type_name(sc, arg)); p = cdr(p);
  set_car(p, typ);
  error_nr(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info);
}

s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr)
{
  if (arg_n > 0)
    wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr)));
  sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr)));
  return(sc->wrong_type_arg_symbol);
}

s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr)
{
  if (arg_n > 0) wrong_type_error_nr(sc, caller, arg_n, arg, descr);
  sole_arg_wrong_type_error_nr(sc, caller, arg, descr);
  return(sc->wrong_type_arg_symbol); /* never happens */
}

static no_return void sole_arg_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr)
{
  set_wlist_3(cdr(sc->sole_arg_out_of_range_info), caller, arg, descr);
  error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info);
}

static no_return void out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr)
{
  set_wlist_4(cdr(sc->out_of_range_info), caller, arg_n, arg, descr);
  error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info);
}

s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr)
{
  if (arg_n > 0)
    {
      set_wlist_4(cdr(sc->out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)),
		  wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr)));
      error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info);
    }
  set_wlist_3(cdr(sc->sole_arg_out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)),
	      arg, wrap_string(sc, descr, safe_strlen(descr)));
  error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info);
  return(sc->out_of_range_symbol);
}

static no_return void wrong_number_of_arguments_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer args)
{
  error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), args));
}

s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args)
{
  error_nr(sc, sc->wrong_number_of_args_symbol,
	   set_elist_2(sc, wrap_string(sc, caller, safe_strlen(caller)), args)); /* "caller" includes the format directives */
  return(sc->wrong_number_of_args_symbol);
}


static no_return void syntax_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer obj)
{
  error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), obj));
}

static no_return void syntax_error_with_caller_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer obj)
{
  error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, errmsg, len), caller, obj));
}

static no_return void syntax_error_with_caller2_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer name, s7_pointer obj)
{
  error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj));
}

static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */
#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name))

static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer class_name = find_method(sc, obj, sc->class_name_symbol);
  if (is_symbol(class_name)) return(class_name);
  return(sc->is_openlet_symbol);
}

static no_return void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj)
{
  error_nr(sc, sc->missing_method_symbol,
	   set_elist_4(sc, wrap_string(sc, "~S method is not defined in ~A ~A", 33), method,
		       (is_c_object(obj)) ? c_object_scheme_name(sc, obj) :
                         (((is_let(obj)) && (is_openlet(obj))) ? missing_method_class_name(sc, obj) :
                          s7_make_string_wrapper(sc, type_name(sc, obj, No_Article))),
		       object_to_string_truncated(sc, obj)));
}

static no_return void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);}


/* -------- method handlers -------- */
s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
  if (has_active_methods(sc, obj)) return(find_method_with_let(sc, obj, method));
  return(sc->undefined);
}

/* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc */
#define if_method_exists_return_value(Sc, Obj, Method, Args)		\
  {							\
    s7_pointer _Func_;					\
    if ((has_active_methods(Sc, Obj)) &&				\
	((_Func_ = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \
      return(s7_apply_function(Sc, _Func_, Args)); \
  }

#define if_let_method_exists_return_value(Sc, Let, Method, Args)	\
  {							\
    s7_pointer _Func_;					\
    if ((has_active_methods(Sc, T_Let(Let))) &&				\
	((_Func_ = find_method(Sc, Let, Method)) != Sc->undefined)) \
      return(s7_apply_function(Sc, _Func_, Args)); \
  }

#define if_c_object_method_exists_return_value(Sc, C_Obj, Method, Args)	\
  {							\
    s7_pointer _Func_;					\
    if ((has_active_methods(Sc, T_Obj(C_Obj))) &&				\
	((_Func_ = find_method_with_c_object(Sc, C_Obj, Method)) != Sc->undefined)) \
      return(s7_apply_function(Sc, _Func_, Args)); \
  }

static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
  s7_pointer func = find_method_with_let(sc, obj, method);
  if (func == sc->undefined) return(sc->F);
  return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */
}

/* this is a macro mainly to simplify the Checker handling */
#define check_boolean_method(Sc, Checker, Method, Args)	       \
  {							       \
    const s7_pointer _P_ = car(Args);				       \
    if (Checker(_P_)) return(Sc->T);			       \
    if (!has_active_methods(Sc, _P_)) return(Sc->F);	       \
    return(apply_boolean_method(Sc, _P_, Method));	       \
  }

static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args);

static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointer sym, s7_pointer args) /* slower if inline */
{
  const s7_pointer func = find_method_with_let(sc, obj, sym); /* perhaps find_and_apply_c_object_method for g_c_object_let */
  if (is_closure(func)) return(apply_method_closure(sc, func, args));
  if (func == sc->undefined) missing_method_error_nr(sc, sym, obj);
  if ((s7_Debugging) && (func == global_value(sym))) {fprintf(stderr, "loop in %s?\n", __func__); abort();}
  return(s7_apply_function(sc, func, args));
}

static s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num)
{
  if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ);
  return(find_and_apply_method(sc, obj, method, args));
}

static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num)
{
  if (has_active_methods(sc, obj)) return(find_and_apply_method(sc, obj, method, args));
  if (sc->type_names[type(obj)] != typ) wrong_type_error_nr(sc, method, num, obj, typ);
  if (!is_immutable(obj)) wrong_type_error_nr(sc, method, num, obj, typ);
  immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, method, obj));
  return(NULL);
}

static s7_pointer mutable_method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method,
					     s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num)
{
  return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */
}

static s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ)
{
  if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ);
  return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj)));
}

static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num)
{
  if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ);
  return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2)));
}

static s7_pointer 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)
{
  const int32_t loc = sc->error_argnum + num;
  sc->error_argnum = 0;
  if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, loc, obj, typ);
  return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2)));
}

static s7_pointer sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ)
{
  if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ);
  return(find_and_apply_method(sc, obj, method, args));
}


/* -------------------------------- constants -------------------------------- */
/* #f and #t */
s7_pointer s7_f(s7_scheme *sc) {return(sc->F);}
s7_pointer s7_t(s7_scheme *sc) {return(sc->T);}


/* () */
s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);}               /* should this be "s7_null" ? */
bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));}
static bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */

static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args)
{
  #define H_is_null "(null? obj) returns #t if obj is the empty list"
  #define Q_is_null sc->pl_bt
  check_boolean_method(sc, is_null, sc->is_null_symbol, args);
}


/* #<undefined> and #<unspecified> */
s7_pointer s7_undefined(s7_scheme *sc)   {return(sc->undefined);}
s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);}

bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));}

static s7_pointer g_is_undefined(s7_scheme *sc, s7_pointer args)
{
  #define H_is_undefined "(undefined? val) returns #t if val is #<undefined> or some other #... value that s7 does not recognize; (undefined? #asdf): #t.\
This is not the same as (not (defined? val)) which refers to whether a symbol has a binding: (undefined? 'asdf): #f, but (not (defined? 'asdf)): #t"
  #define Q_is_undefined sc->pl_bt
  check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args);
}

static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args)
{
  #define H_is_unspecified "(unspecified? val) returns #t if val is #<unspecified>"
  #define Q_is_unspecified sc->pl_bt
  check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol, args);
}


/* -------------------------------- eof-object? -------------------------------- */
s7_pointer eof_object = NULL;          /* #<eof> is an entry in the chars array, so it's not a part of sc */

s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);}

static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args)
{
  #define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object, #<eof>.  It is the same as (eq? val #<eof>)"
  #define Q_is_eof_object sc->pl_bt
  check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args);
}

static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);}


/* -------------------------------- not -------------------------------- */
static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);}

static s7_pointer g_not(s7_scheme *sc, s7_pointer args)
{ /* this doesn't need method handling */
  #define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f"
  #define Q_not sc->pl_bt
  return((car(args) == sc->F) ? sc->T : sc->F);
}


/* -------------------------------- boolean? -------------------------------- */
bool s7_boolean(s7_scheme *sc, s7_pointer obj)      {return(obj != sc->F);}
s7_pointer s7_make_boolean(s7_scheme *sc, bool obj) {return(make_boolean(sc, obj));}

bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);}

static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args)
{
  #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f"
  #define Q_is_boolean sc->pl_bt
  check_boolean_method(sc, is_boolean, sc->is_boolean_symbol, args);
}


/* -------------------------------- constant? -------------------------------- */
static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) /* inline: 7 in cb, 5 in tgen */
{
  if (is_immutable_symbol(sym))    /* for keywords */
    return(true);
  if (is_possibly_constant(sym))
    {
      s7_pointer slot = s7_slot(sc, sym);
      return((is_slot(slot)) && (is_immutable_slot(slot)));
    }
  return(false);
}

#define is_constant(Sc, P) ((type(P) != T_SYMBOL) || (is_constant_symbol(Sc, P)))

static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args)
{
  #define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant"
  #define Q_is_constant sc->pl_bt
  const s7_pointer obj = car(args);
  s7_pointer func;
  if (!has_active_methods(sc, obj))
    return(make_boolean(sc, is_constant(sc, obj)));
  func = find_method_with_let(sc, obj, sc->is_constant_symbol);
  if (func == sc->undefined)
    return(make_boolean(sc, is_constant(sc, obj)));
  return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */
}

static bool is_constant_b_7p(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));}
static s7_pointer is_constant_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_constant(sc, p)));}


/* -------------------------------- immutable? -------------------------------- */

static no_return void find_let_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer let, s7_pointer new_let, s7_int arg_num, s7_pointer args)
{
  if (new_let == sc->rootlet)
    {
      if ((arg_num > 1) || (is_pair(cdr(args))))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_5(sc, wrap_string(sc, "(~A~{~^ ~$~}) ~:D argument is ~A, but it does not have its own let", 66),
			     caller, args, wrap_integer(sc, arg_num), object_type_name(sc, let)));
      error_nr(sc, sc->wrong_type_arg_symbol,
	       set_elist_4(sc, wrap_string(sc, "(~A~{~^ ~$~}) argument is ~A, but it does not have its own let", 62),
			   caller, args, object_type_name(sc, let)));
    }
  wrong_type_error_nr(sc, caller, arg_num, s7_list_ref(sc, args, arg_num - 1), wrap_string(sc, "a let or an object that has its own let", 39));
}

bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));}
#define has_let_signature(Sc) s7_make_signature(Sc, 5, Sc->is_let_symbol, Sc->is_c_object_symbol, Sc->is_c_pointer_symbol, Sc->is_procedure_symbol, Sc->is_macro_symbol)

static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args)
{
  #define H_is_immutable "(immutable? obj (env (curlet))) returns #t if obj (or obj in the environment env) is immutable"
  #define Q_is_immutable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, has_let_signature(sc))
  const s7_pointer obj = car(args);
  if (is_symbol(obj))
    {
      s7_pointer slot;
      if (is_keyword(obj)) return(sc->T);
      if (is_pair(cdr(args)))
	{
	  s7_pointer 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 #<undefined> */
	return(make_boolean(sc, is_immutable_slot(slot)));
    }
  else
    {
      if (has_active_methods(sc, obj))
	{
	  s7_pointer func = find_method_with_let(sc, obj, sc->is_immutable_symbol);
	  if (func != sc->undefined)
	    return(s7_apply_function(sc, func, (is_pair(cdr(args))) ? set_mlist_2(sc, obj, cadr(args)) : set_mlist_1(sc, obj)));
	}
      if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable? 1 2) */
	wrong_type_error_nr(sc, sc->is_immutable_symbol, 2, cadr(args), A_Let_String);
    }
  return(make_boolean(sc, (is_immutable(obj)) || (t_immutable_p[type(obj)]) ||
		           ((is_any_vector(obj)) && (vector_length(obj) == 0))));
}


/* -------------------------------- immutable! -------------------------------- */
s7_pointer s7_set_immutable(s7_scheme *sc, s7_pointer 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);
}

#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

#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
#define s7_Warn_Bufsize 256

static s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len);

static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args)
{
  #define H_immutable "(immutable! obj (env (curlet))) declares that the object obj (or obj in the environment env) can't be changed. obj is returned."
  #define Q_immutable s7_make_signature(sc, 3, sc->T, sc->T, sc->T)
  /* the sig second argument should be has_let_signature if the first is a symbol, and is_integer_symbol if the first is a pair, else the second argument is unused */
  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)))
    {
      const s7_pointer let_int = cadr(args);
      if ((is_let(let_int)) || (!is_pair(obj)))
	error_nr(sc, sc->error_symbol, set_elist_2(sc, wrap_string(sc, "in (immutable! ~{~S~^ ~}), the second argument is pointless", 59), args));
      if (!s7_is_integer(let_int))
	wrong_type_error_nr(sc, sc->immutable_symbol, 2, let_int, A_Non_Negative_Integer_String);
    }
  if ((sc->safety > No_Safety) && (ignores_immutable(obj)))
    s7_warn(sc, s7_Warn_Bufsize, "%s, %s, ignores immutable!", display(obj), type_name(sc, obj, Indefinite_Article));

  if (is_pair(obj)) /* the second arg saying how many pairs to set immutable makes object->string :readable of a circular patchwork list workable */
    {
      const s7_int end = (is_pair(cdr(args))) ? s7_integer(cadr(args)) : sc->max_list_length;
      s7_int i = 1;
      if (end < 0)
	wrong_type_error_nr(sc, sc->immutable_symbol, 2, cadr(args), A_Non_Negative_Integer_String);
      if (end == 0) return(obj);
      set_immutable(obj);
      for (s7_pointer p = cdr(obj), slow = obj; (i < end) && (is_pair(p)) && (slow != p); p = cdr(p), i++)
	{
	  set_immutable(p);
	  i++;
	  if ((i < end) && (is_pair(cdr(p))))
	    {
	      p = cdr(p);
	      set_immutable(p);
	      slow = cdr(slow);
	    }}}
  else
    {
      if (has_active_methods(sc, obj))
	{
	  s7_pointer func = find_method_with_let(sc, obj, sc->immutable_symbol);
	  if (func != sc->undefined)
	    return(s7_apply_function(sc, func, (is_pair(cdr(args))) ? set_mlist_2(sc, obj, cadr(args)) : set_mlist_1(sc, obj)));
	}
      set_immutable(obj);
    }
  return(obj);
}

/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */


/* -------------------------------- GC -------------------------------- */
/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the
 *   total cell allocations.  In snd-test, reals are 50%. slots need not be in the heap,
 *   but moving them out to their own free list was slower because we need (in that
 *   case) to manage them in the sweep process by tracking lets.
 */

#if s7_Debugging
static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line)
{
  static bool already_warned = false;
  const 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);
      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;
    }
}

s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x)
{
  s7_int loc;
  if (sc->protected_objects_free_list_loc < 0)
    resize_gc_protect(sc);
  loc = sc->protected_objects_free_list[sc->protected_objects_free_list_loc--];
  vector_element(sc->protected_objects, loc) = x;
  return(loc);
}

void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc)
{
  if (loc < sc->protected_objects_size)
    {
      if (vector_element(sc->protected_objects, loc) != sc->unused)
	sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc;
      else if (s7_Debugging) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc);
      vector_element(sc->protected_objects, loc) = sc->unused;
    }
}

s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc)
{
  s7_pointer obj = sc->unspecified;
  if (loc < sc->protected_objects_size)
    obj = vector_element(sc->protected_objects, loc);
  if (obj == sc->unused)
    return(sc->unspecified);
  return(obj);
}

#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc)

s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc)
{
  vector_element(sc->protected_objects, loc) = x;
  return(x);
}

s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc)
{
  vector_element(sc->protected_objects, loc) = sc->unused;
  sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; /* added 13-Feb-25 */
  return(sc->F);
}


/* these 3 are needed by sweep */
static void (*mark_function[Num_Types])(s7_pointer p);
void s7_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[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)--;
    }
}

static void process_multivector(s7_scheme *sc, s7_pointer vect)
{
  vdims_t *info = vector_dimension_info(vect);  /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */
  if ((info) && (info != sc->wrap_only))
    {
      if (vector_elements_should_be_freed(info)) /* a kludge for foreign code convenience */
	{
	  free(any_vector_elements(vect));
	  vector_elements_should_be_freed(info) = false;
	}
      liberate(sc, info);
      vector_set_dimension_info(vect, NULL);
    }
  liberate(sc, vector_block(vect));
}

static void process_input_string_port(s7_scheme *sc, s7_pointer port)
{
#if s7_Debugging
  /* this set of ports is a subset of the ports that respond true to is_string_port --
   *   the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port
   */
  if (port_filename(port))
    fprintf(stderr, "%s[%d]: string input port has a filename: %s\n", __func__, __LINE__, port_filename(port));
  if (port_needs_free(port))
    {fprintf(stderr, "%s[%d]: string input port needs data release\n", __func__, __LINE__); abort();}
#endif
  liberate(sc, port_block(port));
}

static void free_port_data(s7_scheme *sc, s7_pointer port)
{
  if (port_data(port))
    {
      liberate(sc, port_data_block(port));
      port_data_block(port) = NULL;
      port_data(port) = NULL;
      port_data_size(port) = 0;
    }
  port_needs_free(port) = false;
}

static void close_input_function_port(s7_scheme *sc, s7_pointer port);
static void close_output_port(s7_scheme *sc, s7_pointer port);

static void process_input_port(s7_scheme *sc, s7_pointer port)
{
  if (!port_is_closed(port))
    {
      if (is_file_port(port))
	{
	  if (port_file(port))
	    {
	      fclose(port_file(port));
	      port_file(port) = NULL;
	    }}
      else
	if (is_function_port(port))
	  close_input_function_port(sc, port);
    }
  if (port_needs_free(port))
    free_port_data(sc, port);

  if (port_filename(port))
    {
      liberate(sc, port_filename_block(port));
      port_filename(port) = NULL;
    }
  liberate(sc, port_block(port));
}

static void process_output_port(s7_scheme *sc, s7_pointer port)
{
  close_output_port(sc, port); /* needed for free filename, etc */
  liberate(sc, port_block(port));
  if (port_needs_free(port))
    {
      port_needs_free(port) = false;
      if (port_data_block(port))
	{
	  liberate(sc, port_data_block(port));
	  port_data_block(port) = NULL;
	}}
}

static void process_continuation(s7_scheme *sc, s7_pointer cc)
{
  continuation_op_stack(cc) = NULL;
  liberate_block(sc, continuation_block(cc)); /* from mallocate_block (s7_make_continuation) */
}


#if With_Gmp
#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0)))
static int32_t mpq_cmp_z(const mpq_t op1, const mpz_t op2)
{
  mpq_t z;
  int32_t result;
  mpq_init(z);
  mpq_set_z(z, op2);
  result = mpq_cmp(op1, z);
  mpq_clear(z);
  return(result);
}
#endif

static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n);

static s7_int s7_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer num)
{
  if (is_t_integer(num))
    return(integer(num));
  if (is_t_big_integer(num))
    return(big_integer_to_s7_int(sc, big_integer(num)));
  return(0);
}

static void free_big_integer(s7_scheme *sc, s7_pointer num)
{
  big_integer_nxt(num) = sc->bigints;
  sc->bigints = big_integer_bgi(num);
  big_integer_bgi(num) = NULL;
}

static void free_big_ratio(s7_scheme *sc, s7_pointer num)
{
  big_ratio_nxt(num) = sc->bigrats;
  sc->bigrats = big_ratio_bgr(num);
  big_ratio_bgr(num) = NULL;
}

static void free_big_real(s7_scheme *sc, s7_pointer num)
{
  big_real_nxt(num) = sc->bigflts;
  sc->bigflts = big_real_bgf(num);
  big_real_bgf(num) = NULL;
}

static void free_big_complex(s7_scheme *sc, s7_pointer num)
{
  big_complex_nxt(num) = sc->bigcmps;
  sc->bigcmps = big_complex_bgc(num);
  big_complex_bgc(num) = NULL;
}
#else
#define s7_integer_clamped_if_gmp(Sc, P) integer(P)
#endif


static void free_hash_table(s7_scheme *sc, s7_pointer table);
static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym);
static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table);

static void sweep(s7_scheme *sc)
{
  s7_int i, j;
  gc_list_t *gp;

  #define process_gc_list(Code)				\
    if (gp->loc > 0)					\
      {							\
        for (i = 0, j = 0; i < gp->loc; i++)		\
          {						\
            s7_pointer 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;					\
      }							\

  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++)
	{
	  const 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;
    }

  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)
    {
      for (i = 0, j = 0; i < gp->loc; i++)
	{
	  const 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;
    }

#if With_Gmp
  gp = sc->big_integers;
  process_gc_list(free_big_integer(sc, gc_obj)) /* gc_obj == gp->list[i] */

  gp = sc->big_ratios;
  process_gc_list(free_big_ratio(sc, gc_obj))

  gp = sc->big_reals;
  process_gc_list(free_big_real(sc, gc_obj))

  gp = sc->big_complexes;
  process_gc_list(free_big_complex(sc, gc_obj))

  gp = sc->big_random_states;
  process_gc_list(gmp_randclear(random_gmp_state(gc_obj)))
#endif
}

static void add_to_gc_list(s7_scheme *sc, gc_list_t *gp, s7_pointer p)
{
#if s7_Debugging
  if ((!in_heap(p)) && (gp != sc->opt1_funcs))
    {
      char *str = describe_type_bits(sc, p);
      fprintf(stderr, "%s[%d]: %s not in heap, %s\n", __func__, __LINE__, display(p), str);
      free(str);
      abort();
    }
#endif
  if (gp->loc == gp->size)
    {
      gp->size *= 2;
      gp->list = (s7_pointer *)Realloc(gp->list, gp->size * sizeof(s7_pointer));
    }
  gp->list[gp->loc++] = p;
}

static gc_list_t *make_gc_list(void)
{
  gc_list_t *gp = (gc_list_t *)Malloc(sizeof(gc_list_t));
  #define Init_Gc_Cache_Size 4
  gp->size = Init_Gc_Cache_Size;
  gp->loc = 0;
  gp->list = (s7_pointer *)Malloc(gp->size * sizeof(s7_pointer));
  return(gp);
}

static void just_mark(s7_pointer p) {set_mark(p);}

static void add_gensym(s7_scheme *sc, s7_pointer p)
{
  add_to_gc_list(sc, sc->gensyms, p);
  mark_function[T_SYMBOL] = just_mark;
}

#define add_c_object(Sc, P)          add_to_gc_list(Sc, Sc->c_objects, P)
#define add_hash_table(Sc, P)        add_to_gc_list(Sc, Sc->hash_tables, P)
#define add_string(Sc, P)            add_to_gc_list(Sc, Sc->strings, P)
#define add_input_port(Sc, P)        add_to_gc_list(Sc, Sc->input_ports, P)
#define add_input_string_port(Sc, P) add_to_gc_list(Sc, Sc->input_string_ports, P)
#define add_output_port(Sc, P)       add_to_gc_list(Sc, Sc->output_ports, P)
#define add_continuation(Sc, P)      add_to_gc_list(Sc, Sc->continuations, P)
#define add_undefined(Sc, P)         add_to_gc_list(Sc, Sc->undefineds, P)
#define add_vector(Sc, P)            add_to_gc_list(Sc, Sc->vectors, P)
#define add_multivector(Sc, P)       add_to_gc_list(Sc, Sc->multivectors, P)
#define add_weak_ref(Sc, P)          add_to_gc_list(Sc, Sc->weak_refs, P)
#define add_weak_hash_iterator(Sc, P) add_to_gc_list(Sc, Sc->weak_hash_iterators, P)
#define add_opt1_func(Sc, P) do {if (!opt1_func_listed(P)) add_to_gc_list(Sc, Sc->opt1_funcs, P); set_opt1_func_listed(P);} while (0) /* called by set_opt1_lambda_add */

#if With_Gmp
#define add_big_integer(Sc, P)       add_to_gc_list(Sc, Sc->big_integers, P)
#define add_big_ratio(Sc, P)         add_to_gc_list(Sc, Sc->big_ratios, P)
#define add_big_real(Sc, P)          add_to_gc_list(Sc, Sc->big_reals, P)
#define add_big_complex(Sc, P)       add_to_gc_list(Sc, Sc->big_complexes, P)
#define add_big_random_state(Sc, P)  add_to_gc_list(Sc, Sc->big_random_states, P)
#endif

static void init_gc_caches(s7_scheme *sc)
{
  sc->strings = make_gc_list();
  sc->gensyms = make_gc_list();
  sc->undefineds = make_gc_list();
  sc->vectors = make_gc_list();
  sc->multivectors = make_gc_list();
  sc->hash_tables = make_gc_list();
  sc->input_ports = make_gc_list();
  sc->input_string_ports = make_gc_list();
  sc->output_ports = make_gc_list();
  sc->continuations = make_gc_list();
  sc->c_objects = make_gc_list();
  sc->weak_refs = make_gc_list();
  sc->weak_hash_iterators = make_gc_list();
  sc->opt1_funcs = make_gc_list();
#if With_Gmp
  sc->big_integers = make_gc_list();
  sc->big_ratios = make_gc_list();
  sc->big_reals = make_gc_list();
  sc->big_complexes = make_gc_list();
  sc->big_random_states = make_gc_list();
  sc->ratloc = NULL;
#endif
  /* slightly unrelated... */
  sc->setters_size = 4;
  sc->setters_loc = 0;
  sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer));
}

#if s7_Debugging
#define semipermanent_cons(Sc, A, B, Type) semipermanent_cons_1(Sc, A, B, Type, __func__, __LINE__)
static s7_pointer semipermanent_cons_1(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type, const char *func, int line);
#else
static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type);
#endif

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++)
    {
      const 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 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)
{
  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 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);}

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_slot_checked(slot); slot = next_slot(slot))
	if (!is_marked(slot)) /* slot value might be the enclosing let */
	  mark_slot(slot);
    }
}

static void mark_wrappers(s7_scheme *sc)
{
  s7_pointer p = sc->let_wrappers;
  const s7_pointer end_p = p;
  do {
    for (s7_pointer slot = let_slots(car(p)); is_slot_checked(slot); slot = next_slot(slot))
      if (!is_marked(slot)) mark_slot(slot);
    p = cdr(p);
  } while (p != end_p);

  /* dox1|2? gensyms? maybe don't wrap gensym-slot */
}

static void unmark_wrappers(s7_scheme *sc)
{
  s7_pointer p = sc->let_wrappers;
  const s7_pointer end_p = p;
  do {
    for (s7_pointer slot = let_slots(car(p)); is_slot_checked(slot); slot = next_slot(slot))
      clear_mark(slot);
    p = cdr(p);
  } while (p != end_p);
}

#if With_History
static void gc_owlet_mark(s7_pointer tp)
{
  /* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */
  if (is_pair(tp))
    {
      s7_pointer p = tp;
      do {
	set_mark(p);
	gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */
	p = cdr(p);
      } while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (Type_Mask | T_Gc_Mark)) == T_PAIR) is much slower */
      gc_mark(p);
    }
  else
    if (!is_marked(tp))
      (*mark_function[type_unchecked(tp)])(tp);
}
#endif

static void mark_owlet(s7_scheme *sc)
{
#if With_History
  {
    for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3))
      {
	gc_owlet_mark(car(p1));
	gc_owlet_mark(car(p2));
	gc_owlet_mark(car(p3));
	p1 = cdr(p1);
	if (p1 == sc->eval_history1) break; /* these are circular lists */
      }}
#endif
  /* sc->error_type and friends are slots in owlet */
  gc_mark(slot_value(sc->error_type));
  slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */
  gc_mark(slot_value(sc->error_data));
  gc_mark(slot_value(sc->error_code));
  gc_mark(slot_value(sc->error_line));
  gc_mark(slot_value(sc->error_file));
  gc_mark(slot_value(sc->error_position));
#if With_History
  gc_mark(slot_value(sc->error_history));
#endif
  /* set_mark(sc->owlet); */
  mark_let(let_outlet(sc->owlet));
}

static void mark_c_pointer(s7_pointer cp)
{
  set_mark(cp);
  gc_mark(c_pointer_type(cp));
  gc_mark(c_pointer_info(cp));
}

static void mark_c_proc_star(s7_pointer proc)
{
  set_mark(proc);
  if ((!c_func_has_simple_defaults(proc)) &&
      (c_function_call_args(proc))) /* NULL if not a safe function */
    for (s7_pointer arg = c_function_call_args(proc); is_pair(arg); arg = cdr(arg))
      gc_mark(car(arg));
}

static void mark_pair(s7_pointer p)
{
  do {
    set_mark(p);
    gc_mark(car(p)); /* expanding this to avoid recursion is slower */
    p = cdr(p);
  } while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (Type_Mask | T_Gc_Mark)) == T_PAIR) is much slower */
  gc_mark(p);
}

static void mark_counter(s7_pointer 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));
}

static void mark_stack_1(s7_pointer stack, s7_int top)
{
  s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend;
  set_mark(stack);
  if (!tp) return;
  tend = (s7_pointer *)(tp + top);
  while (tp < tend)
    {
      gc_mark(*tp++); /* sc->code */
      gc_mark(*tp++); /* sc->curlet */
      gc_mark(*tp++); /* sc->args */
      tp++;           /* sc->cur_op */
    }
}

static void mark_stack(s7_pointer stack)
{
  /* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC!  But we need a top-of-stack?? */
  mark_stack_1(stack, temp_stack_top(stack));
}

static void mark_continuation(s7_pointer cc)
{
  set_mark(cc);
  if (!is_marked(continuation_stack(cc))) /* can these be cyclic? */
    mark_stack_1(continuation_stack(cc), continuation_stack_top(cc));
  gc_mark(continuation_op_stack(cc));
}

static void mark_vector(s7_pointer vect)
{
  if (is_typed_vector(vect))
    typed_vector_gc_mark(vect)(vect, vector_length(vect));
  else mark_vector_1(vect, vector_length(vect));
}

static void mark_vector_possibly_shared(s7_pointer vect)
{
  /* If a subvector (an inner dimension) of a vector is the only remaining reference
   *    to the main vector, we want to make sure the main vector is not GC'd until
   *    the subvector is also GC-able.  The subvector field either points to the
   *    parent vector, or it is sc->F, so we need to check for a vector parent if
   *    the current is multidimensional (this will include 1-dim slices).  We need
   *    to keep the parent case separate (i.e. sc->F means the current is the original)
   *    so that we only free once (or remove_from_heap once).
   *
   * If we have a subvector of a subvector, and the middle and original are not otherwise
   *   in use, we mark the middle one, but (since it itself is not in use anywhere else)
   *   we don't mark the original!  So we need to follow the share-vector chain marking every one.
   *
   * To remove a cell from the heap, we need its current heap location so that we can replace it.
   *   The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell
   *   is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the
   *   GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the
   *   replacements from the originals, but we need that info because in the base case, we use
   *   the distance of the cell from the base cell to get "x", its location.  In the replacement
   *   case, we add the location at the end of the s7_cell (s7_big_cell).  We track the current
   *   heap blocks via the sc->heap_blocks list.  To get the location of "p" above, we run through
   *   that list looking for a block it fits in.  If none is found, we assume it is an s7_big_cell
   *   and use the saved location.
   */
  if (is_subvector(vect))
    mark_vector_possibly_shared(subvector_vector(vect));

  /* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving
   *   the calling vector, we get infinite recursion unless we check the mark bit here.
   */
  if (!is_marked(vect))
    mark_vector_1(vect, vector_length(vect));
}

static void mark_int_or_float_vector(s7_pointer vect) {set_mark(vect);}

static void mark_int_or_float_vector_possibly_shared(s7_pointer vect) /* also complex_vector */
{
  if (is_subvector(vect))
    mark_int_or_float_vector_possibly_shared(subvector_vector(vect));
  set_mark(vect);
}

static void mark_c_object(s7_pointer cobj)
{
  set_mark(cobj);
  mark_let(c_object_let(cobj));  /* I think this is guaranteed to be a let, added 5-Apr-25 */
  if (c_object_gc_mark(c_object_sc(cobj), cobj))  /* c_object_sc = s7_scheme pointer */
    (*(c_object_gc_mark(c_object_sc(cobj), cobj)))(c_object_sc(cobj), cobj);
  else (*(c_object_mark(c_object_sc(cobj), cobj)))(c_object_value(cobj));
}

static void mark_catch(s7_pointer catcher) /* C++ reserves "catch" */
{
  set_mark(catcher);
  gc_mark(catch_tag(catcher));
  gc_mark(catch_handler(catcher));
}

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
      else fprintf(stderr, "mark_iterator[%d]: has_carrier set (at line %d), but no carrier!\n", __LINE__, iter->carrier_line);
#endif
    }
}

static void mark_input_port(s7_pointer port)
{
  set_mark(port);
  gc_mark(port_string_or_function(port));
}

static void mark_output_port(s7_pointer port)
{
  set_mark(port);
  if (is_function_port(port))
    gc_mark(port_string_or_function(port));
}

static void mark_free(s7_pointer unused_p) {/* if (s7_Debugging) {fprintf(stderr, "mark_free!\n"); abort();} */} /* set_mark also checks */
/* this can happen if safe_list partially filled when GC called etc -- how to catch these cases and not abort? */

static void init_mark_functions(void)
{
  mark_function[T_BACRO]               = mark_closure;
  mark_function[T_BACRO_STAR]          = mark_closure;
  mark_function[T_BIG_COMPLEX]         = just_mark;
  mark_function[T_BIG_INTEGER]         = just_mark;
  mark_function[T_BIG_RATIO]           = just_mark;
  mark_function[T_BIG_REAL]            = just_mark;
  mark_function[T_BOOLEAN]             = mark_noop;
  mark_function[T_BYTE_VECTOR]         = just_mark;
  mark_function[T_CATCH]               = mark_catch;
  mark_function[T_CHARACTER]           = mark_noop;
  mark_function[T_CLOSURE]             = mark_closure;
  mark_function[T_CLOSURE_STAR]        = mark_closure;
  mark_function[T_COMPLEX]             = just_mark;
  mark_function[T_COMPLEX_VECTOR]      = mark_int_or_float_vector;
  mark_function[T_CONTINUATION]        = mark_continuation;
  mark_function[T_COUNTER]             = mark_counter;
  mark_function[T_C_FUNCTION]          = just_mark;
  mark_function[T_C_FUNCTION_STAR]     = just_mark; /* changes to mark_c_proc_star if defaults involve an expression */
  mark_function[T_C_MACRO]             = just_mark;
  mark_function[T_C_OBJECT]            = mark_c_object;
  mark_function[T_C_POINTER]           = mark_c_pointer;
  mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark;
  mark_function[T_DYNAMIC_WIND]        = mark_dynamic_wind;
  mark_function[T_EOF]                 = mark_noop;
  mark_function[T_FLOAT_VECTOR]        = mark_int_or_float_vector;
  mark_function[T_FREE]                = mark_free;
  mark_function[T_GOTO]                = just_mark;
  mark_function[T_HASH_TABLE]          = mark_hash_table;
  mark_function[T_INPUT_PORT]          = mark_input_port;
  mark_function[T_INTEGER]             = just_mark;
  mark_function[T_INT_VECTOR]          = mark_int_or_float_vector;
  mark_function[T_ITERATOR]            = mark_iterator;
  mark_function[T_LET]                 = mark_let;
  mark_function[T_MACRO]               = mark_closure;
  mark_function[T_MACRO_STAR]          = mark_closure;
  mark_function[T_NIL]                 = mark_noop;
  mark_function[T_OUTPUT_PORT]         = just_mark; /* changed to mark_output_port if output function ports are active */
  mark_function[T_PAIR]                = mark_pair;
  mark_function[T_RANDOM_STATE]        = just_mark;
  mark_function[T_RATIO]               = just_mark;
  mark_function[T_REAL]                = just_mark;
  mark_function[T_SLOT]                = mark_slot;
  mark_function[T_STACK]               = mark_stack;
  mark_function[T_STRING]              = just_mark;
  mark_function[T_SYMBOL]              = mark_noop; /* this changes to just_mark when gensyms are in the heap */
  mark_function[T_SYNTAX]              = mark_noop;
  mark_function[T_UNDEFINED]           = just_mark;
  mark_function[T_UNSPECIFIED]         = mark_noop;
  mark_function[T_UNUSED]              = mark_noop;
  mark_function[T_VECTOR]              = mark_vector; /* this changes if subvector created (similarly below) */
}

static void mark_op_stack(s7_scheme *sc)
{
  s7_pointer *p = sc->op_stack;
  s7_pointer *tp = sc->op_stack_now;
  while (p < tp)
    gc_mark(*p++);
}

static void mark_input_port_stack(s7_scheme *sc)
{
  s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc);
  for (s7_pointer *p = sc->input_port_stack; p < tp; p++)
    gc_mark(*p);
}

static void mark_rootlet(s7_scheme *sc)
{
  for (s7_pointer slot = sc->rootlet_slots; is_slot_checked(slot); slot = next_slot(slot))
    gc_mark(slot_value(slot)); /* slot is semipermanent? does this assume slot_value is not rootlet? or that rootlet is marked? */
  /* slot_setter is handled below with an explicit list -- more code than its worth probably */
  /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected
   *   (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0,
   *   but I can't get it to break, so they must be protected somehow; apparently they are
   *   removed from the heap!  At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit)
   *   removes the function from the heap (protecting the gensym).
   */
}

/* mark_closure calls mark_let on closure_let(func) which marks slot values.
 *   if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value?
 *   or save safe-closure lets to handle all at end?  or a gc_list of safe closure lets and only mark let if not safe?
 */

static void mark_semipermanent_objects(s7_scheme *sc)
{
  for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt))
    gc_mark(g->p);
  /* semipermanent_objects also has lets (removed from heap) -- should they be handled like semipermanent_lets?
   *    if unmarked should either be removed from the list and perhaps placed on a free list?
   *    if outlet is free can the let potentially be in use?
   *    there are many more semipermanent_lets(slots) than semipermanent objects
   */
}
/* do we mark funclet slot values from the function as root?  Maybe treat them like semipermanent_lets here? */

static void unmark_semipermanent_objects(s7_scheme *sc)
{
  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);
}

#if !MS_Windows
  #include <time.h>
  #include <sys/time.h>
#endif

#if s7_Debugging
static s7_int gc(s7_scheme *sc, const char *func, int32_t line)
#else
static s7_int gc(s7_scheme *sc)
#endif
{
  s7_cell **old_free_heap_top;

  if (sc->gc_in_progress)
    error_nr(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "GC called recursively", 21)));
  sc->gc_in_progress = true;
  sc->gc_start = my_clock();
  sc->gc_calls++;
  sc->gc_true_calls++;

  mark_rootlet(sc);
  mark_owlet(sc);
  gc_mark(sc->code);
  if ((s7_Debugging) && (!(sc->args))) {fprintf(stderr, "%d: sc->args is NULL\n", __LINE__); 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));
#if WITH_T4_N
  gc_mark(car(sc->t4_2)); gc_mark(car(sc->t4_3)); gc_mark(car(sc->t4_4));
#endif
  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 ([18] often in use) -- 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);
  gc_mark(sc->saved_sharp_readers);

  /* protect recent allocations using the free_heap cells above the current free_heap_top (if any).
   * cells above sc->free_heap_top might be malloc'd garbage (after heap reallocation), so we keep track of
   *   where the last actually freed cells were after the previous GC call.  We're trying to
   *   GC protect the previous Gc_Temps_Size allocated pointers so that the caller doesn't have
   *   to gc-protect every temporary cell.
   */
  {
    s7_pointer *tmps = sc->free_heap_top;
    s7_pointer *tmps_top = tmps + sc->gc_temps_size;
    if (tmps_top > sc->previous_free_heap_top)
      tmps_top = sc->previous_free_heap_top;
    while (tmps < tmps_top)
      gc_mark(*tmps++);
  }
  mark_op_stack(sc);
  mark_semipermanent_objects(sc);
  mark_wrappers(sc);

  if (sc->profiling_gensyms)
    {
      profile_data_t *pd = sc->profile_data;
      for (s7_int i = 0; i < pd->top; i++)
	if ((pd->funcs[i]) && (is_gensym(pd->funcs[i])))
	  set_mark(pd->funcs[i]);
    }

  {
    gc_list_t *gp = sc->opt1_funcs;
    for (s7_int i = 0; i < gp->loc; i++)
      {
	s7_pointer 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 */
      }}

  /* free up all unmarked objects */
  old_free_heap_top = sc->free_heap_top;
  {
    s7_pointer *fp = sc->free_heap_top; /* why does callgrind say this is very expensive? */
    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);
  }

  unmark_semipermanent_objects(sc);
  unmark_wrappers(sc);

  sc->gc_freed = (s7_int)(sc->free_heap_top - old_free_heap_top);
  sc->gc_total_freed += sc->gc_freed;
  sc->gc_end = my_clock();
  sc->gc_total_time += (sc->gc_end - sc->gc_start);
  sc->gc_true_total_time += (sc->gc_end - sc->gc_start);

  if (show_gc_stats(sc))
    {
#if !MS_Windows
      s7_warn(sc, s7_Warn_Bufsize, "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, s7_Warn_Bufsize, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size);
#endif
    }
  if (show_protected_objects_stats(sc))
    s7_warn(sc, s7_Warn_Bufsize, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n",
	    sc->protected_objects_size - 1 - sc->protected_objects_free_list_loc,
	    sc->protected_objects_size);
  sc->previous_free_heap_top = sc->free_heap_top;
  sc->gc_in_progress = false;
  return(sc->gc_freed);
}


#ifndef GC_RESIZE_HEAP_FRACTION
  #define GC_RESIZE_HEAP_FRACTION 0.8
/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap)
 *    in my tests, only tvect.scm ends up larger if 3/4 used
 */
#endif
#define Gc_Resize_Heap_Fraction GC_RESIZE_HEAP_FRACTION

#define Gc_Resize_Heap_By_4_Fraction 0.67
/*   .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305.  .85+.7: dup -5 */

#if s7_Debugging
#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__)
static void resize_heap_to_1(s7_scheme *sc, s7_int size, const char *func, int line)
#else
static void resize_heap_to(s7_scheme *sc, s7_int size)
#endif
{
  const s7_int old_size = sc->heap_size;
  const s7_int old_free = sc->free_heap_top - sc->free_heap;

#if s7_Debugging && (!MS_Windows)
  if (show_gc_stats(sc))
    s7_warn(sc, 512, "%s from %s[%d]: old: %" ld64 " / %" ld64 ", new: %" ld64 ", fraction: %.3f -> %" ld64 "\n",
	    __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (s7_int)(floor(sc->heap_size * sc->gc_resize_heap_fraction)));
#endif

  if (size == 0)
    {
      if ((old_free < old_size * sc->gc_resize_heap_by_4_fraction) &&
	  (sc->max_heap_size > (sc->heap_size * 4)))
	sc->heap_size *= 4;          /* *8 if < 1M (or whatever) doesn't make much difference */
      else sc->heap_size *= 2;
      if ((s7_Debugging) && (sc->heap_size >= sc->max_heap_size))
	fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size);
      if (sc->gc_resize_heap_fraction > .4)
	sc->gc_resize_heap_fraction *= .95;
    }
  else
    {
      if (size > sc->heap_size)
	while (sc->heap_size < size) sc->heap_size *= 2;
      else return;
      if ((s7_Debugging) && (sc->heap_size >= sc->max_heap_size))
	fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size);
    }
  if (sc->heap_size >= sc->max_heap_size)
    {
      const s7_int new_heap_size = 32 * (s7_int)floor(sc->max_heap_size / 32.0);
      if (new_heap_size > old_size)
	{
	  s7_warn(sc, s7_Warn_Bufsize, "heap size requested is greater than (*s7* 'max-heap-size); trying %" ld64 "\n", new_heap_size);
	  sc->heap_size = new_heap_size;
	  if ((s7_Debugging) && (sc->heap_size >= sc->max_heap_size))
	    fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size);
	}
      else
	{
	  const s7_int new_size = sc->heap_size;
	  sc->heap_size = old_size; /* needed if user catches this error and (for example) runs (*s7* 'memory-usage) in the error handler */
	  error_nr(sc, make_symbol(sc, "heap-too-big", 12),
		   set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~D > ~D", 50),
			       wrap_integer(sc, new_size),
			       wrap_integer(sc, sc->max_heap_size)));
	  return;
	}}

  /* do not call new_cell here! */
#if Pointer_32
  if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX)
    { /* can this happen in 64-bit land?  SIZE_MAX is unsigned int in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = 18446744073709551615UL */
      s7_warn(sc, s7_Warn_Bufsize, "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, s7_Warn_Bufsize, "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);
  {
    s7_cell *cells = (s7_cell *)Calloc(sc->heap_size - old_size, sizeof(s7_cell)); /* Malloc + clear_type below is much slower?! */
    s7_pointer p = cells;
    add_saved_pointer(sc, (void *)cells);
    for (s7_int k = old_size; k < sc->heap_size;) Loop_8(sc->heap[k++] = p++; sc->heap[k++] = p++; sc->heap[k++] = p++; sc->heap[k++] = p++);
    memcpy((s7_pointer *)(sc->free_heap + old_free), (s7_pointer *)(sc->heap + old_size), sizeof(s7_pointer) * (sc->heap_size - old_size));
    sc->free_heap_top = sc->free_heap + old_free + (sc->heap_size - old_size);
    {
      heap_block_t *hp = (heap_block_t *)Malloc(sizeof(heap_block_t));
      hp->start = (intptr_t)cells;
      hp->end = (intptr_t)cells + ((sc->heap_size - old_size) * sizeof(s7_cell));
      hp->offset = old_size;
      hp->next = sc->heap_blocks;
      sc->heap_blocks = hp;
    }}
  sc->previous_free_heap_top = sc->free_heap_top;

  if (show_heap_stats(sc))
    {
      if (size != 0)
	s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ")\n",
		sc->heap_size, old_free, old_size, size);
      else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", %.3f)\n",
		   sc->heap_size, old_free, old_size, sc->gc_resize_heap_fraction);
    }
}

#define resize_heap(Sc) resize_heap_to(Sc, 0)

#if s7_Debugging
#define call_gc(Sc) gc(Sc, __func__, __LINE__)
static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line)
#else
#define call_gc(Sc) gc(Sc)
static void try_to_call_gc(s7_scheme *sc)
#endif
{
  /* called only from new_cell */
  if (sc->gc_off)     /* we can't just return here!  Someone needs a new cell, and once the heap free list is exhausted, segfault */
    {
#if s7_Debugging
      fprintf(stderr, "%s[%d]: forced resize from %s[%d]\n", __func__, __LINE__, func, line);
#endif
      resize_heap(sc);
    }
  else
    {
      if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304))
	  sc->gc_resize_heap_fraction = 0.5;
#if s7_Debugging
      gc(sc, func, line); /* not call_gc! */
      /* describe_gc_strings(sc); */
#else
      gc(sc);
#endif
      if ((s7_int)(sc->free_heap_top - sc->free_heap) < (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */
	resize_heap(sc);
    }
}
  /* originally I tried to mark each temporary value until I was done with it, but that way madness lies... By delaying
   *   GC of _every_ %$^#%@ pointer, I can dispense with hundreds of individual protections.  So the free_heap's last
   *   Gc_Temps_Size allocated pointers are protected during the mark sweep.
   */

static s7_pointer g_gc(s7_scheme *sc, s7_pointer args)
{
  #define H_gc "(gc (on #t)) runs the garbage collector.  If 'on' (a boolean) is supplied, it turns the GC on or off. \
Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!"
  #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol)

  set_elist_1(sc, sc->unused);
  set_elist_2(sc, sc->unused, sc->unused);
  set_elist_3(sc, sc->unused, sc->unused, sc->unused);
  set_car(sc->elist_4, sc->unused);
  set_car(sc->elist_5, sc->unused);
  set_car(sc->elist_6, sc->unused);
  set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */
  if (is_pair(args))
    {
      if (!is_boolean(car(args)))
	return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[T_BOOLEAN]));
      sc->gc_off = (car(args) == sc->F);
      if (sc->gc_off)
	return(sc->F);
    }
  call_gc(sc);
  return(sc->unspecified);
}

s7_pointer s7_gc_on(s7_scheme *sc, bool on)
{
  sc->gc_off = !on;
  return(make_boolean(sc, on));
}

#if s7_Debugging
static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int32_t line)
#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__)
#else
static void check_free_heap_size(s7_scheme *sc, s7_int size)
#endif
{
  const s7_int free_cells = sc->free_heap_top - sc->free_heap;
  if (free_cells < size)
    {
#if s7_Debugging
      gc(sc, func, line);
#else
      gc(sc);
#endif
      while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5))
	resize_heap(sc);
    }
}

#define Alloc_Pointer_Size 256
static inline s7_cell *alloc_pointer(s7_scheme *sc) /* inline for tload */
{
  if (sc->alloc_pointer_k == Alloc_Pointer_Size)     /* if either no current block or the block is used up, make a new block */
    {
      sc->semipermanent_cells += Alloc_Pointer_Size;
      sc->alloc_pointer_cells = (s7_cell *)Calloc(Alloc_Pointer_Size, sizeof(s7_cell)); /* not Malloc here or below (maybe set full type to 0 if Malloc) */
      add_saved_pointer(sc, sc->alloc_pointer_cells);
      sc->alloc_pointer_k = 0;
    }
  return(&(sc->alloc_pointer_cells[sc->alloc_pointer_k++]));
}

#define Alloc_Big_Pointer_Size 256
static s7_big_cell *alloc_big_pointer(s7_scheme *sc, s7_int loc)
{
  s7_big_pointer p;
  if (sc->alloc_big_pointer_k == Alloc_Big_Pointer_Size)
    {
      sc->semipermanent_cells += Alloc_Big_Pointer_Size;
      sc->alloc_big_pointer_cells = (s7_big_cell *)Calloc(Alloc_Big_Pointer_Size, sizeof(s7_big_cell));
      add_saved_pointer(sc, sc->alloc_big_pointer_cells);
      sc->alloc_big_pointer_k = 0;
    }
  p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++]));
  p->big_hloc = loc;
  /* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks,
   *   but it's in the heap, and we'll need to know where it is in the heap to replace it
   */
  return(p);
}

static void add_semipermanent_object(s7_scheme *sc, s7_pointer obj) /* called by remove_from_heap */
{
  gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t));
  g->p = obj;
  g->nxt = sc->semipermanent_objects;
  sc->semipermanent_objects = g;
}

static void add_semipermanent_let_or_slot(s7_scheme *sc, s7_pointer obj)
{
  gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t));
  g->p = obj;
  g->nxt = sc->semipermanent_lets;
  sc->semipermanent_lets = g;
}

static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x)
{
  const s7_int loc = heap_location(sc, x);
  const s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc);
  sc->heap[loc] = p;
  (*(sc->free_heap_top++)) = p;
  unheap(x);        /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */
  return(x);
}

#if s7_Debugging
#define remove_gensym_from_heap(Sc, Gensym) remove_gensym_from_heap_1(Sc, Gensym, __func__, __LINE__)
static void remove_gensym_from_heap_1(s7_scheme *sc, s7_pointer x, const char *func, int line)
#else
static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to be a symbol and in the heap */
#endif
{
  const s7_int loc = heap_location(sc, x);
  sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc);
  (*(sc->free_heap_top++)) = sc->heap[loc];
#if s7_Debugging
  x->gc_func = func; /* main culprit in s7test/t725 is (essentially) (symbol->keyword (gensym)) */
  x->gc_line = line;
#endif
  unheap(x); /* set T_Unheap bit in type(x) */
  {
    gc_list_t *gp = sc->gensyms;
    for (s7_int i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */
      if (gp->list[i] == x)
	{
	  for (s7_int j = i + 1; i < gp->loc - 1; i++, j++)
	    gp->list[i] = gp->list[j];
	  gp->list[i] = NULL;
	  gp->loc--;
	  if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop;
	  break;
	}}
}

static inline void remove_from_heap(s7_scheme *sc, s7_pointer x)
{
  /* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */
  if (!in_heap(x)) return;
  if (is_pair(x))   /* all the compute time is here, might be faster to go down a level explicitly */
    {
      s7_pointer p = x;
      do {
	petrify(sc, p);
	remove_from_heap(sc, car(p));
	p = cdr(p);
      } while (is_pair(p) && (in_heap(p)));
      if (in_heap(p)) petrify(sc, p);
      return;
    }
  switch (type(x))
    {
    case T_LET: /* very rare */
      if (is_funclet(x)) set_immutable_let(x);
    case T_HASH_TABLE:
    case T_VECTOR:
      /* not byte|int|float|complex_vector or string because none of their elements are GC-able (so unheap below is ok)
       *   but hash-table and let seem like they need protection? And let does happen via define-class.
       */
      add_semipermanent_object(sc, x);
      return;
    case T_SYMBOL:
      if (is_gensym(x))
	remove_gensym_from_heap(sc, x);
      return;
    case T_CLOSURE: case T_CLOSURE_STAR:
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
      /* these need to be GC-protected! */
      add_semipermanent_object(sc, x);
      return;
    default: break;
    }
  petrify(sc, x);
}


/* -------------------------------- stacks -------------------------------- */

/* -------- op stack -------- */
#define Op_Stack_Initial_Size 64

#define op_stack_entry(Sc) (*(Sc->op_stack_now - 1))

#if s7_Debugging
static void push_op_stack(s7_scheme *sc, s7_pointer op)
{
  (*sc->op_stack_now++) = T_Ext(op); /* not T_App etc -- args can be pushed */
  if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size))
    {fprintf(stderr, "%sop_stack overflow%s\n", Bold_Text, Unbold_Text); abort();}
}

static s7_pointer pop_op_stack(s7_scheme *sc)
{
  s7_pointer op = T_Ext(*(--(sc->op_stack_now)));
  if (sc->op_stack_now < sc->op_stack)
    {fprintf(stderr, "%sop_stack underflow%s\n", Bold_Text, Unbold_Text); abort();}
  return(T_Ext(op));
}
#else
#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op
#define pop_op_stack(Sc)      (*(--(Sc->op_stack_now)))
#endif

static void initialize_op_stack(s7_scheme *sc)
{
  sc->op_stack = (s7_pointer *)Malloc(Op_Stack_Initial_Size * sizeof(s7_pointer));
  sc->op_stack_size = Op_Stack_Initial_Size;
  sc->op_stack_now = sc->op_stack;
  sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
  for (int32_t i = 0; i < Op_Stack_Initial_Size; i++) sc->op_stack[i] = sc->unused;
}

static void resize_op_stack(s7_scheme *sc)
{
  const uint32_t new_size = sc->op_stack_size * 2;
  const uint32_t loc = (uint32_t)(sc->op_stack_now - sc->op_stack);
  if (new_size > sc->max_stack_size)
#if s7_Debugging
    {fprintf(stderr, "%s%s[%d]: op stack will be too big after resize, %u > %u%s\n", Bold_Text, __func__, __LINE__, new_size, sc->max_stack_size, Unbold_Text); abort();}
#else
    error_nr(sc, make_symbol(sc, "stack-too-big", 13),
	     set_elist_3(sc, wrap_string(sc, "op stack has grown past (*s7* 'max-stack-size): ~D > ~D", 55),
			 wrap_integer(sc, (s7_int)new_size),
			 wrap_integer(sc, (s7_int)sc->max_stack_size)));
#endif
  sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer));
  for (uint32_t i = sc->op_stack_size; i < new_size; i++) sc->op_stack[i] = sc->unused;
  sc->op_stack_size = (uint32_t)new_size;
  sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc);
  sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
}


/* -------- main stack -------- */
/* stack_top_code changes.  If a function has a tail-call, the stack_top_code that form sees
 *   if stack_top_op==op-begin1 can change from call to call -- the begin actually refers
 *   to the caller, which is dependent on where the current function was called, so we can't hard-wire
 *   any optimizations based on that sequence.
 */

#define stack_op(Stack, Loc)         ((opcode_t)T_Op(stack_element(Stack, Loc)))
#define stack_args(Stack, Loc)       stack_element(Stack, Loc - 1)
#define stack_let(Stack, Loc)        stack_element(Stack, Loc - 2)
#define stack_code(Stack, Loc)       stack_element(Stack, Loc - 3)
#define set_stack_op(Stack, Loc, Op) stack_element(Stack, Loc) = (s7_pointer)(opcode_t)(Op)

#define stack_top_op(Sc)             ((opcode_t)T_Op(Sc->stack_end[-1]))
#define 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]

#if s7_Debugging
void s7_show_stack(s7_scheme *sc);

#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__)
static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line)
{
  sc->stack_end -= 4;
  if (sc->stack_end < sc->stack_start)
    {fprintf(stderr, "%s%s[%d]: stack underflow%s\n", Bold_Text, func, line, Unbold_Text); 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));
  set_curlet_unchecked(sc, stack_end_let(sc));  /* unchecked: 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)
{
  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); 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);
  set_curlet_unchecked(sc, stack_end_let(sc)); /* unchecked: not T_Let|Pos: gc_protect can set this directly (not through push_stack) to anything */
  sc->args = stack_end_args(sc);
}

static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line)
{
  if ((Eval_Print) && (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);
      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); 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_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0)

#define push_stack_no_code(Sc, Op, Args)        push_stack(Sc, Op, Args, Sc->unused)
#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused)
#define push_stack_no_args(Sc, Op, Code)        push_stack(Sc, Op, Sc->unused, Code)
#define push_stack_no_let(Sc, Op, Args, Code)   push_stack(Sc, Op, Args, Code)
#define push_stack_op(Sc, Op)                   push_stack(Sc, Op, Sc->unused, Sc->unused)
#define push_stack_op_let(Sc, Op)               push_stack(Sc, Op, Sc->unused, Sc->unused)
#define push_stack_direct(Sc, Op)               push_stack(Sc, Op, Sc->args, Sc->code)
#define push_stack_no_args_direct(Sc, Op)       push_stack(Sc, Op, Sc->unused, Sc->code)
/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */

#else

#define pop_stack(Sc)       do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
#define pop_stack_no_op(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)

#define push_stack(Sc, Op, Args, Code) \
  do { \
      stack_end_code(Sc) = Code; \
      stack_end_let(Sc) = Sc->curlet; \
      stack_end_args(Sc) = Args; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_direct(Sc, Op) \
  do { \
      Sc->cur_op = Op; \
      memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \
      /* stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); */ \
      Sc->stack_end += 4; \
  } while (0)
/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind messing up memcpy stats?
 *   time's output is all over the map.  I think the cur_op form should be slower, but callgrind disagrees.
 */

#define push_stack_no_code(Sc, Op, Args) \
  do { \
      stack_end_let(Sc) = Sc->curlet; \
      stack_end_args(Sc) = Args; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_no_let_no_code(Sc, Op, Args) \
  do { \
      stack_end_args(Sc) = Args; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_no_args(Sc, Op, Code) \
  do { \
      stack_end_code(Sc) = Code; \
      stack_end_let(Sc) = Sc->curlet; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_no_args_direct(Sc, Op) \
  do { \
      memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer));	\
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_no_let(Sc, Op, Args, Code) \
  do { \
      stack_end_code(Sc) = Code; \
      stack_end_args(Sc) = Args; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_op(Sc, Op) \
  do { \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_op_let(Sc, Op) \
  do { \
      stack_end_let(Sc) = Sc->curlet; \
      stack_end_op(Sc) = (s7_pointer)(opcode_t)(Op); \
      Sc->stack_end += 4; \
  } while (0)
#endif
/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set
 *   sc->code and sc->args to currently free objects.
 */

#if s7_Debugging
#define unstack_with(Sc, Op) unstack_1(Sc, Op, __func__, __LINE__)
static void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line)
{
  sc->stack_end -= 4;
  if ((opcode_t)T_Op(stack_end_op(sc)) != op)
    {
      fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", Bold_Text, func, line, op_names[(opcode_t)T_Op(stack_end_op(sc))], op_names[op], Unbold_Text);
      /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */
      fprintf(stderr, "    code: %s\n    args: %s\n", display(sc->code), display(sc->args));
      fprintf(stderr, "    cur_code: %s\n    estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr")));
      s7_show_stack(sc);
      abort();
    }
}
#define unstack_gc_protect(Sc) unstack_with(Sc, OP_GC_PROTECT)
#else
#define unstack_gc_protect(Sc) Sc->stack_end -= 4
#define unstack_with(Sc, Op) Sc->stack_end -= 4
#endif

static void stack_reset(s7_scheme *sc)
{
  sc->stack_end = sc->stack_start;
  push_stack_op(sc, OP_EVAL_DONE);
}

static uint32_t resize_stack_unchecked(s7_scheme *sc)
{
  const s7_uint loc = stack_top(sc);
  const uint32_t new_size = sc->stack_size * 2;
  block_t *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);
}

#if s7_Debugging
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)]);
}

void s7_show_full_stack(s7_scheme *sc);
void s7_show_full_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++)
    {
      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");
    }
}

#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__)
static void resize_stack_1(s7_scheme *sc, const char *func, int line)
{
  if ((sc->stack_size * 2) > sc->max_stack_size)
    {
      fprintf(stderr, "%s%s[%d]: stack will be too big after resize, %u > %u, trigger: %" ld64 "%s\n",
	      Bold_Text, func, line, sc->stack_size * 2, sc->max_stack_size,
	      (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)),
	      Unbold_Text);
      s7_show_stack(sc);
      abort();
    }
  resize_stack_unchecked(sc);
}
#else
static void resize_stack(s7_scheme *sc)
{
  const uint32_t new_size = resize_stack_unchecked(sc);
  if (show_stack_stats(sc))
    s7_warn(sc, s7_Warn_Bufsize, "stack grows to %u\n", new_size);
  if (new_size > sc->max_stack_size)
    error_nr(sc, make_symbol(sc, "stack-too-big", 13),
	     set_elist_3(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size): ~D > ~D", 52),
			 wrap_integer(sc, new_size),
			 wrap_integer(sc, sc->max_stack_size)));
  /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */
}
#endif

#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0)

s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x)
{
  check_stack_size(sc); /* this can be called externally, so we need to be careful about this */
  push_stack_no_code(sc, OP_GC_PROTECT, x);
  return(x);
}

s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  check_stack_size(sc);
  push_stack(sc, OP_GC_PROTECT, x, y);
  return(x);
}

s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x)
{
  unstack_gc_protect(sc); /* this might not be related to 'x' -- something got unprotected */
  return(x);
}

#if s7_Debugging
  static s7_pointer stack_protected1_1(s7_scheme *sc, opcode_t op, const char *func, int line)
  {
    if (stack_top_op(sc) != op)
      {fprintf(stderr, "%s[%d]: stack_protected1 %s\n", func, line, op_names[stack_top_op(sc)]); abort();}
    return(stack_top_args(sc));
  }

  static s7_pointer stack_protected2_1(s7_scheme *sc, opcode_t op, const char *func, int line)
  {
    if (stack_top_op(sc) != op)
      {fprintf(stderr, "%s[%d]: stack_protected2 %s\n", func, line, op_names[stack_top_op(sc)]); abort();}
    return(stack_top_code(sc));
  }

  static s7_pointer stack_protected3_1(s7_scheme *sc, opcode_t op, const char *func, int line)
  {
    if (stack_top_op(sc) != op)
      {fprintf(stderr, "%s[%d]: stack_protected3 %s\n", func, line, op_names[stack_top_op(sc)]); abort();}
    return(stack_top_let(sc));
  }

  #define stack_protected1(Sc, Op) stack_protected1_1(Sc, Op, __func__, __LINE__)
  #define stack_protected2(Sc, Op) stack_protected2_1(Sc, Op, __func__, __LINE__)
  #define stack_protected3(Sc, Op) stack_protected3_1(Sc, Op, __func__, __LINE__)

  #define set_stack_protected1(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected1 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_args(Sc) = Val;} while (0)
  #define set_stack_protected2(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected2 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_code(Sc) = Val;} while (0)
  #define set_stack_protected3(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected3 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_let(Sc) = Val;} while (0)

#else

  #define stack_protected1(Sc, Op) stack_top_args(Sc)
  #define stack_protected2(Sc, Op) stack_top_code(Sc)
  #define stack_protected3(Sc, Op) stack_top_let(Sc)

  #define set_stack_protected1(Sc, Val, Op) stack_top_args(Sc) = Val
  #define set_stack_protected2(Sc, Val, Op) stack_top_code(Sc) = Val
  #define set_stack_protected3(Sc, Val, Op) stack_top_let(Sc) = Val
#endif

#define gc_protected1(Sc) stack_protected1(Sc, OP_GC_PROTECT)
#define gc_protected2(Sc) stack_protected2(Sc, OP_GC_PROTECT)
#define gc_protected3(Sc) stack_protected3(Sc, OP_GC_PROTECT)

#define set_gc_protected1(Sc, Val) set_stack_protected1(Sc, Val, OP_GC_PROTECT)
#define set_gc_protected2(Sc, Val) set_stack_protected2(Sc, Val, OP_GC_PROTECT)
#define set_gc_protected3(Sc, Val) set_stack_protected3(Sc, Val, OP_GC_PROTECT)

#define map_unwind_list(Sc)          stack_protected3(Sc, OP_MAP_UNWIND)
#define set_map_unwind_list(Sc, Val) set_stack_protected3(Sc, Val, OP_MAP_UNWIND)

#define gc_protect_curlet_via_stack(Sc)      push_stack_op_let(Sc, OP_GC_PROTECT)
#define gc_protected_let_via_stack(Sc)       stack_top_let(Sc)
#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]);
    }
  if (len <= 16)
    {
      s7_uint xs[2] = {0, 0};
      memcpy((void *)xs, (const void *)key, len);
      return(xs[0] + xs[1]);
    }
  {
    s7_uint xs[3] = {0, 0, 0};
    memcpy((void *)xs, (const void *)key, (len > 24) ? 24 : len);
    return(xs[0] + xs[1] + xs[2]);
  }
}

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)
{
  const 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) */
  set_alloc_info(str, __func__, __LINE__);
  string_length(str) = len;
  string_value(str) = (char *)val;
  string_hash(str) = hash;

  full_type(new_sym) = T_SYMBOL | T_Unheap;
  set_alloc_info(new_sym, __func__, __LINE__);
  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, (s7_int)0, 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 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);
      {
	s7_pointer 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 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);
}

static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_int len) /* inline out: ca 40=2% in tload */
{ /* name here might not be null-terminated or aligned */
  const s7_uint hash = raw_string_hash((const uint8_t *)name, len);
  const uint32_t location = hash % Symbol_Table_Size;

  if (len <= 8)
    {
      for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms))
	if ((hash == pair_raw_hash(syms)) &&
	    ((s7_uint)len == pair_raw_len(syms)))
	  return(car(syms));
    }
  else /* checking name[len=='\0' and using strcmp if so was not a big win */
    for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms))
      if ((hash == pair_raw_hash(syms)) &&
	  ((s7_uint)len == pair_raw_len(syms)) &&
	  (strings_are_equal_with_length(name, pair_raw_name(syms), len))) /* length here because name might not be null-terminated or aligned */
	return(car(syms));
  return(new_symbol(sc, name, len, hash, location));
}

static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));}

s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));}

static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, s7_uint hash, uint32_t location, s7_int len)
{
  for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms))
    if ((hash == pair_raw_hash(syms)) &&
	(strings_are_equal_with_length(name, pair_raw_name(syms), len)))
      return(car(syms));
  return(sc->nil);
}

s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name)
{
  s7_int len = safe_strlen(name);
  s7_uint hash = raw_string_hash((const uint8_t *)name, len);
  s7_pointer result = symbol_table_find_by_name(sc, name, hash, hash % Symbol_Table_Size, len);
  return((is_null(result)) ? NULL : result);
}


/* -------------------------------- symbol-table -------------------------------- */
static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len);

static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_symbol_table "(symbol-table) returns a vector containing the current contents (symbols) of s7's symbol-table"
  #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol)

  int32_t syms = 0;
  s7_pointer *entries = vector_elements(sc->symbol_table);

  /* this can't be optimized by returning the actual symbol-table (a vector of lists), because
   *    gensyms can cause the table's lists and symbols to change at any time.  This wreaks havoc
   *    on traversals like for-each.  So, symbol-table returns a snap-shot of the table contents
   *    at the time it is called.
   * can be called in gdb: p display(s7_eval_c_string(sc, "(for-each (lambda (x) (when (gensym? x) (format *stderr* \"~A \" x))) (symbol-table))"))
   */
  for (int32_t i = 0; i < Symbol_Table_Size; i++)
    for (s7_pointer symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist))
      syms++;
  if (syms > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "symbol-table size, ~D, is greater than (*s7* 'max-vector-length), ~D", 68),
			 wrap_integer(sc, syms), wrap_integer(sc, sc->max_vector_length)));
  {
    const s7_pointer vec = make_simple_vector(sc, syms);
    s7_pointer *els = vector_elements(vec);
    set_is_symbol_table(vec);
    for (int32_t i = 0, j = 0; i < Symbol_Table_Size; i++)
      for (s7_pointer symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist))
	els[j++] = car(symlist);
    return(vec);
  }
}

bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data)
{
  /* this includes the special constants #<unspecified> 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("#<unspecified>", data)) || (symbol_func("#<undefined>", data))   ||
	 (symbol_func("#<eof>", data))         ||
	 (symbol_func("#true", data))          || (symbol_func("#false", data)));
}

bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data)
{
  for (int32_t i = 0; i < Symbol_Table_Size; i++)
    for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms))
      if (symbol_func(symbol_name(car(syms)), data))
	return(true);
  return(false);
}


/* -------------------------------- gensym -------------------------------- */
static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym)
{
  /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */
  const uint32_t location = string_hash(symbol_name_cell(sym)) % Symbol_Table_Size;
  s7_pointer symbols = vector_element(sc->symbol_table, location);
  if (car(symbols) == sym)
    vector_element(sc->symbol_table, location) = cdr(symbols);
  else
    for (s7_pointer syms = cdr(symbols); is_pair(syms); symbols = syms, syms = cdr(syms))
      if (car(syms) == sym)
	{
	  set_cdr_unchecked(symbols, cdr(syms)); /* delete z */
	  return;
	}
}

s7_pointer s7_gensym(s7_scheme *sc, const char *prefix)
{
  const s7_int len = safe_strlen(prefix) + 32;
  block_t *b = mallocate(sc, len);
  char *name = (char *)block_data(b);
  /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */
  name[0] = '\0';
  {
    const s7_int slen = catstrs(name, len, "{", (prefix) ? prefix : "", "}-", pos_int_to_str_direct(sc, sc->gensym_counter++), (char *)NULL);
    const s7_uint hash = raw_string_hash((const uint8_t *)name, slen);
    const int32_t location = hash % Symbol_Table_Size;
    const s7_pointer x = new_symbol(sc, name, slen, hash, location);  /* not T_Gensym -- might be called from outside so should not be GC'd(?) */
    liberate(sc, b);
    return(x);
  }
}

static bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));}

static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args)
{
  #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym"
  #define Q_is_gensym sc->pl_bt
  check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args);
}

static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args)
{
  #define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol"
  #define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol)

  const char *prefix;
  s7_int plen;

  /* get symbol name */
  if (is_pair(args))
    {
      s7_pointer gname = car(args);
      if (!is_string(gname))
	return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING]));
      prefix = string_value(gname);
      plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */
    }
  else
    {
      prefix = "gensym";
      plen = 6;
    }

  {
    s7_int len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19, see gensym name collision loop below */
    /* it might be better (less predictable) to use a random number instead of gensym_counter, but that looks messy */
    block_t *b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell));
    char *base = (char *)block_data(b);
    s7_pointer str = (s7_cell *)base;
    s7_pointer stc = (s7_cell *)(base + sizeof(s7_cell));
    block_t *ib = (block_t *)(base + 2 * sizeof(s7_cell));
    char *name = (char *)(base + sizeof(block_t) + 2 * sizeof(s7_cell));
    name[0] = '{';
    memcpy((void *)(name + 1), prefix, plen); /* memcpy is ok with plen==0, I think */
    name[plen + 1] = '}';
    name[plen + 2] = '-'; /* {gensym}-nnn */

    {
      s7_pointer new_gensym;
      s7_uint hash;
      uint32_t location;
      s7_int nlen;
      while (true)
	{
	  const char *p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0');
	  memcpy((void *)(name + plen + 3), (void *)p, len);
	  nlen = len + plen + 2;
	  name[nlen] = '\0';
	  hash = raw_string_hash((const uint8_t *)name, nlen);
	  location = hash % Symbol_Table_Size;
	  if (is_null(symbol_table_find_by_name(sc, name, hash, location, nlen))) break;
	  if (sc->safety > No_Safety)
	    s7_warn(sc, nlen + 25, "%s collides with gensym?\n", name);
	}

      /* make-string for symbol name */
      if (s7_Debugging) full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */
      set_full_type(str, T_STRING | T_Immutable); /* was T_Unheap? 17-Mar-25 */
      string_length(str) = nlen;
      string_value(str) = name;
      string_hash(str) = hash;

      /* allocate the symbol in the heap so GC'd when inaccessible */
      new_cell(sc, new_gensym, T_SYMBOL | T_Gensym);
      symbol_set_name_cell(new_gensym, str);
      symbol_info(new_gensym) = ib;
      set_global_slot(new_gensym, sc->undefined);   /* undefined_slot? */
      set_initial_value(new_gensym, sc->undefined);
      symbol_set_local_slot_unchecked(new_gensym, (s7_int)0, 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;

      /* 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);
    }}
}


/* -------------------------------- syntax? -------------------------------- */
bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));}

static s7_pointer g_is_syntax(s7_scheme *sc, s7_pointer args)
{
  #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)"
  #define Q_is_syntax sc->pl_bt
  check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args);
}


/* -------------------------------- symbol? -------------------------------- */
bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));}

static s7_pointer g_is_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol"
  #define Q_is_symbol sc->pl_bt
  check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args);
}

const char *s7_symbol_name(s7_pointer sym) {return(symbol_name(sym));}

s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_value(sc, make_symbol_with_strlen(sc, name)));}
/* should this also handle non-symbols such as "+nan.0"? */


/* -------------------------------- symbol->string -------------------------------- */
static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len)
{
  s7_pointer 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);
}

static s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len)
{
  return(inline_make_string_with_length(sc, str, len)); /* packaged to avoid inlining everywhere */
}

static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string"
  #define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol)

  const s7_pointer sym = car(args);
  if (!is_symbol(sym))
    return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL]));
  /* s7_make_string uses strlen which stops at an embedded null */
  if (symbol_name_length(sym) > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "symbol->string symbol name is too large: (> ~D ~D) (*s7* 'max-string-length)", 76),
			 wrap_integer(sc, symbol_name_length(sym)), wrap_integer(sc, sc->max_string_length)));
  return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));    /* return a copy */
}

static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer sym = car(args);
  if (!is_symbol(sym))
    return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL]));
  if (is_gensym(sym))
    return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));    /* return a copy of gensym name (which will be freed) */
  return(symbol_name_cell(sym));
}

static s7_pointer symbol_to_string_p_p(s7_scheme *sc, s7_pointer sym)
{
  if (!is_symbol(sym))
    return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL]));
  if (symbol_name_length(sym) > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "symbol->string symbol name is too large: (> ~D ~D) (*s7* 'max-string-length)", 76),
			 wrap_integer(sc, symbol_name_length(sym)), wrap_integer(sc, sc->max_string_length)));
  return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));
}

static s7_pointer symbol_to_string_uncopied_p(s7_scheme *sc, s7_pointer sym)
{
  if (!is_symbol(sym))
    return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL]));
  if (is_gensym(sym))
    return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));
  return(symbol_name_cell(sym));
}


/* -------------------------------- string->symbol -------------------------------- */
static inline s7_pointer string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer caller)
{
  if (!is_string(str))
    return(method_or_bust_p(sc, str, caller, sc->type_names[T_STRING]));
  if (string_length(str) <= 0)
    sole_arg_wrong_type_error_nr(sc, caller, str, wrap_string(sc, "a non-null string", 17));
  return(make_symbol(sc, string_value(str), string_length(str)));
}

static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol"
  #define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
  return(string_to_symbol_1(sc, car(args), sc->string_to_symbol_symbol));
}

static s7_pointer string_to_symbol_p_p(s7_scheme *sc, s7_pointer p) {return(string_to_symbol_1(sc, p, sc->string_to_symbol_symbol));}


/* -------------------------------- symbol -------------------------------- */
static s7_pointer 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(string_to_symbol_1(sc, car(args), sc->symbol_symbol)));
      return(mark_as_symbol_from_symbol(string_to_symbol_1(sc, string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol)));
    }
  if (len == 0)
    sole_arg_wrong_type_error_nr(sc, sc->symbol_symbol, car(args), wrap_string(sc, "a non-null string", 17));

  { /* can't use catstrs_direct here because it stops at embedded null */
    block_t *b = mallocate(sc, len + 1);
    char *name = (char *)block_data(b);
    s7_pointer sym;
    p = args;
    for (s7_int cur_len = 0; is_pair(p); p = cdr(p))
      {
	s7_pointer str = car(p);
	if (string_length(str) > 0)
	  {
	    memcpy((void *)(name + cur_len), (void *)string_value(str), string_length(str));
	    cur_len += string_length(str);
	  }}
    name[len] = '\0';
    sym = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len));
    liberate(sc, b);
    return(sym);
  }
}

/* chooser, if arg=number->string wrap but even g_number_to_string_p_p is unpleasing */

static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  #define Sym_Bufsize 256
  char buf[Sym_Bufsize];
  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 >= Sym_Bufsize)) return(g_symbol(sc, set_plist_2(sc, str1, str2)));
  memcpy((void *)buf, (void *)string_value(str1), string_length(str1));
  memcpy((void *)(buf + string_length(str1)), (void *)string_value(str2), string_length(str2));
  return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len)));
}

/* -------- symbol-initial-value -------- */
static s7_pointer g_symbol_initial_value(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_initial_value "(symbol-initial-value sym) returns the initial binding of the symbol sym"
  #define Q_symbol_initial_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)

  s7_pointer symbol = car(args);
  if (!is_symbol(symbol)) /* or is_normal_symbol? now (symbol-initial-value :hi) -> #<undefined> */
    return(sole_arg_method_or_bust(sc, symbol, sc->symbol_initial_value_symbol, set_plist_1(sc, symbol), sc->type_names[T_SYMBOL]));
  return(initial_value(symbol));
}

static s7_pointer g_symbol_set_initial_value(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer symbol = car(args), value = cadr(args);
  if (!is_symbol(symbol))
    wrong_type_error_nr(sc, wrap_string(sc, "set! symbol-initial-value", 25), 1, symbol, sc->type_names[T_SYMBOL]);
  if (initial_value_is_defined(sc, symbol))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set! (symbol-initial-value ~$); it is immutable", 53), symbol));
  set_initial_value(symbol, value);
  if (in_heap(value)) add_semipermanent_object(sc, value);
  /* should this tie into unlet? */
  return(value);
}

s7_pointer s7_symbol_initial_value(s7_pointer symbol) {return(initial_value(symbol));}

static bool is_eq_initial_value(s7_pointer symbol, s7_pointer other)
{
  const s7_pointer init = initial_value(symbol);
  if (init == other) return(true);
  if (is_c_function(init)) return((is_c_function(other)) && (c_function_data(init) == c_function_data(other)));
  if (is_syntax(init)) return((is_syntax(other)) && (syntax_symbol(init) == syntax_symbol(other)));
  if (is_unspecified(init)) return(is_unspecified(other));
  if (is_c_macro(init)) return((is_c_macro(other)) && (c_macro_data(init) == c_macro_data(other)));
  return(false);
}

static bool is_eq_initial_c_function_data(s7_pointer symbol, s7_pointer s_func)
{
  return((is_c_function(s_func)) && (c_function_data(s_func) == c_function_data(initial_value(symbol))));
}

static void copy_initial_value(s7_scheme *sc, s7_pointer sym)
{
  s7_pointer curval = initial_value(sym);
  if (!is_symbol(curval)) /* otherwise we end up with a copied symbol */
    {
      s7_pointer newval = alloc_pointer(sc);
      memcpy((void *)newval, (void *)curval, sizeof(s7_cell));
      set_is_initial_value(newval);
      set_initial_value(sym, newval);
    }
}

s7_pointer s7_symbol_set_initial_value(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
{
  if (initial_value(symbol) == sc->undefined)
    {
      set_initial_value(symbol, value);
      /* copy_initial_value(sc, symbol); */
      if (in_heap(value)) add_semipermanent_object(sc, value);
    }
  return(initial_value(symbol));
}


/* -------- small symbol set -------- */

#if s7_Debugging
enum {Set_Ignore, Set_Begin, Set_End};

#define symbol_is_in_small_symbol_set(Sc, Sym) symbol_is_in_small_symbol_set_1(Sc, Sym, __func__, __LINE__)
static bool symbol_is_in_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line)
{
  if (sc->small_symbol_set_state == Set_End)
    fprintf(stderr, "%s[%d]: small_symbol_set membership test but it's not running\n", func, line);
  return(small_symbol_tag(sym) == sc->small_symbol_tag);
}

#define add_symbol_to_small_symbol_set(Sc, Sym) add_symbol_to_small_symbol_set_1(Sc, Sym, __func__, __LINE__)
static s7_pointer add_symbol_to_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line)
{
  if (sc->small_symbol_set_state == Set_End)
    fprintf(stderr, "%s[%d]: small_symbol_set add member but it's not running\n", func, line);
  set_small_symbol_tag(sym, sc->small_symbol_tag);
  return(sym);
}

#define clear_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, Set_Ignore, __func__, __LINE__)
static void clear_small_symbol_set_1(s7_scheme *sc, int status, const char *func, int line)
{
  /* if running end is ok, begin is an error, if not running end is error, begin is ok */
  if (status == Set_Begin)
    {
      if (sc->small_symbol_set_state == Set_Begin)
	{
	  fprintf(stderr, "%s[%d]: small_symbol_set is running but begin requested (started at %s[%d])\n",
		  func, line, sc->small_symbol_set_func, sc->small_symbol_set_line);
	  abort();
	}
      sc->small_symbol_set_func = func;
      sc->small_symbol_set_line = line;
    }
  if ((status == Set_End) && (sc->small_symbol_set_state == Set_End))
    fprintf(stderr, "%s[%d]: small_symbol_set is not running but end requested (started at %s[%d])\n",
	    func, line, sc->small_symbol_set_func, sc->small_symbol_set_line);
  sc->small_symbol_set_state = status;

  if (sc->small_symbol_tag == 0) /* see comment below */
    {
      s7_pointer *els = vector_elements(sc->symbol_table);
      for (int32_t i = 0; i < Symbol_Table_Size; i++) /* clear old small_symbol_tags */
	for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms))
	  set_small_symbol_tag(car(syms), 0);
      sc->small_symbol_tag = 1;
    }
  else sc->small_symbol_tag++;
}

#define begin_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, Set_Begin, __func__, __LINE__)
#define end_small_symbol_set(Sc)   clear_small_symbol_set_1(Sc, Set_End, __func__, __LINE__)

#else

#define symbol_is_in_small_symbol_set(Sc, Sym) (small_symbol_tag(Sym) == Sc->small_symbol_tag)

static /* inline */ s7_pointer add_symbol_to_small_symbol_set(s7_scheme *sc, s7_pointer sym)
{
  set_small_symbol_tag(sym, sc->small_symbol_tag);
  return(sym);
}

static /* inline */ void clear_small_symbol_set(s7_scheme *sc)
{
  if (sc->small_symbol_tag == 0) /* or 2^32 - 1, but that's much slower than checking for 0 -- unsigned wrap around is defined in C */
    {
      s7_pointer *els = vector_elements(sc->symbol_table);
      for (int32_t i = 0; i < Symbol_Table_Size; i++) /* clear old small_symbol_tags */
	for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms))
	  set_small_symbol_tag(car(syms), 0);
      sc->small_symbol_tag = 1;
    }
  else sc->small_symbol_tag++;
}

#define begin_small_symbol_set(Sc) clear_small_symbol_set(Sc)
#define end_small_symbol_set(Sc)
#endif

/* -------- big symbol set -------- */
#define symbol_is_in_big_symbol_set(Sc, Sym) (big_symbol_tag(Sym) == Sc->big_symbol_tag)
#define clear_big_symbol_set(Sc) Sc->big_symbol_tag++

static s7_pointer add_symbol_to_big_symbol_set(s7_scheme *sc, s7_pointer sym)
{
  if (symbol_is_in_big_symbol_set(sc, sym)) symbol_shadows(sym)++; else symbol_clear_shadows(sym);
  set_big_symbol_tag(sym, sc->big_symbol_tag);
  return(sym);
}


/* -------------------------------- lets/slots -------------------------------- */
static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let)
{
  s7_pointer new_let;
  new_cell(sc, new_let, T_LET | T_Safe_Procedure);
  let_set_id(new_let, ++sc->let_number);
  let_set_slots(new_let, Slot_End);
  let_set_outlet(new_let, old_let);
  return(new_let);
}

static inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));}

static Inline s7_pointer inline_make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value)
{
  s7_pointer new_let, slot;
  sc->value = value;
  new_cell(sc, new_let, T_LET | T_Safe_Procedure);
  let_set_id(new_let, ++sc->let_number);
  let_set_outlet(new_let, old_let);
  new_cell_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)
{
  const s7_pointer let = wrap_let(sc, old_let); /* increments let_number */
  const 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 */
static inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, s7_uint id)
{
  s7_pointer slot;
  new_cell_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 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 add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let))

static inline s7_pointer add_slot_checked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol_and_value(slot, symbol, value);
  symbol_set_local_slot(symbol, let_id(let), slot);
  slot_set_next(slot, let_slots(let));
  let_set_slots(let, slot);
  return(slot);
}

static inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol_and_value(slot, symbol, value);
  set_local(symbol);
  if (let_id(let) >= symbol_id(symbol))
    symbol_set_local_slot(symbol, let_id(let), slot);
  slot_set_next(slot, let_slots(let));
  let_set_slots(let, slot);
  return(slot);
}

static inline s7_pointer add_slot_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* no symbol_set_local_slot, no set_local */
{
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol_and_value(slot, symbol, value);
  slot_set_next(slot, let_slots(let));
  let_set_slots(let, slot);
  return(slot);
}

static s7_pointer add_slot_unchecked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  s7_pointer slot;
  new_cell_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);
}

static inline s7_pointer add_slot_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
{
  s7_pointer slot;
  new_cell_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 add_slot_checked_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
{ /* same as above but new_cell is checked */
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol_and_value(slot, symbol, value);
  slot_set_next(slot, Slot_End);
  symbol_set_local_slot(symbol, id, slot);
  slot_set_next(last_slot, slot);
  return(slot);
}

static s7_pointer add_slot_at_end_no_local(s7_scheme *sc, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
{
  s7_pointer slot;
  new_cell_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;
  const s7_pointer 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(s7_scheme *sc, s7_pointer let)
{
  const s7_int id = ++sc->let_number;
  let_set_id(let, id);
  for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
    symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot);
  return(let);
}

static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val)
{
  const s7_pointer slot = let_slots(let);
  const 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);
  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);
  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, symbol;
  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);
  symbol = is_pair(car(vars)) ? caar(vars) : car(vars);
  slot = make_semipermanent_slot(sc, symbol, sc->F);
  add_semipermanent_let_or_slot(sc, slot);
  symbol_set_local_slot(symbol, 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;
      symbol = is_pair(car(var)) ? caar(var) : car(var);
      slot = make_semipermanent_slot(sc, symbol, sc->F);
      add_semipermanent_let_or_slot(sc, slot);
      symbol_set_local_slot(symbol, sc->let_number, slot);
      slot_set_next(last_slot, slot);
    }
  slot_set_next(slot, Slot_End);
  add_semipermanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */
  return(let);
}

static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value);

static inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value)
{
  if (slot_has_setter(slot))
    slot_set_value(slot, call_setter(sc, slot, value));
  else
    {
      if (is_immutable_slot(slot))
	immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->let_set_symbol, slot_symbol(slot)));
      slot_set_value(slot, value);
    }
  return(slot_value(slot));
}

static s7_pointer let_fill(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer let = car(args);
  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));
  {
    s7_pointer val = cadr(args);
    for (s7_pointer slot = let_slots(let); is_slot_checked(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_slot_checked(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); /* we want an s7_int here, should we raise an error? */
	}}
  {
    s7_int i = 0;
    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); i++, slot = next_slot(slot));
    return(i);
  }
}

static 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 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))))) */
  const s7_pointer symbol = slot_symbol(slot);
  if ((global_slot(symbol) == slot) &&
      (value != slot_value(slot)))
    s7_call(sc, sc->rootlet_redefinition_hook, set_plist_2(sc, symbol, value));
  slot_set_value(slot, value);
}

static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */

static void remove_let_from_heap(s7_scheme *sc, s7_pointer let)
{
  for (s7_pointer slot = let_slots(let); is_slot_checked(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);
}

static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym)
{
  if ((has_closure_let(x)) && (is_let(closure_let(x))) && (closure_let(x) != sc->rootlet))
    {
      s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x));
      if ((!is_slot(val)) && (let_outlet(closure_let(x)) != sc->rootlet))
	val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x)));
      if (is_slot(val))
	return(slot_value(val));
    }
  return(NULL);
}

static void remove_function_from_heap(s7_scheme *sc, s7_pointer value)
{
  remove_from_heap(sc, closure_pars(value));
  remove_from_heap(sc, closure_body(value)); /* this is where the compute time goes */
  /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */

  { /* not sure this is worth the effort (finds 46 strings during s7test, checks 407 functions) */
    s7_pointer val = funclet_entry(sc, value, sc->local_documentation_symbol);
    if ((val) && (is_string(val)) && (in_heap(val))) petrify(sc, val);
  }
  {
    s7_pointer 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);
	  }}}
}

static void add_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_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 -- why is this here? */
	       (is_c_function(value))))   /* || (is_syntax(value)) -- we need 'else as a special case? */
	    /* the c_function check is overly paranoid -- all we need is that the value is semipermanent (T_Unheap?) */
	    {
	      set_initial_value(symbol, value);
	      if (/* (!sc->string_signature) && */ (is_c_function(value))) /* syntax can't happen here (it's handled explicitly in syntax procedure) */
		add_to_unlet(sc, symbol);
	      /* else fprintf(stderr, "%s unlet: %s\n", display(symbol), display(value)); */
	    }
	  set_local_slot(symbol, slot);
	}
      symbol_increment_ctr(symbol);
      if (is_gensym(symbol))
	remove_gensym_from_heap(sc, symbol);
      return(slot);
    }
  return(add_slot_checked_with_id(sc, let, symbol, value));
  /* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code */
}

static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value)
{
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol_and_value(slot, variable, value);
  return(slot);
}


/* -------------------------------- let? -------------------------------- */
bool s7_is_let(s7_pointer let) {return(is_let(let));}

static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args)
{
  #define H_is_let "(let? obj) returns #t if obj is a let."
  #define Q_is_let sc->pl_bt
  const s7_pointer let = car(args);
  s7_pointer func;
  if (!has_active_methods(sc, let))
    return(make_boolean(sc, is_let(let)));
  func = find_method_with_let(sc, let, sc->is_let_symbol);
  if (func == sc->undefined)
    return(make_boolean(sc, is_let(let)));
  return(s7_apply_function(sc, func, set_mlist_1(sc, let)));
}


/* -------------------------------- funclet? -------------------------------- */
static s7_pointer g_is_funclet(s7_scheme *sc, s7_pointer args)
{
  #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)."
  #define Q_is_funclet sc->pl_bt

  const s7_pointer let = car(args);
  if (let == sc->rootlet) return(sc->F);
  if ((is_let(let)) && ((is_funclet(let)) || (is_maclet(let))))
    return(sc->T);
  if (!has_active_methods(sc, let))
    return(sc->F);
  return(apply_boolean_method(sc, let, sc->is_funclet_symbol));
}


/* -------------------------------- unlet -------------------------------- */
static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args)
{
  /* add sc->unlet bindings to the current environment */
  #define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions"
  #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol)

  const s7_pointer result = make_let(sc, sc->curlet);
  begin_temp(sc->y, result);
  set_is_unlet(result);
  if (global_value(sc->else_symbol) != sc->else_symbol)
    add_slot_checked_with_id(sc, result, sc->else_symbol, initial_value(sc->else_symbol));
  for (unlet_entry_t *p = sc->unlet_entries; p; p = p->next)
    {
      s7_pointer sym = p->symbol;
      if ((!is_eq_initial_value(sym, global_value(sym))) ||  /* it has been changed globally */
	  ((!is_global(sym)) &&        /* it might be shadowed locally */
	   (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym))))
	add_slot_checked_with_id(sc, result, sym, initial_value(sym));
    }
  end_temp(sc->y);
  return(result);
}


/* -------------------------------- openlet? -------------------------------- */
bool s7_is_openlet(s7_pointer let) {return(has_methods(let));}

static s7_pointer g_is_openlet(s7_scheme *sc, s7_pointer args)
{
  #define H_is_openlet "(openlet? obj) returns #t if 'obj' has methods."
  #define Q_is_openlet sc->pl_bt

  s7_pointer let = car(args);  /* if let is not a let, should this raise an error? -- no, easier to use this way in cond */
  if_method_exists_return_value(sc, let, sc->is_openlet_symbol, args);
  return(make_boolean(sc, has_methods(let)));
}


/* -------------------------------- openlet -------------------------------- */
s7_pointer s7_openlet(s7_scheme *sc, s7_pointer let)
{
  /* if e is not a let, the openlet bit is still set on it (c-pointer etc) */
  set_has_methods(let);
  return(let);
}

static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args)
{
  #define H_openlet "(openlet e) tells the built-in functions that the let e might have an over-riding method. e is returned."
  #define Q_openlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc))

  const s7_pointer let = car(args);
  s7_pointer new_let, func;
  if (!is_let(let))
    {
      new_let = find_let(sc, let);
      if ((!is_let(new_let)) || (new_let == sc->rootlet))
	find_let_error_nr(sc, sc->openlet_symbol, let, new_let, 1, args);
    }
  else new_let = let;
  if ((new_let == sc->rootlet) || (new_let == sc->starlet))
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't openlet ~S", 16), let));
  if (is_unlet(new_let)) /* protect against infinite loop: (let () (define + -) (with-let (unlet) (+ (openlet (unlet)) 2))) */
    error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet unlet", 19)));
  if ((has_active_methods(sc, let)) &&
      ((func = find_method(sc, new_let, sc->openlet_symbol)) != sc->undefined))
    return(s7_apply_function(sc, func, args));
  set_has_methods(let);
  return(let); /* openlet and coverlet return their argument */
}

/* -------------------------------- coverlet -------------------------------- */
static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args)
{
  #define H_coverlet "(coverlet e) undoes an earlier openlet.  e is returned."
  #define Q_coverlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc))

  const s7_pointer let = car(args);
  s7_pointer new_let, func;
  if (!is_let(let))
    {
      new_let = find_let(sc, let);
      if ((!is_let(new_let))  || (new_let == sc->rootlet))
	find_let_error_nr(sc, sc->coverlet_symbol, let, new_let, 1, args);
    }
  else new_let = let;
  if ((new_let == sc->rootlet) || (new_let == sc->starlet))
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), let));
  if (is_unlet(new_let))
    error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet unlet", 20)));
  if ((has_active_methods(sc, let)) &&
      ((func = find_method(sc, new_let, sc->coverlet_symbol)) != sc->undefined))
    return(s7_apply_function(sc, func, args));
  clear_has_methods(let);
  return(let); /* mimic openlet in everything */
}


/* -------------------------------- varlet -------------------------------- */
static void check_let_fallback(s7_scheme *sc, const s7_pointer symbol, s7_pointer let)
{
  if (symbol == sc->let_ref_fallback_symbol)
    set_has_let_ref_fallback(let);
  else
    if (symbol == sc->let_set_fallback_symbol)
      set_has_let_set_fallback(let);
}

static void append_let(s7_scheme *sc, s7_pointer new_let, s7_pointer old_let, s7_pointer caller)
{
  if (new_let == sc->rootlet)
    for (s7_pointer slot = let_slots(old_let); is_slot_checked(slot); slot = next_slot(slot))
      {
	s7_pointer sym = slot_symbol(slot), val = slot_value(slot);
	if (is_slot(global_slot(sym)))
	  set_global_value(sym, val);
	else s7_make_slot(sc, sc->rootlet, sym, val);
      }
  else
    if (old_let == sc->starlet)
      {
	const s7_pointer iter = s7_make_iterator(sc, sc->starlet);
	const s7_int gc_loc = gc_protect_1(sc, iter);
	iterator_carrier(iter) = cons_unchecked(sc, sc->unused, sc->unused);
	set_has_carrier(iter); /* so carrier is GC protected by mark_iterator */
	while (true)
	  {
	    s7_pointer field = s7_iterate(sc, iter);
	    if (iterator_is_at_end(iter)) break;
	    add_slot_checked_with_id(sc, new_let, car(field), cdr(field));
	  }
	s7_gc_unprotect_at(sc, gc_loc);
      }
    else
      {
	if (let_id(new_let) != sc->let_number)
	  update_let(sc, new_let);
	for (s7_pointer slot = let_slots(old_let); is_slot_checked(slot); slot = next_slot(slot))
	  {
	    /* fprintf(stderr, "%s %" ld64 " %" ld64 "\n", display(slot), let_id(new_let), symbol_id(slot_symbol(slot))); */
	    if (let_id(new_let) == symbol_id(slot_symbol(slot)))
	      error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S: '~S", 31), caller, slot_symbol(slot)));
	    add_slot_checked_with_id(sc, new_let, slot_symbol(slot), slot_value(slot)); /* not add_slot here because it might run off the free heap end */
	  }}
}

s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  if (!is_let(let))
    wrong_type_error_nr(sc, sc->varlet_symbol, 1, let, A_Let_String);
  if (!is_symbol(symbol))
    wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, A_Symbol_String);
#if 0
  if ((is_slot(global_slot(symbol))) &&
      (is_syntax(global_value(symbol))))
    wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22));
#endif
  if (let == sc->rootlet)
    {
      if (is_slot(global_slot(symbol)))
	set_global_value(symbol, value);
      else s7_make_slot(sc, sc->rootlet, symbol, value);
    }
  else
    {
      add_slot_checked_with_id(sc, let, symbol, value);
      check_let_fallback(sc, symbol, let);
    }
  return(value);
}

static int32_t position_of(const s7_pointer p, s7_pointer args)
{
  int32_t i;
  for (i = 1; p != args; i++, args = cdr(args));
  return(i);
}

static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args)   /* varlet = with-let + define */
{
  #define H_varlet "(varlet target-let ...) adds its arguments (a let, a cons: (symbol . value), or two arguments, the symbol and its value) \
to the let target-let, and returns target-let.  (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1."
  #define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, has_let_signature(sc), \
                     s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), sc->T)
  s7_pointer let = car(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->varlet_symbol, let, new_let, 1, args);
      let = new_let;
    }
  if ((is_immutable_let(let)) || (let == sc->starlet))
    immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, let));

  for (s7_pointer arglist = cdr(args); is_pair(arglist); arglist = cdr(arglist))
    {
      s7_pointer sym, val;
      const s7_pointer arg = car(arglist);
      if (is_symbol(arg))
	{
	  sym = (is_keyword(arg)) ? keyword_symbol(arg) : arg;
	  if (!is_pair(cdr(arglist)))
	    error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), arg, args));
	  if (is_constant_symbol(sc, sym))
	    wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, A_Non_Constant_Symbol_String);
	  arglist = cdr(arglist);
	  val = car(arglist);
	}
      else
	if (is_let(arg))
	  {
	    if ((arg != sc->rootlet) && (let != sc->starlet))   /* (varlet (inlet 'a 1) (rootlet)) is trouble */
	      {
		append_let(sc, let, arg, sc->varlet_symbol);
		if (has_let_set_fallback(arg)) set_has_let_set_fallback(let);
		if (has_let_ref_fallback(arg)) set_has_let_ref_fallback(let);
	      }
	    continue;
	  }
	else
	  if (is_pair(arg))
	    {
	      sym = car(arg);
	      if (!is_symbol(sym))
		wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, A_Symbol_String);
	      if (is_constant_symbol(sc, sym))
		wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, A_Non_Constant_Symbol_String);
	      val = cdr(arg);
	    }
	  else wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, wrap_string(sc, "a symbol, let, or cons", 22));

      if (let == sc->rootlet)
	{
	  s7_pointer gslot = global_slot(sym);
	  if (is_slot(gslot))
	    {
	      if (is_immutable(gslot)) /* (immutable! 'abs) (varlet (rootlet) 'abs 1) */
		immutable_object_error_nr(sc, set_elist_5(sc, wrap_string(sc, "~S is immutable in (varlet ~S '~S ~S)", 37), sym, car(args), arg, val));
	      slot_set_value_with_hook(global_slot(sym), val);
	    }
	  else s7_make_slot(sc, sc->rootlet, sym, val);
	}
      else
	{
	  check_let_fallback(sc, sym, let);
	  if (symbol_id(sym) >= let_id(let)) /* either a duplicate id, or a tricky case, TODO: check other such cases */
	    {
	      if ((symbol_id(sym) == let_id(let)) ||
		  (is_slot(symbol_to_local_slot(sc, sym, let))))
		error_nr(sc, sc->duplicate_identifier_symbol, set_elist_2(sc, wrap_string(sc, "varlet: duplicate identifier '~S", 32), sym));
	      /* we get here (with >) if the symbol we're checking was incremented during the evaluation of arguments:
	       *   (define (sym . a) (copy a)) (varlet (inlet 'a 1) 'a (sym))
	       */
	    }
	  add_slot_checked_with_id(sc, let, sym, val);
	}}
  return(let);
}


/* -------------------------------- cutlet -------------------------------- */
static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args)
{
  #define H_cutlet "(cutlet e symbol ...) removes symbols from the let e."
  #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, has_let_signature(sc), sc->is_symbol_symbol)

  s7_pointer let = car(args);
  s7_int the_un_id;
  if (let != sc->rootlet)
    {
      if_method_exists_return_value(sc, let, sc->cutlet_symbol, args);
      if (!is_let(let))
	{
	  s7_pointer new_let = find_let(sc, let);
	  if ((!is_let(new_let)) || (new_let == sc->rootlet))
	    find_let_error_nr(sc, sc->cutlet_symbol, let, new_let, 1, args);
	  let = new_let;
	}}
  if ((is_immutable_let(let)) || (let == sc->starlet))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->cutlet_symbol, let));

  /* besides removing the slot we have to make sure the symbol_id does not match, else
   *   let-ref and others will use the old slot!  So use the next (unused) id.
   *   (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b)
   */
  the_un_id = ++sc->let_number;

  for (s7_pointer syms = cdr(args); is_pair(syms); syms = cdr(syms))
    {
      s7_pointer sym = car(syms);
      if (!is_symbol(sym))
	wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, A_Symbol_String);
      if (is_keyword(sym))
	sym = keyword_symbol(sym);

      if (let == sc->rootlet)
	{
	  if (!is_slot(global_slot(sym)))
	    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym));
	  if (is_immutable(global_slot(sym)))
	    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->cutlet_symbol, sym));
	  symbol_set_id(sym, the_un_id);
	  set_global_value(sym, sc->undefined);
	  /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */
	}
      else
	{
	  s7_pointer slot;
	  if ((has_let_fallback(let)) &&
	      ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol)))
	    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym));
	  slot = let_slots(let);
	  if (is_slot_checked(slot))
	    {
	      if (slot_symbol(slot) == sym)
		{
		  if (is_immutable_slot(slot))
		    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->cutlet_symbol, sym));
		  let_set_slots(let, next_slot(let_slots(let)));
		  symbol_set_id(sym, the_un_id);
		}
	      else
		{
		  s7_pointer last_slot = slot;
		  for (slot = next_slot(let_slots(let)); is_slot_checked(slot); last_slot = slot, slot = next_slot(slot))
		    if (slot_symbol(slot) == sym)
		      {
			if (is_immutable_slot(slot))
			  immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->cutlet_symbol, sym));
			symbol_set_id(sym, the_un_id);
			slot_set_next(last_slot, next_slot(slot));
			break;
		      }}}}}
  return(let);
}


/* -------------------------------- sublet -------------------------------- */
static s7_pointer sublet_1(s7_scheme *sc, s7_pointer let, s7_pointer bindings, s7_pointer caller)
{
  const s7_pointer new_let = make_let(sc, let); /* make a let whose outlet is let */
  set_all_methods(new_let, let);

  if (!is_null(bindings))
    {
      s7_int argn = (caller == sc->sublet_symbol) ? 2 : 1; /* sublet passes in cdr(args) */
      sc->temp3 = new_let;
      for (s7_pointer slot = NULL, entries = bindings; is_pair(entries); entries = cdr(entries), argn++)
	{
	  s7_pointer entry = car(entries), sym, val;
	  switch (type(entry))
	    {
	    case T_SYMBOL:
	      sym = (is_keyword(entry)) ? keyword_symbol(entry) : entry;
	      if (!is_pair(cdr(entries)))
		error_nr(sc, sc->syntax_error_symbol,
			 set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, entry, bindings));
	      entries = cdr(entries);
	      argn++;
	      val = car(entries);
	      break;

	    case T_PAIR:  /* (cons sym val) */
	      sym = car(entry);
	      if (!is_symbol(sym))
		error_nr(sc, sc->wrong_type_arg_symbol,
			 set_elist_6(sc, wrap_string(sc, "~S ~:D argument, '~S, the variable name ~S is ~A but should be a symbol", 71),
				     caller, wrap_integer(sc, argn), entry, sym, object_type_name(sc, sym)));
	      if (is_keyword(sym))
		sym = keyword_symbol(sym);
	      val = cdr(entry);
	      break;

	    case T_LET: /* this is a let in the bindings list, not the first parameter to sublet */
	      if ((entry == sc->rootlet) || (new_let == sc->starlet)) continue;
	      append_let(sc, new_let, entry, caller);
	      if (is_slot_checked(let_slots(new_let))) /* make sure the end slot (slot) is correct */
		for (slot = let_slots(new_let); is_slot_checked(next_slot(slot)); slot = next_slot(slot)); /* slot can't be local -- see below */
	      continue;

	    default:
	      wrong_type_error_nr(sc, caller, argn, entry, A_Symbol_String);
	      /* (inlet "asdf" 1) (sublet (curlet) "asdf" 1) but (inlet (cons :pi 1)) or (sublet (curlet) 'a 1 (cons :pi 2)) */
	    }
	  if (is_constant_symbol(sc, sym))
	    {
	      if (is_symbol(entry))
		wrong_type_error_nr(sc, caller, argn - 1, sym, A_Non_Constant_Symbol_String);
	      else error_nr(sc, sc->wrong_type_arg_symbol,
			    set_elist_5(sc, wrap_string(sc, "~S ~:D argument, ~S, the symbol ~S is a constant", 48),
					caller, wrap_integer(sc, argn), entry, sym));
	    }
	  /* (inlet :pi 2) (sublet (curlet) :pi 1) -- entries is moved to cdr above! */
#if 0
	  if ((is_slot(global_slot(sym))) &&
	      (is_syntax_or_qq(global_value(sym))))
	    wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22));
	  /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */
	  /*   so s7_inlet (which calls sublet) differs from g_inlet? which is correct? */
	  /*   (define (f1) (with-let (sublet (curlet)) (inlet 'quasiquote 1))) (f1) */

#endif
	  /* here we know new_let is a let and is not rootlet */

	  if (let_id(new_let) == symbol_id(sym))
	    error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S: '~S", 31), caller, sym));
	  if (!slot)
	    slot = add_slot_checked_with_id(sc, new_let, sym, val);
	  else
	    {
	      /* if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc);*/ /* or maybe add add_slot_at_end_checked? */
	      slot = add_slot_checked_at_end(sc, let_id(new_let), slot, sym, val);
	      set_local(sym); /* ? */
	    }
	  check_let_fallback(sc, sym, new_let);
	}
      if ((s7_Debugging) && (sc->temp3 != new_let)) fprintf(stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, display(sc->temp3));
      sc->temp3 = sc->unused;
    }
  return(new_let);
}

s7_pointer s7_sublet(s7_scheme *sc, s7_pointer let, s7_pointer bindings) {return(sublet_1(sc, let, bindings, sc->sublet_symbol));}

static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args)
{
  #define H_sublet "(sublet let ...) makes a new let (an environment) within the environment 'let', initializing it with the bindings"
  #define Q_sublet Q_varlet

  s7_pointer let = car(args);
  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if ((!is_let(new_let)) || (new_let == sc->rootlet))  /* not rootlet because find_let -> rootlet means c_object|pointer did not have a let?? */
	find_let_error_nr(sc, sc->sublet_symbol, let, new_let, 1, args);
      let = new_let;
    }
  return(sublet_1(sc, let, cdr(args), sc->sublet_symbol));
}

static s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym = cadr(args), new_let;
  if_let_method_exists_return_value(sc, sc->curlet, sc->sublet_symbol, args); /* curlet is a let so... */
  new_let = inline_make_let_with_slot(sc, sc->curlet, sym, caddr(args));
  set_all_methods(new_let, sc->curlet);
  check_let_fallback(sc, sym, new_let);
  return(new_let);
}

static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr)
{
  if (num_args == 3)
    {
      s7_pointer args = cdr(expr);
      if ((is_pair(car(args))) && (caar(args) == sc->curlet_symbol) && (is_null(cdar(args))) &&
	  (is_quoted_symbol(sc, cadr(args))))
	return(sc->sublet_curlet);
    }
  return(func);
}


/* -------------------------------- inlet -------------------------------- */
s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args)
{
  #define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a symbol/value pair, \
to a new let, and returns the new let. (inlet :a 1 :b 2) or (inlet 'a 1 'b 2)"
  #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T)
  return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol));
}

#define g_inlet s7_inlet

static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args)
{
  /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols, no syntax, etc */
  const s7_pointer new_let = make_let(sc, sc->rootlet);
  const s7_int id = let_id(new_let);

  begin_temp(sc->temp6, new_let);
  for (s7_pointer x = args, last_slot = NULL; is_pair(x); x = cddr(x))
    {
      s7_pointer symbol = car(x);
      if (is_keyword(symbol))                 /* (inlet ':allow-other-keys 3) */
	symbol = keyword_symbol(symbol);
      if (is_constant_symbol(sc, symbol))     /* (inlet 'pi 1) */
	{
	  end_temp(sc->temp6);
	  wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, A_Non_Constant_Symbol_String);
	}
      if (id == symbol_id(symbol))
	error_nr(sc, sc->duplicate_identifier_symbol, set_elist_2(sc, wrap_string(sc, "duplicate identifier in inlet: '~S", 34), symbol));
      if (!last_slot)
	{
	  add_slot_unchecked(sc, new_let, symbol, cadr(x), id);
	  last_slot = let_slots(new_let);
	}
      else last_slot = add_slot_checked_at_end(sc, id, last_slot, symbol, cadr(x));
    }
  end_temp(sc->temp6);
  return(new_let);
}

static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
{
  if (!is_symbol(symbol))
    return(sublet_1(sc, sc->rootlet, set_plist_2(sc, symbol, value), sc->inlet_symbol));
  if (is_keyword(symbol))
    symbol = keyword_symbol(symbol);
  if (is_constant_symbol(sc, symbol))
    wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, A_Non_Constant_Symbol_String);
#if 0
  if ((is_defined_global(symbol)) &&
      (is_syntax_or_qq(global_value(symbol))))
    wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic symbol", 22));
#endif
  {
    s7_pointer new_let;
    new_cell(sc, new_let, T_LET | T_Safe_Procedure);
    begin_temp(sc->x, new_let);
    let_set_id(new_let, ++sc->let_number);
    let_set_outlet(new_let, sc->rootlet);
    let_set_slots(new_let, Slot_End);
    add_slot_unchecked(sc, new_let, symbol, value, let_id(new_let));
    end_temp(sc->x);
    return(new_let);
  }
}

static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) /* used in object->let, so duplicate symbol check is irrelevant */
{
  va_list ap;
  const s7_pointer new_let = make_let(sc, sc->rootlet);
  const s7_int id = let_id(new_let);
  s7_pointer last_slot = NULL;

  begin_temp(sc->x, new_let);
  va_start(ap, num_args);
  for (s7_int i = 0; i < num_args; i += 2)
    {
      s7_pointer symbol = T_Sym(va_arg(ap, s7_pointer));
      s7_pointer value = T_Ext(va_arg(ap, s7_pointer));
      if (id == symbol_id(symbol))
	error_nr(sc, sc->duplicate_identifier_symbol, set_elist_2(sc, wrap_string(sc, "duplicate identifier in inlet: '~S", 34), symbol));
      if (!last_slot)
	{
	  add_slot_unchecked(sc, new_let, symbol, value, id);
	  last_slot = let_slots(new_let);
	}
      else last_slot = add_slot_at_end(sc, id, last_slot, symbol, value);
    }
  va_end(ap);
  end_temp(sc->x);
  return(new_let);
}

static 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))));
}

static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args > 0) && ((args % 2) == 0))
    {
      begin_small_symbol_set(sc);
      for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p))
	{
	  s7_pointer sym;
	  if (is_symbol_and_keyword(car(p)))                  /* (inlet :if ...) */
	    sym = keyword_symbol(car(p));
	  else
	    {
	      if (!is_proper_quote(sc, car(p))) goto Give_Up; /* (inlet abs ...) */
	      sym = cadar(p);                                 /* looking for (inlet 'a ...) */
	      if (!is_symbol(sym)) goto Give_Up;              /* (inlet '(a . 3) ...) */
	      if (is_keyword(sym)) sym = keyword_symbol(sym); /* (inlet ':abs ...) */
	    }
	  if ((symbol_is_in_small_symbol_set(sc, sym)) ||     /* look for duplicates */
	      (is_possibly_constant(sym)) ||                  /* (inlet 'define-constant ...) or (inlet 'pi ...) */
	      (is_syntactic_symbol(sym))  ||                  /* (inlet 'if 3) */
	      ((is_slot(global_slot(sym))) &&
	       (is_syntax_or_qq(global_value(sym)))) ||       /* (inlet 'quasiquote 1) */
	      (sym == sc->let_ref_fallback_symbol) ||
	      (sym == sc->let_set_fallback_symbol))
	    goto Give_Up;
	  add_symbol_to_small_symbol_set(sc, sym);
	}
      end_small_symbol_set(sc);
      return(sc->simple_inlet);
    Give_Up:
      end_small_symbol_set(sc);
      /* this error can haopen in a case like (define (f) (display (inlet 'a (* 2 3) 'b 2 'c (+ 2 3) 'd 3 'a 2))) where we catch a call
       *   and ignore the error (from g_simple_inlet), then call it again.  Maybe we should just let this happen.
       *   Or maybe raise an error here?
       */
    }
  return(func);
}


/* -------------------------------- let->list -------------------------------- */
static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list);

static s7_pointer abbreviate_let(s7_scheme *sc, s7_pointer val)
{
  if (is_let(val))
    return(make_symbol(sc, "<inlet...>", 11));
  return(val);
}

s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let)
{
  if (let == sc->rootlet)
    {
      begin_temp(sc->temp6, sc->nil);
      for (s7_pointer lib = global_value(sc->libraries_symbol); is_pair(lib); lib = cdr(lib))
	sc->temp6 = cons(sc, caar(lib), sc->temp6);
      sc->temp6 = cons(sc, cons(sc, sc->libraries_symbol, sc->temp6), sc->nil);
      for (s7_pointer slot = sc->rootlet_slots; is_slot_checked(slot); slot = next_slot(slot))
	if (slot_symbol(slot) != sc->libraries_symbol)
	  sc->temp6 = cons_unchecked(sc, cons(sc, slot_symbol(slot), abbreviate_let(sc, slot_value(slot))), sc->temp6);
      {
	s7_pointer result = proper_list_reverse_in_place(sc, sc->temp6);
	end_temp(sc->temp6);
	return(result);
      }}
  else
    {
      s7_pointer iter, func;
      s7_int gc_loc = -1;
      /* need to check make-iterator method before dropping into let->list */
      sc->temp3 = sc->w;
      sc->w = sc->nil;

      if ((has_active_methods(sc, let)) &&
	  ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined))
	iter = s7_apply_function(sc, func, set_plist_1(sc, let));
      else
	if (let == sc->starlet) /* (let->list *s7*) via starlet_make_iterator */
	  {
	    iter = s7_make_iterator(sc, let);
	    gc_loc = gc_protect_1(sc, iter);
	  }
	else iter = sc->nil;

      if (is_null(iter))
	for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
	  sc->w = cons_unchecked(sc, cons(sc, slot_symbol(slot), slot_value(slot)), sc->w);
      else
	/* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */
	while (true)
	  {
	    s7_pointer val = s7_iterate(sc, iter);
	    if (iterator_is_at_end(iter)) break;
	    sc->w = cons(sc, val, sc->w);
	  }
      sc->w = proper_list_reverse_in_place(sc, sc->w);
      if (gc_loc != -1)
	s7_gc_unprotect_at(sc, gc_loc);
      {
	s7_pointer result = sc->w;
	sc->w = sc->temp3;
	sc->temp3 = sc->unused;
	return(result);
      }}
}

#if !With_Pure_s7
static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_let_to_list "(let->list let) returns let's bindings as a list of cons's: '(symbol . value)."
  #define Q_let_to_list s7_make_signature(sc, 2, sc->is_list_symbol, has_let_signature(sc))

  s7_pointer let = car(args);
  if_method_exists_return_value(sc, let, sc->let_to_list_symbol, args);
  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if ((!is_let(new_let)) || (new_let == sc->rootlet))
	find_let_error_nr(sc, sc->let_to_list_symbol, let, new_let, 1, args);
      /* this is not (let->list (rootlet)) but (say) (let->list func) which defaults in find_let to rootlet */
      let = new_let;
    }
  return(s7_let_to_list(sc, let));
}
/* *s7* in gdb: p display(s7_let_to_list(sc, sc->starlet)) */
#endif


/* -------------------------------- let-ref -------------------------------- */
static s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
{
  s7_pointer result;
  const s7_pointer val = find_method(sc, let, sc->let_ref_fallback_symbol);
  /* (let ((x #f)) (let begin ((x 1234)) (begin 1) 2)) -> stack overflow eventually, but should we try to catch it? */
  if (!is_applicable(val)) return(val);
  push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
  result = s7_apply_function(sc, val, set_qlist_2(sc, let, symbol));
  unstack_gc_protect(sc);
  sc->code = T_Pos(stack_end_code(sc)); /* can be #<unused> */
  sc->value = T_Ext(stack_end_args(sc));
  return(result);
}

static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  s7_pointer result;
  push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
  result = s7_apply_function(sc, find_method(sc, let, sc->let_set_fallback_symbol), set_qlist_3(sc, let, symbol, value));
  unstack_gc_protect(sc);
  sc->code = T_Pos(stack_end_code(sc));
  sc->value = T_Ext(stack_end_args(sc));
  return(result);
}

static s7_pointer g_unlet_disabled(s7_scheme *sc, s7_pointer unused_args) {return(sc->unlet_disabled);}
/* we need a self-id here for let_ref, but it needs to be a real s7_cell, not g_unlet_disabled itself, hence sc->unlet_disabled */

static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
{
  /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */
  if (!is_let(let))
    {
      s7_pointer new_let;
      if (let == sc->unlet_disabled) return(initial_value(symbol));
      new_let = find_let(sc, let);
      if ((!is_let(new_let)) || (new_let == sc->rootlet))
	find_let_error_nr(sc, sc->let_ref_symbol, let, new_let, 1, set_mlist_2(sc, let, symbol));
      let = new_let;
    }
  if (!is_symbol(symbol))
    {
      if ((let != sc->rootlet) && (has_let_ref_fallback(let))) /* let-ref|set-fallback refer to (explicit) let-ref in various forms, not the method lookup process */
	return(call_let_ref_fallback(sc, let, symbol));
      wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, A_Symbol_String);
    }
  /* a let-ref method is almost impossible to write without creating an infinite loop:
   *   any reference to the let will probably call let-ref somewhere, calling us again, and looping.
   *   This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist.
   *   After much wasted debugging, I decided to make let-ref and let-set! immutable.
   *   What about other let-as-first-arg funcs?
   */

  if (let_id(let) == symbol_id(symbol))
    return(local_value(symbol)); /* this has to follow the rootlet check(?) */

  if (is_keyword(symbol))
    symbol = keyword_symbol(symbol);
  if (let == sc->rootlet)
    return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined);

  for (s7_pointer e = let; e; e = let_outlet(e))
    for (s7_pointer slot = let_slots(e); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	return(slot_value(slot));

  if (is_openlet(let))
    {
      /* If a let is a mock-hash-table (for example), implicit indexing of the hash-table collides with the same thing for the let (field names
       *   versus keys), and we can't just try again here because that makes it too easy to get into infinite recursion.  So, 'let-ref-fallback...
       */
      if (has_let_ref_fallback(let))
	return(call_let_ref_fallback(sc, let, symbol));
    }
  return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)), but also confusingly: ((inlet 'a 1) :if) -> if */
}

s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) {return(let_ref(sc, let, symbol));}

static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let"
  #define Q_let_ref s7_make_signature(sc, 3, sc->T, has_let_signature(sc), sc->is_symbol_symbol)
  if (!is_pair(cdr(args)))
    error_nr(sc, sc->syntax_error_symbol,
	     set_elist_2(sc, wrap_string(sc, "let-ref: symbol missing: ~S", 27), set_ulist_1(sc, sc->let_ref_symbol, args)));
  return(let_ref(sc, car(args), cadr(args)));
}

static s7_pointer slot_in_let(s7_scheme *sc, s7_pointer let, const s7_pointer sym)
{
  for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
    if (slot_symbol(slot) == sym)
      return(slot);
  return(sc->undefined);
}

static s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer let, s7_pointer sym)
{
  if (let_id(let) == symbol_id(sym))
    return(local_value(sym)); /* see add in tlet! */
  if (let == sc->rootlet) /* op_implicit_let_ref_c can pass rootlet */
    return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
  for (s7_pointer e = let; e; e = let_outlet(e))
    for (s7_pointer slot = let_slots(e); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == sym)
	return(slot_value(slot));
  if (has_let_ref_fallback(let))
    return(call_let_ref_fallback(sc, let, sym));
  return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
}

static inline s7_pointer g_cdr_let_ref(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer let = car(args), sym = cadr(args);
  if (!is_let(let))
    wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, A_Let_String);
  if (let_id(let) == symbol_id(sym))
    return(local_value(sym));
  if (let == sc->rootlet)
    return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
  for (s7_pointer slot = let_slots(let); is_slot_checked(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 starlet(s7_scheme *sc, s7_int choice);
static s7_pointer g_starlet_ref(s7_scheme *sc, s7_pointer args) {return(starlet(sc, starlet_symbol_id(cadr(args))));}
static s7_pointer g_curlet_ref(s7_scheme *sc, s7_pointer args) {return(lookup(sc, cadr(args)));}
static s7_pointer g_unlet_ref(s7_scheme *unused_sc, s7_pointer args) {return(initial_value(cadr(args)));}

static s7_pointer g_rootlet_ref(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym = cadr(args);
  return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
}

static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
  if ((is_quoted_symbol(sc, arg2)) && (!is_keyword(cadr(arg2))))
    {
      if (is_pair(arg1))
	{
	  if ((optimize_op(expr) == HOP_SAFE_C_opSq_C) && (car(arg1) == sc->cdr_symbol))
	    {
	      set_opt3_sym(cdr(expr), cadr(arg2));
	      return(sc->cdr_let_ref);
	    }
	  if (car(arg1) == sc->rootlet_symbol) return(sc->rootlet_ref);
	  if (car(arg1) == sc->curlet_symbol) return(sc->curlet_ref);
	  if (car(arg1) == sc->unlet_symbol)
	    {
	      set_fn_direct(arg1, g_unlet_disabled);
	      return(sc->unlet_ref);
	    }}
      if (arg1 == sc->starlet_symbol) return(sc->starlet_ref); /* should *curlet* be added? */
    }
  return(func);
}

static bool op_implicit_let_ref_c(s7_scheme *sc)
{
  s7_pointer let = lookup_checked(sc, car(sc->code));
  if (!is_let(let)) {sc->last_function = let; return(false);}
  sc->value = let_ref_p_pp(sc, let, opt3_con(sc->code));
  return(true);
}

static bool op_implicit_let_ref_a(s7_scheme *sc)
{
  s7_pointer sym, let = lookup_checked(sc, car(sc->code));
  if (!is_let(let)) {sc->last_function = let; return(false);}
  sym = fx_call(sc, cdr(sc->code));
  if (is_symbol(sym))
    sc->value = let_ref_p_pp(sc, let, (is_keyword(sym)) ? keyword_symbol(sym) : sym);
  else sc->value = let_ref(sc, let, sym);
  return(true);
}

static s7_pointer fx_implicit_let_ref_c(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer let = lookup_checked(sc, car(arg)); /* the let */
  if (!is_let(let))
    return(s7_apply_function(sc, let, set_mlist_1(sc, opt3_con(arg))));
  return(let_ref_p_pp(sc, let, opt3_con(arg)));
}


/* -------------------------------- let-set! -------------------------------- */
static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  if (is_keyword(symbol))
    symbol = keyword_symbol(symbol);

  if (let == sc->rootlet)
    {
      s7_pointer slot;
      if (is_constant_symbol(sc, symbol))  /* (let-set! (rootlet) 'pi #f) */
	wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, A_Non_Constant_Symbol_String);
      /* it would be nice if safety>0 to add an error check for bad arity if a built-in method is set (set! (lt 'write) hash-table-set!),
       *   built_in being (initial_value_is_defined(sc, sym)), but this function is called a ton, and this error can't easily be
       *   checked by the optimizer (we see the names, but not the values, so bad arity check requires assumptions about those values).
       */
      slot = global_slot(symbol);
      if (!is_slot(slot))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let));
#if 0
      if (is_syntax(slot_value(slot)))
	wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22));
#endif
      if (is_immutable(slot))
	immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (rootlet)", 28), symbol)); /* also (set! (with-let...)...) */
      symbol_increment_ctr(symbol);
      slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value);
      return(slot_value(slot));
    }
  if (is_unlet(let))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), symbol));
  if (let_id(let) == symbol_id(symbol))
   {
     s7_pointer slot = local_slot(symbol);
     if (is_slot(slot))
       {
	 symbol_increment_ctr(symbol);
	 return(checked_slot_set_value(sc, slot, value));
       }}
  for (s7_pointer e = let; e; e = let_outlet(e))
    for (s7_pointer slot = let_slots(e); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	{
	  symbol_increment_ctr(symbol);
	  return(checked_slot_set_value(sc, slot, value));
	}
  if (!has_let_set_fallback(let))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let));
  /* not sure about this -- what's the most useful choice? */
  return(call_let_set_fallback(sc, let, symbol, value));
}

static s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if (!is_let(new_let))
	find_let_error_nr(sc, sc->let_set_symbol, let, new_let, 1, set_plist_3(sc, let, symbol, value));
      let = new_let;
    }
  if (!is_symbol(symbol))
    {
      if ((let != sc->rootlet) && (has_let_set_fallback(let)))
	return(call_let_set_fallback(sc, let, symbol, value));
      wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, A_Symbol_String);
    }
  /* currently let-set! is immutable, so we don't have to check for a let-set! method (so let_set! is always global) */
  return(let_set_1(sc, let, symbol, value));
}

s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set_2(sc, let, symbol, value));}

static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args)
{
  /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */
  #define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val"
  #define Q_let_set s7_make_signature(sc, 4, sc->T, has_let_signature(sc), sc->is_symbol_symbol, sc->T)

  if (!is_pair(cdr(args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) (catch #t f (lambda args #f)) (f)) */
    error_nr(sc, sc->wrong_number_of_args_symbol,
	     set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code));

  return(let_set_2(sc, car(args), cadr(args), caddr(args)));
}

static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer let, s7_pointer sym, s7_pointer val)
{
  if (!is_symbol(sym))
    wrong_type_error_nr(sc, sc->let_set_symbol, 2, sym, A_Symbol_String);
  return(let_set_1(sc, let, sym, val));
}

static s7_pointer g_cdr_let_set(s7_scheme *sc, s7_pointer args)
{
  s7_pointer let = car(args);
  const s7_pointer sym = cadr(args), val = caddr(args);
  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if (!is_let(new_let))
	find_let_error_nr(sc, sc->let_set_symbol, let, new_let, 1, args);
      let = new_let;
    }
  if (let != sc->rootlet)
    {
      for (s7_pointer e = let; e; e = let_outlet(e))
	for (s7_pointer slot = let_slots(e); is_slot_checked(slot); slot = next_slot(slot))
	  if (slot_symbol(slot) == sym)
	    {
	      slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val);
	      return(slot_value(slot));
	    }
      if ((let != sc->rootlet) && (has_let_set_fallback(let)))
	return(call_let_set_fallback(sc, let, sym, val));
    }
  {
    s7_pointer slot = global_slot(sym);
    if (!is_slot(slot))
      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), sym, let));
    slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val);
    return(slot_value(slot));
  }
}

static s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val);

static s7_pointer g_starlet_set(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym = cadr(args);
  if (!is_symbol(sym)) /* (let () (define (func) (let-set! *s7* '(1 . 2) (hash-table))) (func) (func)) */
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_3(sc, wrap_string(sc, "(let-set! *s7* ~A ...) second argument is ~A but should be a symbol", 67),
			 sym, object_type_name(sc, sym)));
  if (is_keyword(sym))
    sym = keyword_symbol(sym);
  if (starlet_symbol_id(sym) == sl_No_Field)
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym));
  return(starlet_set_1(sc, sym, caddr(args)));
}

static s7_pointer g_unlet_set(s7_scheme *sc, s7_pointer args)
{
  immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), cadr(args)));
  return(sc->F);
}

static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  if (optimize_op(expr) == HOP_SAFE_C_opSq_CS)
    {
      const s7_pointer arg2 = caddr(expr), arg3 = cadddr(expr);
      if ((car(arg1) == sc->cdr_symbol) &&
	  (is_quoted_symbol(sc, arg2)) &&
	  (!is_possibly_constant(cadr(arg2))) && /* assumes T_Sym */
	  (!is_possibly_constant(arg3)))
	return(sc->cdr_let_set);
      if (car(arg1) == sc->unlet_symbol)
	{
	  set_fn_direct(arg1, g_unlet_disabled);
	  return(sc->unlet_set);
	}}
  if (arg1 == sc->starlet_symbol) return(sc->starlet_set);
  return(func);
}


static s7_pointer reverse_slots(s7_pointer let_slots)
{
  s7_pointer slot = let_slots, result = Slot_End;
  while (is_slot_checked(slot))
    {
      s7_pointer nextslot = next_slot(slot);
      slot_set_next(slot, result);
      result = slot;
      slot = nextslot;
    }
  return(result);
}

static s7_pointer let_copy(s7_scheme *sc, s7_pointer let)
{
  s7_pointer new_let;
  if (T_Let(let) == sc->rootlet)   /* (copy (rootlet)) or (copy (funclet abs)) etc */
    return(sc->rootlet);
  /* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object!
   *   So if it is present, we get it here, and then there's almost surely trouble.
   */
  new_let = make_let(sc, let_outlet(let));
  set_all_methods(new_let, let);
  begin_temp(sc->x, new_let);
  if (is_slot_checked(let_slots(let)))
    {
      const s7_int id = let_id(new_let);
      for (s7_pointer last_slot = NULL, slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
	{
	  s7_pointer new_slot;
	  if (id != symbol_id(slot_symbol(slot)))
	    /* if ==, the symbol is already in new_let, so just ignore this duplicate.  This might be a sign that new_let has a
	     *   duplicated identifier, but it can also happen innocently: (copy (inlet 'a 1) (inlet 'a 1)) or some facsimile thereof
	     */
	    {
	      new_cell(sc, new_slot, T_SLOT);
	      slot_set_symbol_and_value(new_slot, slot_symbol(slot), slot_value(slot));
	      if (symbol_id(slot_symbol(new_slot)) != id) /* keep shadowing intact */
		symbol_set_local_slot(slot_symbol(slot), id, new_slot);
	      if (slot_has_setter(slot))
		{
		  slot_set_setter(new_slot, slot_setter(slot));
		  set_slot_has_setter(new_slot);
		}
	      if (last_slot)
		slot_set_next(last_slot, new_slot);
	      else let_set_slots(new_let, new_slot);
	      slot_set_next(new_slot, Slot_End);        /* in case GC runs during this loop */
	      last_slot = new_slot;
	    }}}
  end_temp(sc->x);
  return(new_let);
}


/* -------------------------------- rootlet -------------------------------- */
static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer unused)
{
  #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)."
  #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol)
  return(sc->rootlet);
}

s7_pointer s7_rootlet(s7_scheme *sc) {return(sc->rootlet);}

/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet,
 *   but when actually loaded, everything can be shunted into a separate namespace (*motif* for example).
 */
s7_pointer s7_shadow_rootlet(s7_scheme *sc) {return(sc->shadow_rootlet);}

s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let)
{
  s7_pointer old_let = sc->shadow_rootlet;
  sc->shadow_rootlet = let;
  return(old_let); /* like s7_set_curlet below */
}


/* -------------------------------- curlet -------------------------------- */
s7_pointer s7_curlet(s7_scheme *sc) /* see also fx_curlet */
{
  sc->capture_let_counter++;
  return(sc->curlet);
}

static s7_pointer g_curlet(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_curlet "(curlet) returns the current definitions (symbol bindings)"
  #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol)
  sc->capture_let_counter++;
  return(sc->curlet);
}

static void update_symbol_ids(s7_scheme *sc, s7_pointer let)
{
  for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
    {
      s7_pointer sym = slot_symbol(slot);
      if (symbol_id(sym) != sc->let_number)
	symbol_set_local_slot_unincremented(sym, sc->let_number, slot);
    }
}

s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer let)
{
  const s7_pointer old_let = sc->curlet;
  if (is_let(let))
    {
      set_curlet(sc, let);
      if (let_id(let) > 0)
	{
	  let_set_id(let, ++sc->let_number);
	  update_symbol_ids(sc, let);
	}}
  return(old_let);
}


/* -------------------------------- outlet -------------------------------- */
s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) {if (let_outlet(let)) return(let_outlet(let)); return(sc->rootlet);}

static s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let)
{
  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if (!is_let(new_let))
	find_let_error_nr(sc, sc->outlet_symbol, let, new_let, 1, set_mlist_1(sc, let));
      let = new_let;
    }
  if (has_active_methods(sc, let))
    {
      s7_pointer func = find_method(sc, let, sc->outlet_symbol);
      if (func != sc->undefined)
	return(s7_apply_function(sc, func, set_mlist_1(sc, let)));
    }
  return((let == sc->rootlet) ? sc->rootlet : let_outlet(let)); /* rootlet check is needed(!) */
}

static s7_pointer g_outlet_unlet(s7_scheme *sc, s7_pointer unused_args) {return(sc->curlet);}

static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args)
{
  #define H_outlet "(outlet let) is the environment that contains let."
  #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, has_let_signature(sc))
  return(outlet_p_p(sc, car(args)));
}

static s7_pointer outlet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr)
{
  if ((num_args == 1) && (is_pair(cadr(expr))) && (caadr(expr) == sc->unlet_symbol))
    {
      set_fn_direct(cadr(expr), g_unlet_disabled);
      return(sc->outlet_unlet);
    }
  return(func);
}

static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args)
{
  /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */
  s7_pointer let = car(args), new_outer;

  if (!is_let(let))
    {
      s7_pointer new_let = find_let(sc, let);
      if (!is_let(new_let))
	find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), let, new_let, 1, args);
      let = new_let;
    }
  if (let == sc->starlet)
    error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't set! (outlet *s7*)", 24)));
  if (is_immutable_let(let))
    immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "can't (set! (outlet ~S) ~S), ~S is immutable", 44), let, cadr(args), let));
  new_outer = cadr(args);
  if (!is_let(new_outer))
    {
      s7_pointer new_let = find_let(sc, new_outer);
      if (!is_let(new_let))
	find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), new_outer, new_let, 2, args);
      new_outer = new_let;
    }
  if (let != sc->rootlet)
    {
      /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */
      for (s7_pointer new_let = new_outer; new_let; new_let = let_outlet(new_let))
	if (let == new_let)
	  error_nr(sc, make_symbol(sc, "cyclic-let", 10),
		   set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let));
      let_set_outlet(let, new_outer);
    }
  return(new_outer);
}

/* -------------------------------- symbol lookup -------------------------------- */
static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer 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));
    }
  for (; let; let = let_outlet(let))
    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	return(slot_value(slot));

  if (is_slot(global_slot(symbol)))
    return(global_value(symbol));
#if WITH_GCC && ((!__cplusplus) || (!__clang__))
  return(NULL); /* much faster than various alternatives */
#else
  return(unbound_variable(sc, symbol)); /* only use of sc */
#endif
}

#if WITH_GCC && s7_Debugging
static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol)
#else
static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */
#endif
{
  return(inline_lookup_from(sc, symbol, sc->curlet));
}

static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer 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_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	return(T_Slt(slot));
  return(T_Sld(global_slot(symbol))); /* #<undefined> when (define x ...) and x is not yet defined */
}

s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));}

static s7_pointer lookup_slot_with_let(s7_scheme *sc, s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));}

s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));}

s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) {slot_set_value(slot, value); return(value);}

void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {set_real(slot_value(slot), value);}

static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let)
{ /* assumes e is a let, only let is searched */
  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_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	return(slot);
  return(sc->undefined);
}

s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym)
{
  s7_pointer slot = s7_slot(sc, sym);
  return((is_slot(slot)) ? slot_value(slot) : sc->undefined);
}

s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let)
{
  if (let_id(let) == symbol_id(sym))
    return(local_value(sym));
  if (let_id(let) > symbol_id(sym))
    {
      do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym));
      if (let_id(let) == symbol_id(sym))
	return(local_value(sym));
    }
  for (; let; let = let_outlet(let))
    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == sym)
	return(slot_value(slot));

  /* maybe let is local but sym is global but previously shadowed */
  if (is_slot(global_slot(sym)))
    return(global_value(sym));

  /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> #<undefined> not 1 */
  return(sc->undefined); /* 29-Nov-17 */
}


/* -------------------------------- symbol->value -------------------------------- */
#define lookup_global(Sc, Sym) ((is_defined_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym))

static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \
symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32"
  #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, has_let_signature(sc))

  const s7_pointer sym = car(args);
  if (!is_symbol(sym))
    return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1));
  if (is_keyword(sym))
    {
      if ((is_pair(cdr(args))) && (!is_let(cadr(args))) && (!is_let(find_let(sc, cadr(args)))))
	wrong_type_error_nr(sc, sc->symbol_to_value_symbol, 2, cadr(args), sc->type_names[T_LET]);
      return(sym);
    }
  if (is_pair(cdr(args)))
    {
      s7_pointer local_let = cadr(args);
      if (!is_let(local_let))
	{
	  local_let = find_let(sc, local_let);
	  if (!is_let(local_let))
	    return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, A_Let_String, 2)); /* not local_let */
	}
      if (local_let == sc->rootlet) return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
      if (is_unlet(local_let)) return(initial_value(sym));
      if (local_let == sc->starlet) return(starlet(sc, starlet_symbol_id(sym)));
      return(s7_symbol_local_value(sc, sym, local_let));
    }
  if (is_defined_global(sym))
    return(global_value(sym));
  return(s7_symbol_value(sc, sym));
}

s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  s7_pointer slot = s7_slot(sc, sym);   /* if immutable should this return an error? */
  if (is_slot(slot))
    slot_set_value(slot, val); /* with_hook? */
  return(val);
}

static s7_pointer g_sv_unlet_ref(s7_scheme *unused_sc, s7_pointer args) {return(initial_value(car(args)));}

static s7_pointer symbol_to_value_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  s7_pointer arg1 = cadr(expr), arg2 = (is_pair(cddr(expr))) ? caddr(expr) : sc->F;
  if ((is_quoted_symbol(sc, arg1)) && (!is_keyword(cadr(arg1))) && (is_pair(arg2)) && (car(arg2) == sc->unlet_symbol)) /* old-style (obsolete) unlet as third arg(!) */
    {
      set_fn_direct(arg2, g_unlet_disabled);
      return(sc->sv_unlet_ref);
    }
  return(func);
}


/* -------------------------------- symbol->dynamic-value -------------------------------- */
static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer let, s7_pointer sym, s7_int *id)
{
  for (; let_id(let) > symbol_id(sym); let = let_outlet(let));
  if (let_id(let) == symbol_id(sym))
    {
      (*id) = let_id(let);
      return(local_value(sym));
    }
  for (; (let) && (let_id(let) > (*id)); let = let_outlet(let))
    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == sym)
	{
	  (*id) = let_id(let);
	  return(slot_value(slot));
	}
  return(sc->unused);
}

static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym"
  #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)

  /* symbol->dynamic-value assumes the "true" curlet is saved on the stack if a function is called that
   *   calls the code with symbol->dynamic-value.  But the function might simply reset curlet to its own, then return,
   *   as in op_safe_thunk_a, leaving the incoming curlet inaccessible.  If we push op_gc_protect+let=incoming curlet,
   *   everything is ok.
   *   (let ((x 32))
   *     (define (gx) (symbol->dynamic-value 'x))
   *     (define (ok?) (format #t "gx -> ~S~%" (gx)))
   *     (let ((x 12))
   *       (ok? gx) ; 32, but 12 if we include the line below (since x=12 let is on the stack)
   *       ;(newline)
   *       ))
   */
  const s7_pointer sym = car(args);
  s7_pointer val;
  s7_int top_id = -1;

  if (!is_symbol(sym))
    return(method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, sc->type_names[T_SYMBOL], 1));

  if (is_defined_global(sym))
    return(global_value(sym));

  if (let_id(sc->curlet) == symbol_id(sym))
    return(local_value(sym));

  val = find_dynamic_value(sc, sc->curlet, sym, &top_id);
  if (top_id == symbol_id(sym))
    return(val);

  for (s7_int op_loc = stack_top(sc) - 1; op_loc > 0; op_loc -= 4)
    if (is_let_unchecked(stack_let(sc->stack, op_loc))) /* OP_GC_PROTECT let slot can be anything (even free) */
      {
	s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, op_loc), sym, &top_id);
	if (cur_val != sc->unused)
	  val = cur_val;
	if (top_id == symbol_id(sym))
	  return(val);
      }
  /* what about call/cc stacks? */
  return((val == sc->unused) ? s7_symbol_value(sc, sym) : val);
}

static bool direct_memq(const s7_pointer symbol, s7_pointer symbols)
{
  for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms))
    if (car(syms) == symbol)
      return(true);
  return(false);
}

static bool direct_translucent_member(const s7_pointer symbol, s7_pointer symbols)
{
  for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms))
    {
      if (car(syms) == symbol) return(true);
      if ((is_pair(car(syms))) && (is_translucent(caar(syms))) && (is_pair(cdar(syms))) && (cadar(syms) == symbol)) return(true);
    }
  return(false);
}

static bool direct_assq(const s7_pointer symbol, s7_pointer symbols) /* used only below in do_symbol_is_safe */
{
  for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms))
    if (caar(syms) == symbol)
      return(true);
  return(false);
}

static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list)
{
  return((is_slot(global_slot(sym))) ||
	 (direct_assq(sym, var_list)) ||
	 (is_bound_symbol(sc, sym)));
}

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 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 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 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 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 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));
    }
}

static s7_pointer add_trace(s7_scheme *sc, s7_pointer code)
{
  if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol))
    return(code);
  return(cons_unchecked(sc, list_2(sc, sc->trace_in_symbol, list_1(sc, sc->curlet_symbol)), code));
}

static s7_pointer add_profile(s7_scheme *sc, s7_pointer code)
{
  s7_pointer result;
  if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol))
    return(code);
  result = cons_unchecked(sc, list_3(sc, sc->profile_in_symbol, make_integer_unchecked(sc, sc->profile_position), list_1(sc, sc->curlet_symbol)), code);
  sc->profile_position++;
  set_unsafe_optimize_op(car(result), OP_PROFILE_IN);
  return(result);
}

static bool tree_has_definer(s7_scheme *sc, s7_pointer tree)
{
  for (s7_pointer p = tree; is_pair(p); p = cdr(p))
    if (tree_has_definer(sc, car(p)))
      return(true);
  return((is_symbol(tree)) && (is_definer(tree)));
}

static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op)
{
  switch (op)
    {
    case OP_DEFINE_MACRO:          return(sc->define_macro_symbol);
    case OP_DEFINE_MACRO_STAR:     return(sc->define_macro_star_symbol);
    case OP_DEFINE_BACRO:          return(sc->define_bacro_symbol);
    case OP_DEFINE_BACRO_STAR:     return(sc->define_bacro_star_symbol);
    case OP_DEFINE_EXPANSION:      return(sc->define_expansion_symbol);
    case OP_DEFINE_EXPANSION_STAR: return(sc->define_expansion_star_symbol);
    case OP_MACRO:                 return(sc->macro_symbol);
    case OP_MACRO_STAR:            return(sc->macro_star_symbol);
    case OP_BACRO:                 return(sc->bacro_symbol);
    case OP_BACRO_STAR:            return(sc->bacro_star_symbol);
    case OP_EXPANSION:             return(sc->expansion_symbol);
    case OP_EXPANSION_STAR:        return(sc->expansion_star_symbol);
    default:
#if s7_Debugging
      fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]);
#endif
      break;
    }
  return(NULL);
}

typedef enum {Opt_Bad, Opt_Ok, Opt_Oops} opt_t;
static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer let_or_list);

static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named)
{
  s7_pointer mac, body, mac_name = NULL;
  s7_uint typ;
  if (Eval_Print) 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_EXPANSION:
    case OP_DEFINE_EXPANSION:        typ = T_MACRO | T_Expansion;      break; /* ??? local expansions were just normal macros (checked curlet == rootlet) */
    case OP_EXPANSION_STAR:
    case OP_DEFINE_EXPANSION_STAR:   typ = T_MACRO_STAR | T_Expansion; break;
    default:
#if s7_Debugging
      fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]);
#endif
      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)
    {
      mac_name = caar(sc->code);
      if ((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR) || (op == OP_EXPANSION) || (op == OP_EXPANSION_STAR))
	set_full_type(mac_name, T_Expansion | T_SYMBOL | (full_type(mac_name) & T_Unheap)); /* T_Unheap because T_SYMBOL? not direct for gensyms? */
      /* symbol? macro name has already been checked, find name in let, and define it */
      {
	const s7_pointer mac_slot = symbol_to_local_slot(sc, mac_name, sc->curlet);
	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_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 */
  return(mac);
}

static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity)
{
  s7_pointer new_func;
  new_cell_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 s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) /* inline else 91 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)
    {
      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; \
                                   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)));
}

static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree)
{
#if WITH_GCC
  #define Copy_Tree(P) ({s7_pointer _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)));
}


/* -------------------------------- tree-cyclic? -------------------------------- */
#define Tree_Not_Cyclic 0
#define Tree_Cyclic 1
#define Tree_Has_Pairs 2

static int32_t tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree)
{
  s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */
  bool has_pairs = false;
  while (true)
    {
      if (tree_is_collected(fast)) return(Tree_Cyclic);
      if ((!has_pairs) && (is_unquoted_pair(sc, car(fast)))) has_pairs = true;
      fast = cdr(fast);
      if (!is_pair(fast)) return((has_pairs) ? Tree_Has_Pairs : Tree_Not_Cyclic);

      if (tree_is_collected(fast)) return(Tree_Cyclic);
      if ((!has_pairs) && (is_unquoted_pair(sc, car(fast)))) has_pairs = true;
      fast = cdr(fast);
      if (!is_pair(fast)) return((has_pairs) ? Tree_Has_Pairs : Tree_Not_Cyclic);

      slow = cdr(slow);
      if (fast == slow) return(Tree_Cyclic);
    }
  return(Tree_Has_Pairs); /* not reached */
}

/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */

static bool tree_is_cyclic_1(s7_scheme *sc, s7_pointer tree)
{
  for (s7_pointer p = tree; is_pair(p); p = cdr(p))
    {
      tree_set_collected(p);
      if (sc->tree_pointers_top == sc->tree_pointers_size)
	{
	  if (sc->tree_pointers_size == 0)
	    {
	      sc->tree_pointers_size = 8;
	      sc->tree_pointers = (s7_pointer *)Malloc(sc->tree_pointers_size * sizeof(s7_pointer));
	    }
	  else
	    {
	      sc->tree_pointers_size *= 2;
	      sc->tree_pointers = (s7_pointer *)Realloc(sc->tree_pointers, sc->tree_pointers_size * sizeof(s7_pointer));
	    }}
      sc->tree_pointers[sc->tree_pointers_top++] = p;
      if (is_unquoted_pair(sc, car(p)))
	{
	  const int32_t old_top = sc->tree_pointers_top;
	  const int32_t result = tree_is_cyclic_or_has_pairs(sc, car(p));
	  if ((result == Tree_Cyclic) || (tree_is_cyclic_1(sc, car(p))))
	    return(true);
	  for (int32_t i = old_top; i < sc->tree_pointers_top; i++)
	    tree_clear_collected(sc->tree_pointers[i]);
	  sc->tree_pointers_top = old_top;
	}}
  return(false);
}

static bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree)
{
  int32_t result;
  if (!is_pair(tree)) return(false);
  result = tree_is_cyclic_or_has_pairs(sc, tree);
  if (result == Tree_Not_Cyclic) return(false);
  if (result == Tree_Cyclic) return(true);
  result = tree_is_cyclic_1(sc, tree);
  for (int32_t i = 0; i < sc->tree_pointers_top; i++)
    tree_clear_collected(sc->tree_pointers[i]);
  sc->tree_pointers_top = 0;
  return(result); /* this means Tree_Has_Pairs -> true? */
}

static s7_pointer g_tree_is_cyclic(s7_scheme *sc, s7_pointer args)
{
  #define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle."
  #define Q_tree_is_cyclic sc->pl_bt
  /* return(make_boolean(sc, tree_is_cyclic(sc, car(args)))); */
  s7_pointer tree = car(args);
  if (tree_is_cyclic(sc, tree)) return(sc->T);
  if (!has_active_methods(sc, tree)) return(sc->F);
  return(apply_boolean_method(sc, tree, sc->tree_is_cyclic_symbol));
}

static inline s7_int tree_len(s7_scheme *sc, s7_pointer p);

static s7_pointer copy_body(s7_scheme *sc, s7_pointer p)
{
  sc->w = p;
  if (tree_is_cyclic(sc, p)) /* don't wrap this in is_safety_checked */
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "copy: tree is cyclic: ~S", 24), p));
  check_free_heap_size(sc, tree_len(sc, p) * 2);
  return((sc->safety > No_Safety) ? copy_tree_with_type(sc, p) : copy_tree(sc, p));
}

static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc)
{
  /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */
  s7_pointer new_fnc;
  const s7_pointer body = copy_body(sc, closure_body(fnc));
  if ((is_any_macro(fnc)) && (has_pair_macro(fnc)))
    {
      set_pair_macro(body, pair_macro(closure_body(fnc)));
      set_has_pair_macro(fnc);
    }
  new_cell(sc, new_fnc, full_type(fnc) & (~T_Collected)); /* I'm paranoid about that is_collected bit */
  closure_set_pars(new_fnc, closure_pars(fnc));
  closure_set_body(new_fnc, body);
  closure_set_setter_or_map_list(new_fnc, closure_setter_or_map_list(fnc));
  closure_set_arity(new_fnc, closure_arity(fnc));
  closure_set_let(new_fnc, closure_let(fnc));
  return(new_fnc);
}


/* -------------------------------- defined? -------------------------------- */
static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
{
  #define H_is_defined "(defined? symbol (let (curlet)) only-search-local-let) returns #t if symbol has a binding (a value) in the let. \
Only the let is searched if only-search-local-let is #t."
  #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, has_let_signature(sc), sc->is_boolean_symbol)
  /* if the symbol has a global slot and e is unset or rootlet, this returns #t */

  s7_pointer sym = car(args);
  if (!is_symbol(sym))
    return(method_or_bust(sc, sym, sc->is_defined_symbol, args, sc->type_names[T_SYMBOL], 1));

  if (is_pair(cdr(args)))
    {
      s7_pointer let = cadr(args);
      const s7_pointer ignore_globals = (is_pair(cddr(args))) ? caddr(args) : sc->F;
      if (!is_let(let))
	{
	  const s7_pointer new_let = find_let(sc, let);  /* returns () if none */
	  if (!is_let(new_let))
	    find_let_error_nr(sc, sc->is_defined_symbol, let, new_let, 2, args);
	  if ((new_let == sc->rootlet) && (is_pair(cddr(args))) && (ignore_globals != sc->F))
	    {
	      if (ignore_globals != sc->T) /* signature claims this should be a boolean */
		return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, A_Boolean_String, 3));
	      return(sc->F);
	    }
	  let = new_let;
	}
      /* if (is_unlet(let)) return(make_boolean(sc, initial_value_is_defined(sc, sym))); */
      /* this ^ is wrong: (with-let (unlet) (define xx 1) (list (defined? 'xx) (defined? 'xx (curlet)))) should be (#t #t) */

      if (is_keyword(sym))                       /* if no "let", is global -> #t */
	{                                        /* we're treating :x as 'x outside rootlet, but consider all keywords defined (as themselves) in rootlet? */
	  if (let == sc->rootlet) return(sc->T); /* (defined? x (rootlet)) where x value is a keyword */
	  sym = keyword_symbol(sym);             /* (defined? :print-length *s7*) */
	}
      if (let == sc->starlet)
	return(make_boolean(sc, starlet_symbol_id(sym) != sl_No_Field));
      if (!is_boolean(ignore_globals))
	return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, A_Boolean_String, 3));
      if (let == sc->rootlet) /* we checked (let? let) above */
	{
	  if (ignore_globals == sc->F)
	    return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to #<undefined> */
	  return(sc->F);
	}
      if (ignore_globals == sc->T)
	return(make_boolean(sc, is_slot(symbol_to_local_slot(sc, sym, T_Let(let)))));
      return(make_boolean(sc, is_slot(lookup_slot_from(sym, T_Let(let)))));
    }
  return((is_defined_global(sym)) ? sc->T : make_boolean(sc, is_bound_symbol(sc, sym))); /* is_bound_symbol is (s7_slot() != sc->undefined) */
}

static s7_pointer g_is_defined_in_unlet(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym = car(args);
  if (!is_symbol(sym))
    wrong_type_error_nr(sc, sc->is_defined_symbol, 1, car(args), A_Symbol_String);
  return(make_boolean(sc, initial_value_is_defined(sc, sym)));
}

static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) /* aimed at lint.scm */
{
  /* (defined? bigi1 (rootlet)) can be optimized to opt_p_call_sf */
  s7_pointer sym = car(args);
  if (!is_symbol(sym))
    wrong_type_error_nr(sc, sc->is_defined_symbol, 1, sym, A_Symbol_String);
  return(make_boolean(sc, (is_slot(global_slot(sym))) && (global_value(sym) != sc->undefined)));
}

static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2)
    {
      const s7_pointer 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);
}

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 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 #<undefined> */
  if (is_slot(slot))
    slot_set_value_with_hook(slot, value);
  else
    {
      s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */
      /* if let is rootlet, s7_make_slot makes a semipermanent_slot */
      if ((let == sc->shadow_rootlet) &&
	  (!is_slot(global_slot(symbol))))
	set_global_slot(symbol, local_slot(symbol));
    }
}

s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value)
{
  s7_pointer sym = make_symbol_with_strlen(sc, name);
  s7_define(sc, sc->rootlet, sym, value);
  return(sym);
}

s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
{
  const s7_pointer sym = s7_define_variable(sc, name, value);
  symbol_set_has_help(sym);
  symbol_set_help(sym, copy_string(help));
  add_saved_pointer(sc, symbol_help(sym));
  return(sym);
}

s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer 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_possibly_constant(sym);
  if (let == sc->rootlet)
    {
      set_immutable(sym);
      set_immutable(global_slot(sym));
    }
  else
    {
      s7_pointer slot = symbol_to_local_slot(sc, sym, let);
      set_immutable_slot(slot);
    }
  return(sym);
}

s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value)
{
  return(s7_define_constant_with_environment(sc, sc->rootlet, name, value));
}

/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar
 * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa
 */

s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
{
  const s7_pointer sym = s7_define_constant(sc, name, value);
  symbol_set_has_help(sym);
  symbol_set_help(sym, copy_string(help));
  add_saved_pointer(sc, symbol_help(sym));
  return(value); /* inconsistent with variable above, but consistent with define_function? */
}


/* -------------------------------- keyword? -------------------------------- */
bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));}

static s7_pointer g_is_keyword(s7_scheme *sc, s7_pointer args)
{
  #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t"
  #define Q_is_keyword sc->pl_bt
  check_boolean_method(sc, is_symbol_and_keyword, sc->is_keyword_symbol, args);
}


/* -------------------------------- string->keyword -------------------------------- */
s7_pointer s7_make_keyword(s7_scheme *sc, const char *key)
{
  const size_t slen = (size_t)safe_strlen(key);
  block_t *b = inline_mallocate(sc, slen + 2);
  char *name = (char *)block_data(b);
  name[0] = ':';
  memcpy((void *)(name + 1), (const void *)key, slen);
  name[slen + 1] = '\0';
  {
    s7_pointer sym = inline_make_symbol(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */
    liberate(sc, b);
    return(sym);
  }
}

static s7_pointer g_string_to_keyword(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword"
  #define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol)

  const s7_pointer str = car(args);
  if (!is_string(str))
    return(sole_arg_method_or_bust(sc, str, sc->string_to_keyword_symbol, args, sc->type_names[T_STRING]));
  if ((string_length(str) == 0) ||
      (string_value(str)[0] == '\0'))
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "string->keyword wants a non-null string: ~S", 43), str));
  return(s7_make_keyword(sc, string_value(str)));
}


/* -------------------------------- keyword->symbol -------------------------------- */
static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended or appended colon"
  #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol)
  s7_pointer sym = car(args);
  if (!is_symbol_and_keyword(sym))
    return(method_or_bust_p(sc, sym, sc->keyword_to_symbol_symbol, wrap_string(sc, "a keyword", 9)));
  do {sym = keyword_symbol(sym);} while (is_keyword(sym)); /* loop for: (keyword->symbol ::hi) -> 'hi, : is not a keyword */
  return(sym);
}

s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_symbol(key));}


/* -------------------------------- symbol->keyword -------------------------------- */
#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym))

static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended"
  #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol)
  s7_pointer sym = car(args);
  if (!is_symbol(sym))
    return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_keyword_symbol, args, sc->type_names[T_SYMBOL]));
  if (is_keyword(sym)) return(sym);
  return(symbol_to_keyword(sc, sym));
}


/* -------------------------------- c-pointer? -------------------------------- */
bool s7_is_c_pointer(s7_pointer arg) {return(is_c_pointer(arg));}

bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type) {return((is_c_pointer(arg)) && (c_pointer_type(arg) == type));}

static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args)
{
  #define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7.  \
If type is given, the c_pointer's type is also checked."
  #define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T)

  const s7_pointer obj = car(args);
  if (is_c_pointer(obj))
    return((is_pair(cdr(args))) ? make_boolean(sc, c_pointer_type(obj) == cadr(args)) : sc->T);
  if (!has_active_methods(sc, obj)) return(sc->F);
  return(apply_boolean_method(sc, obj, sc->is_c_pointer_symbol));
}


/* -------------------------------- c-pointer -------------------------------- */
void *s7_c_pointer(s7_pointer p) {return(c_pointer(p));}

void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer cptr, s7_pointer expected_type, const char *caller, s7_int argnum)
{
  if (!is_c_pointer(cptr))
    wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, cptr, sc->type_names[T_C_POINTER]);
  if ((c_pointer(cptr) != NULL) &&
      (c_pointer_type(cptr) != expected_type))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     (argnum == 0) ?
	     set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52),
			 wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(cptr), expected_type) :
	     set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57),
			 wrap_string(sc, caller, safe_strlen(caller)),
			 wrap_integer(sc, argnum), c_pointer_type(cptr), expected_type));
  return(c_pointer(cptr));
}

s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info)
{
  s7_pointer new_cptr;
  new_cell(sc, new_cptr, T_C_POINTER);
  c_pointer(new_cptr) = ptr;
  c_pointer_type(new_cptr) = type;
  c_pointer_info(new_cptr) = info;
  c_pointer_weak1(new_cptr) = sc->F;
  c_pointer_weak2(new_cptr) = sc->F;
  return(new_cptr);
}

s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));}

s7_pointer s7_make_c_pointer_wrapper_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) /* for FFI, see libgsl_s7.c */
{
  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);
	    }}}
  {
    const s7_pointer cp = s7_make_c_pointer_with_type(sc, (void *)cptr, type, info);
    c_pointer_set_weak1(cp, weak1);
    c_pointer_set_weak2(cp, weak2);
    if ((weak1 != sc->F) || (weak2 != sc->F))
      add_weak_ref(sc, cp);
    return(cp);
  }
}


/* -------------------------------- c-pointer-info -------------------------------- */
static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer cptr)
{
  if (!is_c_pointer(cptr))
    return(method_or_bust_p(sc, cptr, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER]));
  return(c_pointer_info(cptr));
}

static s7_pointer g_c_pointer_info(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field"
  #define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
  return(c_pointer_info_p_p(sc, car(args)));
}


/* -------------------------------- c-pointer-type -------------------------------- */
static s7_pointer method_or_bust_lp(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ)
{ /* weird -- overhead goes berserk in callgrind if using the simpler method_or_bust_p! */
  if (!has_active_methods(sc, obj))
    wrong_type_error_nr(sc, method, 1, obj, sc->type_names[typ]);
  return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj)));
}

s7_pointer s7_c_pointer_type(s7_pointer cptr) {return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : NULL);}

static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer cptr)
{
  return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_type_symbol, T_C_POINTER));
}

static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field"
  #define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
  return(c_pointer_type_p_p(sc, car(args)));
}


/* -------------------------------- c-pointer-weak1/2 -------------------------------- */
static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer cptr)
{
  return((is_c_pointer(cptr)) ? c_pointer_weak1(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_weak1_symbol, T_C_POINTER));
}

static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field"
  #define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
  return(c_pointer_weak1_p_p(sc, car(args)));
}

static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer cptr)
{
  return((is_c_pointer(cptr)) ? c_pointer_weak2(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_weak2_symbol, T_C_POINTER));
}

static s7_pointer g_c_pointer_weak2(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field"
  #define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
  return(c_pointer_weak2_p_p(sc, car(args)));
}


/* -------------------------------- c-pointer->list -------------------------------- */
static s7_pointer g_c_pointer_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)"
  #define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol)

  s7_pointer cptr = car(args);
  if (!is_c_pointer(cptr))
    return(method_or_bust(sc, cptr, sc->c_pointer_to_list_symbol, args, sc->type_names[T_C_POINTER], 1));
  return(list_3(sc, make_integer(sc, (s7_int)((intptr_t)c_pointer(cptr))), c_pointer_type(cptr), c_pointer_info(cptr)));
}


/* -------------------------------- continuations and gotos -------------------------------- */

/* ----------------------- continuation? -------------------------------- */
static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args)
{
  #define H_is_continuation "(continuation? obj) returns #t if obj is a continuation"
  #define Q_is_continuation sc->pl_bt
  check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args);
  /* is this the right thing?  It returns #f for call-with-exit ("goto") because
   *   that form of continuation can't continue (via a jump back to its context).
   */
}

static bool is_continuation_b_p(s7_pointer p) {return(is_continuation(p));}

#if s7_Debugging
static s7_pointer check_wrap_return(s7_pointer lst)
{
  for (s7_pointer fast = lst, slow = lst; is_pair(fast); slow = cdr(slow), fast = cdr(fast))
    {
      if (is_matched_pair(fast)) fprintf(stderr, "%s[%d]: matched_pair not cleared\n", __func__, __LINE__);
      fast = cdr(fast);
      if (!is_pair(fast)) return(lst);
      if (fast == slow) return(lst);
      if (is_matched_pair(fast)) fprintf(stderr, "%s[%d]: matched_pair not cleared\n", __func__, __LINE__);
    }
  return(lst);
}
#endif

static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a)
{
  s7_pointer slow = cdr(a);
  s7_pointer fast = slow;
  s7_pointer p;
#if s7_Debugging
  #define wrap_return(W) do {fast = W; W = sc->unused; end_temp(sc->y); return(check_wrap_return(fast));} while (0)
#else
  #define wrap_return(W) do {fast = W; W = sc->unused; end_temp(sc->y); return(fast);} while (0)
#endif
  begin_temp(sc->y, a); /* gc_protect_via_stack doesn't work here because we're called in copy_stack, I think (trouble is in call/cc stuff) */
  sc->w = list_1(sc, car(a));
  p = sc->w;
  while (true)
    {
      if (!is_pair(fast))
	{
	  if (is_null(fast))
	    wrap_return(sc->w);
	  set_cdr(p, fast);
	  wrap_return(sc->w);
	}

      set_cdr(p, list_1(sc, car(fast)));
      p = cdr(p);
      fast = cdr(fast);
      if (!is_pair(fast))
	{
	  if (is_null(fast))
	    wrap_return(sc->w);
	  set_cdr(p, fast);
	  wrap_return(sc->w);
	}
      /* if unrolled further, it's a lot slower? */
      set_cdr(p, list_1_unchecked(sc, car(fast)));
      p = cdr(p);
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow)
	{
	  /* try to preserve the original cyclic structure */
	  s7_pointer p1, f1, p2, f2;
	  set_match_pair(a);
	  for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1))
	    set_match_pair(f1);
	  for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2))
	    clear_match_pair(f2);
	  for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2))
	    {
	      clear_match_pair(f1);
	      f1 = cdr(f1);
	      clear_match_pair(f1);
	      if (f1 == f2) break;
	    }
	  clear_match_pair(a);
	  if (is_null(p1))
	    set_cdr(p2, p2);
	  else set_cdr(p1, p2);
	  wrap_return(sc->w);
	}}
  wrap_return(sc->w);
}

static s7_pointer copy_counter(s7_scheme *sc, s7_pointer old_ctr)
{
  s7_pointer new_ctr;
  new_cell(sc, new_ctr, T_COUNTER);
  counter_set_result(new_ctr, counter_result(old_ctr));
  counter_set_list(new_ctr, counter_list(old_ctr));
  counter_set_capture(new_ctr, counter_capture(old_ctr));
  counter_set_let(new_ctr, counter_let(old_ctr));
  counter_set_slots(new_ctr, counter_slots(old_ctr));
  return(new_ctr);
}

static void stack_list_set_immutable(s7_pointer pold, s7_pointer pnew)
{
  for (s7_pointer p1 = pold, p2 = pnew, slow = pold; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2))
    {
      if (is_immutable(p1)) set_immutable_pair(p2);
      if (is_pair(cdr(p1)))
	{
	  p1 = cdr(p1);
	  p2 = cdr(p2);
	  if (is_immutable(p1)) set_immutable_pair(p2);
	  if (p1 == slow) break;
	  slow = cdr(slow);
	}}
}

static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, s7_int top)
{
  bool has_pairs = false;
  s7_pointer *nv = stack_elements(new_v);
  s7_pointer *ov = stack_elements(old_v);
  memcpy((void *)nv, (void *)ov, top * sizeof(s7_pointer));
  stack_clear_flags(new_v);

  s7_gc_on(sc, false);
  if (stack_has_counters(old_v))
    {
      for (s7_int i = 2; i < top; i += 4)
	{
	  const s7_pointer p = ov[i];               /* args */
	  /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */
	  if (is_pair(p))                           /* args need not be a list (it can be a port or #f, etc) */
	    {
	      has_pairs = true;
	      if (is_null(cdr(p)))
		nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */
	      else
		if ((is_pair(cdr(p))) && (is_null(cddr(p))))
		  nv[i] = list_2_unchecked(sc, car(p), cadr(p));
		else nv[i] = copy_any_list(sc, p);  /* args (copy is needed -- see s7test.scm) */
	      /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */
	      stack_list_set_immutable(p, nv[i]);
	    }
	  /* lst can be dotted or circular here.  The circular list only happens in a case like:
	   *    (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f))
	   *    proper_list_reverse_in_place(sc->args) is one reason we need to copy
	   */
	  else
	    if (is_counter(p))                     /* these can only occur in this context (not in a list etc) */
	      {
		stack_set_has_counters(new_v);
		nv[i] = copy_counter(sc, p);
	      }}}
  else
    for (s7_int i = 2; i < top; i += 4)
      if (is_pair(ov[i]))
	{
	  const s7_pointer p = ov[i];
	  has_pairs = true;
	  if (is_null(cdr(p)))
	    nv[i] = cons_unchecked(sc, car(p), sc->nil);
	  else
	    if ((is_pair(cdr(p))) && (is_null(cddr(p))))
	      nv[i] = list_2_unchecked(sc, car(p), cadr(p));
	    else nv[i] = copy_any_list(sc, p);  /* args (copy is needed -- see s7test.scm) */
	  stack_list_set_immutable(p, nv[i]);
	}
  if (has_pairs) stack_set_has_pairs(new_v);
  s7_gc_on(sc, true);
  return(new_v);
}

static s7_pointer copy_op_stack(s7_scheme *sc)
{
  int32_t len = (int32_t)(sc->op_stack_now - sc->op_stack);
  s7_pointer nv = make_simple_vector(sc, len); /* not sc->op_stack_size */
  if (len > 0)
    {
      s7_pointer *src = sc->op_stack;
      s7_pointer *dst = (s7_pointer *)vector_elements(nv);
      for (int32_t i = len; i > 0; i--) *dst++ = *src++;
    }
  return(nv);
}

/* -------------------------------- with-baffle -------------------------------- */
/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the
 *    middle of it from outside -- no outer evaluation of a continuation can jump across this
 *    barrier:  The flip-side of call-with-exit.
 */

static bool find_baffle(s7_scheme *sc, s7_int key)
{
  /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */
  if (sc->baffle_ctr > 0)
    for (s7_pointer let = sc->curlet; let; let = let_outlet(let))
      if ((is_baffle_let(let)) &&
	  (let_baffle_key(let) == key))
	return(true);
  return(false);
}

#define Not_Baffled -1

static s7_int find_any_baffle(s7_scheme *sc)
{
  /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */
  if (sc->baffle_ctr > 0)
    for (s7_pointer let = sc->curlet; let; let = let_outlet(let))
      if (is_baffle_let(let))
	return(let_baffle_key(let));
  return(Not_Baffled);
}

static void check_with_baffle(s7_scheme *sc)
{
  if (!s7_is_proper_list(sc, sc->code))
    syntax_error_nr(sc, "with-baffle: unexpected dot? ~A", 31, sc->code);
  pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED);
}

static bool op_with_baffle_unchecked(s7_scheme *sc)
{
  sc->code = cdr(sc->code);
  if (is_null(sc->code))
    {
      sc->value = sc->nil;
      return(true);
    }
  set_curlet(sc, make_let(sc, sc->curlet));
  set_baffle_let(sc->curlet);
  let_set_baffle_key(sc->curlet, sc->baffle_ctr++);
  return(false);
}


/* -------------------------------- call/cc -------------------------------- */
static void make_room_for_cc_stack(s7_scheme *sc)
{
  if ((s7_int)(sc->free_heap_top - sc->free_heap) < (s7_int)(sc->heap_size / 32)) /* we probably never need this much space (8 becomes enormous, 512 seems ok) */
    {                                                                               /*  but this doesn't seem to make much difference in timings */
      call_gc(sc);
      if ((s7_int)(sc->free_heap_top - sc->free_heap) < (s7_int)(sc->heap_size / 32))
	resize_heap(sc);
    }
}

s7_pointer s7_make_continuation(s7_scheme *sc)
{
  /* precede this with make_room_for_cc_stack(sc); */
  const s7_int loc = stack_top(sc);
  const s7_pointer stack = make_simple_vector(sc, loc);
  s7_pointer new_cc;
  block_t *block;

  set_full_type(stack, T_STACK);
  temp_stack_top(stack) = loc;
  begin_temp(sc->x, stack);
  copy_stack(sc, stack, sc->stack, loc);

  new_cell(sc, new_cc, T_CONTINUATION);
  block = mallocate_block(sc);
#if s7_Debugging
  sc->blocks_mallocated[Block_List]++;
#endif
  continuation_block(new_cc) = block;
  continuation_set_stack(new_cc, stack);
  continuation_stack_size(new_cc) = vector_length(continuation_stack(new_cc));
  continuation_stack_start(new_cc) = stack_elements(continuation_stack(new_cc));
  continuation_stack_end(new_cc) = (s7_pointer *)(continuation_stack_start(new_cc) + loc);
  continuation_op_stack(new_cc) = copy_op_stack(sc);
  continuation_op_loc(new_cc) = (int32_t)(sc->op_stack_now - sc->op_stack);
  continuation_op_size(new_cc) = sc->op_stack_size;
  continuation_key(new_cc) = find_any_baffle(sc);
  continuation_name(new_cc) = sc->F;
  end_temp(sc->x);
  add_continuation(sc, new_cc);
  return(new_cc);
}

static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let);
static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value);
static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer let);

static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer cont)
{
  /* called only from call_with_current_continuation.
   *   if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle
   *   so they'll complain.  Otherwise we're supposed to re-run the init func before diving
   *   into the body.  Similarly for let-temporarily.  If a call/cc jumps out of a dynamic-wind
   *   body-func, we're supposed to call the finish-func.  The continuation is called at
   *   stack_top(sc); the continuation form is at continuation_stack_top(cont).
   *
   * check sc->stack for dynamic-winds we're jumping out of
   *    we need to check from the current stack top down to where the continuation stack matches the current stack??
   *    this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation.
   *    also the two stacks can be different sizes (either can be larger)
   */
  const s7_pointer cc_stack = continuation_stack(cont);
  const s7_int cc_top = continuation_stack_top(cont);
  for (s7_int op_loc = stack_top(sc) - 1; (op_loc > 0) && ((op_loc >= cc_top) || (stack_code(sc->stack, op_loc) != stack_code(cc_stack, op_loc))); op_loc -= 4)
    {
      const opcode_t op = stack_op(sc->stack, op_loc);
      switch (op)
	{
	case OP_DYNAMIC_WIND:
	case OP_LET_TEMP_DONE:
	  {
	    const s7_pointer code = stack_code(sc->stack, op_loc);
	    s7_int s_base = 0;
	    for (s7_int j = 3; j < cc_top; j += 4)
	      if (((stack_op(cc_stack, j) == OP_DYNAMIC_WIND) ||
		   (stack_op(cc_stack, j) == OP_LET_TEMP_DONE)) &&
		  (code == stack_code(cc_stack, j)))
		{
		  s_base = op_loc;
		  break;
		}
	    if (s_base == 0)
	      {
		if (op == OP_DYNAMIC_WIND)
		  {
		    if (dynamic_wind_state(code) == Dwind_Body)
		      {
			dynamic_wind_state(code) = Dwind_Finish;
			if (dynamic_wind_out(code) != sc->F)
			  sc->value = s7_call(sc, dynamic_wind_out(code), sc->nil);
		      }}
		else let_temp_done(sc, stack_args(sc->stack, op_loc), T_Let(stack_let(sc->stack, op_loc)));
	      }}
	  break;

	case OP_DYNAMIC_UNWIND:
	  {
	    s7_pointer func = stack_code(sc->stack, op_loc);
	    s7_pointer args = stack_args(sc->stack, op_loc);
	    if ((is_pair(cdr(args))) && (is_pair(cddr(args))) && (caddr(args) == sc->T))
	      dynamic_unwind(sc, func, args);
	  }
	case OP_DYNAMIC_UNWIND_PROFILE:
	  set_stack_op(sc->stack, op_loc, OP_GC_PROTECT);
	  break;

	case OP_LET_TEMP_UNWIND:
	  let_temp_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc));
	  break;

	case OP_LET_TEMP_S7_UNWIND:
	  starlet_set_1(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc));
	  break;

	case OP_LET_TEMP_S7_OPENLETS_UNWIND:
	  sc->has_openlets = (stack_args(sc->stack, op_loc) != sc->F);
	  break;

	case OP_BARRIER:
	  if (op_loc > cc_top)                /* otherwise it's some unproblematic outer eval-string? */
	    return(false);                    /*    but what if we've already evaluated a dynamic-wind closer? */
	  break;

	case OP_DEACTIVATE_GOTO:              /* here we're jumping out of an unrelated call-with-exit block */
	  if (op_loc > cc_top)
	    call_exit_active(stack_args(sc->stack, op_loc)) = false;
	  break;

	case OP_UNWIND_INPUT:
	  if (stack_args(sc->stack, op_loc) != sc->unused)
	    set_current_input_port(sc, stack_args(sc->stack, op_loc));    /* "args" = port that we shadowed */
	  break;

	case OP_UNWIND_OUTPUT:
	  if (stack_args(sc->stack, op_loc) != sc->unused)
	    set_current_output_port(sc, stack_args(sc->stack, op_loc));   /* "args" = port that we shadowed */
	  break;

	default:
	  if ((s7_Debugging) && (op == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr);
	  break;
	}}

  /* check continuation-stack for dynamic-winds we're jumping into */
  for (s7_int op_loc = stack_top(sc) - 1; op_loc < cc_top; op_loc += 4)
    {
      const opcode_t op = stack_op(cc_stack, op_loc);
      if (op == OP_DYNAMIC_WIND)
	{
	  const s7_pointer dw = T_Dyn(stack_code(cc_stack, op_loc));
	  if (dynamic_wind_in(dw) != sc->F)
	    sc->value = s7_call(sc, dynamic_wind_in(dw), sc->nil);
	  dynamic_wind_state(dw) = Dwind_Body;
	}
      else
	if (op == OP_DEACTIVATE_GOTO)
	  call_exit_active(stack_args(cc_stack, op_loc)) = true;
      /* not let_temp_done here! */
      /* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily.  MIT and Chez scheme say they remember the
       *   let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them
       *   on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the
       *   call/cc to restore all let-temp vars!  I think let-temp here should be the same as let -- if you jump back
       *   in, nothing hidden happens. So,
       *     (let ((x #f) (cc #f))
       *       (let-temporarily ((x 1))
       *         (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc)))
       *   behaves the same (in this regard) if let-temp is replaced with let.
       */
    }
  return(true);
}

static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args);

static void call_with_current_continuation(s7_scheme *sc)
{
  s7_pointer cont = sc->code;  /* sc->args are the returned values */

  /* check for (baffle ...) blocking the current attempt to continue */
  if ((continuation_key(cont) != Not_Baffled) &&
      (!find_baffle(sc, continuation_key(cont))))
    error_nr(sc, sc->baffled_symbol,
	     (is_symbol(continuation_name(sc->code))) ?
	     set_elist_2(sc, wrap_string(sc, "continuation ~S can't jump into with-baffle", 43), continuation_name(cont)) :
	     set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40)));

  if (check_for_dynamic_winds(sc, cont))
    {
      /* make_room_for_cc_stack(sc); */ /* 28-May-21 */
      /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be cont here, etc */
      if ((stack_has_pairs(continuation_stack(cont))) ||
	  (stack_has_counters(continuation_stack(cont))))
	{
	  make_room_for_cc_stack(sc);
	  copy_stack(sc, sc->stack, continuation_stack(cont), continuation_stack_top(cont));
	}
      else
	{
	  s7_pointer *nv = stack_elements(sc->stack);
	  s7_pointer *ov = stack_elements(continuation_stack(cont));
	  memcpy((void *)nv, (void *)ov, continuation_stack_top(cont) * sizeof(s7_pointer));
	}
      /* copy_stack(sc, sc->stack, continuation_stack(cont), continuation_stack_top(cont)); */
      sc->stack_end = (s7_pointer *)(sc->stack_start + continuation_stack_top(cont));
      {
	const int32_t top = continuation_op_loc(cont);
	sc->op_stack_now = (s7_pointer *)(sc->op_stack + top);
	sc->op_stack_size = continuation_op_size(cont);
	sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
	{
	  s7_pointer *src = (s7_pointer *)vector_elements(continuation_op_stack(cont));
	  s7_pointer *dst = sc->op_stack;
	  for (int32_t i = 0; i < top; i++) dst[i] = src[i];
	}}
      sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args));
    }
}

static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args)
{
  #define H_call_cc "(call-with-current-continuation (lambda (continuer) ...)) evaluates the body with continuer as a way to goto to the continuation of the body"
  #define Q_call_cc s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)

  const s7_pointer func = car(args);         /* this is the procedure passed to call/cc */
  if (!is_t_procedure(func))                 /* this includes continuations */
    {
      if_method_exists_return_value(sc, func, sc->call_cc_symbol, args);
      if_method_exists_return_value(sc, func, sc->call_with_current_continuation_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->call_cc_symbol, func, A_Procedure_String);
    }
  if (((!is_closure(func)) ||
       (closure_arity(func) != 1)) &&
      (!s7_is_aritable(sc, func, 1)))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "call/cc procedure, ~A, should take one argument", 47), func));

  make_room_for_cc_stack(sc);
  begin_temp(sc->y, s7_make_continuation(sc));
  if ((is_any_closure(func)) && (is_pair(closure_pars(func))) && (is_symbol(car(closure_pars(func)))))
    continuation_name(sc->y) = car(closure_pars(func));
  push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->y), func); /* apply func to continuation */
  end_temp(sc->y);
  return(sc->nil);
}

static void op_call_cc(s7_scheme *sc) /* OP_CALL_CC in eval via optimize_c_function_one_arg */
{
  make_room_for_cc_stack(sc);
  begin_temp(sc->y, s7_make_continuation(sc));
  continuation_name(sc->y) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */
  set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, continuation_name(sc->y), sc->y));
  end_temp(sc->y);
  sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */
}

static bool op_implicit_continuation_a(s7_scheme *sc)
{
  const s7_pointer code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */
  const s7_pointer cont = lookup_checked(sc, car(code));
  if (!is_continuation(cont)) {sc->last_function = cont; return(false);}
  sc->code = cont;
  sc->args = set_plist_1(sc, fx_call(sc, cdr(code)));
  call_with_current_continuation(sc);
  return(true);
}


/* -------------------------------- call-with-exit -------------------------------- */
static void pop_input_port(s7_scheme *sc);

static void call_with_exit(s7_scheme *sc)
{
  s7_int op_loc, new_stack_top, quit = 0;

  if (!call_exit_active(sc->code))
    error_nr(sc, sc->invalid_exit_function_symbol,
	     (is_symbol(call_exit_name(sc->code))) ?
	       set_elist_2(sc, wrap_string(sc, "call-with-exit exit procedure, ~A, called outside its block", 59), call_exit_name(sc->code)) :
	       set_elist_1(sc, wrap_string(sc, "call-with-exit exit procedure called outside its block", 54)));

  call_exit_active(sc->code) = false;
  new_stack_top = call_exit_goto_loc(sc->code);
  sc->op_stack_now = (s7_pointer *)(sc->op_stack + call_exit_op_loc(sc->code));

  /* look for dynamic-wind in the stack section that we are jumping out of */
  op_loc = stack_top(sc) - 1;
  /* op is entirely op_deactivate_goto tgc, for_each_2|3 tcase, dox_step_o texit, lots of ops s7test.scm */
  /* if (stack_op(sc->stack, op_loc) == OP_DEACTIVATE_GOTO) {call_exit_active(stack_args(sc->stack, op_loc)) = false; goto Set_Value;} saves >54 in tgc */

  do {
    switch (stack_op(sc->stack, op_loc)) /* the hit rate here is good; exiters[op] slowed us down! (see tmp) tgc/texit slower, tcase faster */
      {
      case OP_DYNAMIC_WIND:
	{
	  const s7_pointer lx = T_Dyn(stack_code(sc->stack, op_loc));
	  if (dynamic_wind_state(lx) == Dwind_Body)
	    {
	      dynamic_wind_state(lx) = Dwind_Finish;
	      if (dynamic_wind_out(lx) != sc->F)
		{
		  s7_pointer arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused;  /* might also need GC protection here */
		  /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */
		  sc->value = s7_call(sc, dynamic_wind_out(lx), sc->nil);
		  if (arg != sc->unused) set_plist_1(sc, arg);
		}}}
	break;

      case OP_DYNAMIC_UNWIND:
      case OP_DYNAMIC_UNWIND_PROFILE:
	set_stack_op(sc->stack, op_loc, OP_GC_PROTECT);
	dynamic_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc));
	break;

      case OP_EVAL_STRING:
	s7_close_input_port(sc, current_input_port(sc));
	pop_input_port(sc);
	break;

      case OP_BARRIER:                /* oops -- we almost certainly went too far */
	goto Set_Value;

      case OP_DEACTIVATE_GOTO:        /* here we're jumping into an unrelated call-with-exit block */
	call_exit_active(stack_args(sc->stack, op_loc)) = false;
	break;

      case OP_LET_TEMP_DONE:
	{
	  s7_pointer old_args = sc->args;
	  let_temp_done(sc, stack_args(sc->stack, op_loc), T_Let(stack_let(sc->stack, op_loc)));
	  sc->args = old_args;
	}
	break;

      case OP_LET_TEMP_UNWIND:
	let_temp_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc));
	break;

      case OP_LET_TEMP_S7_UNWIND:
	starlet_set_1(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc));
	break;

      case OP_LET_TEMP_S7_OPENLETS_UNWIND:
	sc->has_openlets = (stack_args(sc->stack, op_loc) != sc->F);
	break;

	/* call/cc does not close files, but I think call-with-exit should */
      case OP_GET_OUTPUT_STRING:
      case OP_UNWIND_OUTPUT:
	{
	  s7_pointer port = T_Pro(stack_code(sc->stack, op_loc));  /* "code" = port that we opened */
	  s7_close_output_port(sc, port);
	  port = stack_args(sc->stack, op_loc);                    /* "args" = port that we shadowed, if not #<unused> */
	  if (port != sc->unused)
	    set_current_output_port(sc, port);
	}
	break;

      case OP_UNWIND_INPUT:
	s7_close_input_port(sc, T_Pri(stack_code(sc->stack, op_loc))); /* "code" = port that we opened */
	if (stack_args(sc->stack, op_loc) != sc->unused)
	  set_current_input_port(sc, stack_args(sc->stack, op_loc));   /* "args" = port that we shadowed */
	break;

      case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */
	quit++;
	break;

      default:
	if ((s7_Debugging) && (stack_op(sc->stack, op_loc) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr);
	break;
      }
    op_loc -= 4;
  } while (op_loc > new_stack_top);

 Set_Value:
  sc->stack_end = (s7_pointer *)(sc->stack_start + new_stack_top);

  /* the return value should have an implicit values call, just as in call/cc */
  sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args));
  if (quit > 0)
    {
      if (sc->longjmp_ok)
	{
	  pop_stack(sc);
	  LongJmp(*(sc->Goto_Start), Call_With_Exit_Jump);
	}
      for (s7_int i = 0; i < quit; i++)
	push_stack_op_let(sc, OP_EVAL_DONE);
    }
}

static s7_pointer g_is_goto(s7_scheme *sc, s7_pointer args)
{
  #define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function"
  #define Q_is_goto sc->pl_bt
  return(make_boolean(sc, is_goto(car(args))));
}

static inline s7_pointer make_goto(s7_scheme *sc, s7_pointer name) /* inline for 73=1% in tgc */
{
  s7_pointer new_goto;
  new_cell(sc, new_goto, T_GOTO);
  call_exit_goto_loc(new_goto) = stack_top(sc);
  call_exit_op_loc(new_goto) = (int32_t)(sc->op_stack_now - sc->op_stack);
  call_exit_active(new_goto) = true;
  call_exit_name(new_goto) = name;
  return(new_goto);
}

static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args)   /* (call-with-exit (lambda (return) ...)) */
{
  #define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation."
  #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)

  const s7_pointer func = car(args);
  s7_pointer new_goto;
  if (is_any_closure(func)) /* lambda or lambda* */
    {
      new_goto = make_goto(sc, ((is_pair(closure_pars(func))) && (is_symbol(car(closure_pars(func))))) ? car(closure_pars(func)) : sc->F);
      push_stack(sc, OP_DEACTIVATE_GOTO, new_goto, func); /* this means call-with-exit is not tail-recursive */
      push_stack(sc, OP_APPLY, cons_unchecked(sc, new_goto, sc->nil), func);
      return(sc->nil);
    }
  /* maybe just return an error here -- these gotos as args are stupid; also an error above if closure not aritable 1 */
  if (!is_t_procedure(func))
    return(method_or_bust_p(sc, func, sc->call_with_exit_symbol, A_Procedure_String));
  if (!s7_is_aritable(sc, func, 1))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a function of one argument: ~S", 64), func));
  if (is_continuation(func)) /* (call/cc call-with-exit) ! */
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a normal function (not a continuation: ~S)", 76), func));
  new_goto = make_goto(sc, sc->F);
  call_exit_active(new_goto) = false;
  return((is_c_function(func)) ? c_function_call(func)(sc, set_plist_1(sc, new_goto)) : s7_apply_function_star(sc, func, set_plist_1(sc, new_goto)));
}

static inline void op_call_with_exit(s7_scheme *sc)
{
  const s7_pointer args = opt2_pair(sc->code);
  const s7_pointer go = make_goto(sc, caar(args));
  push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */
  set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(args), go));
  sc->code = T_Pair(cdr(args));
  /* goto Begin */
}

static void op_call_with_exit_o(s7_scheme *sc)
{
  op_call_with_exit(sc);
  sc->code = car(sc->code);
  /* goto Eval */
}

static bool op_implicit_goto(s7_scheme *sc)
{
  const s7_pointer g = lookup_checked(sc, car(sc->code));
  if (!is_goto(g)) {sc->last_function = g; return(false);}
  sc->args = sc->nil;
  sc->code = g;
  call_with_exit(sc);
  return(true);
}

static bool op_implicit_goto_a(s7_scheme *sc) /* in tgc implicit_goto_s saves 15 */
{
  const s7_pointer g = lookup_checked(sc, car(sc->code));
  if (!is_goto(g)) {sc->last_function = g; return(false);}
  sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code)));
  sc->code = g;
  call_with_exit(sc);
  return(true);
}

static s7_pointer g_goto_is_active(s7_scheme *sc, s7_pointer args)
{
  #define H_goto_is_active "(goto-active? goto) returns #t if the goto can be called, exiting its call-with-exit's body, or a continuation is not baffled"
  #define Q_goto_is_active s7_make_signature(sc, 2, sc->is_boolean_symbol, s7_make_signature(sc, 2, sc->is_goto_symbol, sc->is_continuation_symbol))

  const s7_pointer obj = car(args);
  if (is_continuation(obj))
    return(make_boolean(sc, (continuation_key(obj) == Not_Baffled) || (find_baffle(sc, continuation_key(obj)))));
  if (is_goto(obj))
    return(make_boolean(sc, call_exit_active(obj)));
  return(method_or_bust(sc, obj, sc->goto_is_active_symbol, set_mlist_1(sc, obj), wrap_string(sc, "a goto or a continuation", 24), 1));
}

static bool goto_is_active_b_7p(s7_scheme *sc, s7_pointer obj)
{
  if (is_continuation(obj))
    return(make_boolean(sc, (continuation_key(obj) == Not_Baffled) || (find_baffle(sc, continuation_key(obj)))));
  if (is_goto(obj))
    return(call_exit_active(obj));
  return(method_or_bust(sc, obj, sc->goto_is_active_symbol, set_mlist_1(sc, obj), wrap_string(sc, "a goto or a continuation", 24), 1) != sc->F);
}


/* -------------------------------- numbers -------------------------------- */
static block_t *string_to_block(s7_scheme *sc, const char *p, s7_int len)
{
  block_t *b = inline_mallocate(sc, len + 1);
  char *bp = (char *)block_data(b);
  memcpy((void *)bp, (const void *)p, len);
  bp[len] = '\0';
  return(b);
}

static Inline s7_pointer inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len)
{
  s7_pointer new_string;
  new_cell(sc, new_string, T_STRING | T_Safe_Procedure);
  string_block(new_string) = block;
  string_value(new_string) = (char *)block_data(block);
  string_length(new_string) = len;
  string_value(new_string)[len] = '\0';
  string_hash(new_string) = 0;
  add_string(sc, new_string);
  return(new_string);
}

static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));}

static /* inline */ s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den) /* no gcd needed in this case */
{
  s7_pointer new_ratio;
  if (den < 0)
    {
      if ((num == s7_Int64_Min) || (den == s7_Int64_Min))  /* assume no gcd involved */
	return(make_real(sc, (long_double)num / (long_double)den));
      if (den == -1)
	return(make_integer(sc, -num));
      new_cell(sc, new_ratio, T_RATIO);
      set_numerator(new_ratio, -num);
      set_denominator(new_ratio, -den);
    }
  else
    {
      if (den == 1)
	return(make_integer(sc, num));
      new_cell(sc, new_ratio, T_RATIO);
      set_numerator(new_ratio, num);
      set_denominator(new_ratio, den);
    }
  return(new_ratio);
}

static /* inline */ s7_pointer make_simpler_ratio(s7_scheme *sc, s7_int num, s7_int den) /* no gcd needed, and den > 1 */
{
  s7_pointer new_ratio;
  if ((s7_Debugging) && (den < 2)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den);
  new_cell(sc, new_ratio, T_RATIO);
  set_numerator(new_ratio, num);
  set_denominator(new_ratio, den);
  return(new_ratio);
}

static inline s7_pointer make_simpler_ratio_or_integer(s7_scheme *sc, s7_int num, s7_int den) /* nom gcd needed and den > 0 (might be 1) */
{
  s7_pointer new_ratio;
  if ((s7_Debugging) && (den <= 0)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den);
  if (den == 1)
    return(make_integer(sc, num));
  new_cell(sc, new_ratio, T_RATIO);
  set_numerator(new_ratio, num);
  set_denominator(new_ratio, den);
  return(new_ratio);
}

static bool is_zero(s7_pointer x);
static bool is_positive(s7_scheme *sc, s7_pointer x);
static bool is_negative(s7_scheme *sc, s7_pointer x);
static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b);

static bool is_NaN(s7_double x) {return(x != x);}
/* callgrind says this is faster than isnan, I think (very confusing data...) */

#if defined(__sun) && defined(__SVR4)
  static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* there's no isinf in Solaris */
#else
#if !MS_Windows
  #if __cplusplus
    #define is_inf(X) std::isinf(X)
  #else
    #define is_inf(X) isinf(X)
  #endif
#else
  static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));}  /* Another possibility: (x * 0) != 0 */

#if (_MSC_VER < 1700)
  /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */
  static double asinh(double x) {return(log(x + sqrt(1.0 + x * x)));}
  static double acosh(double x) {return(log(x + sqrt(x * x - 1.0)));}
  /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */
  static double atanh(double x) {return(log((1.0 + x) / (1.0 - x)) / 2.0);}
  static double cbrt(double x) {if (x >= 0.0) return(pow(x, 1.0 / 3.0)); return(-pow(-x, 1.0 / 3.0));}
#endif
#endif /* windows */
#endif /* not sun */


/* -------------------------------- NaN payloads -------------------------------- */
typedef union {s7_int ix; double fx;} decode_float_t;

static s7_double nan_with_payload(s7_int payload)
{
  decode_float_t num;
  if (payload <= 0) return(Nan);
  num.fx = Nan;
  num.ix = num.ix | payload;
  return(num.fx);
}

static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload) {return(make_real(sc, nan_with_payload(payload)));}

static s7_pointer g_nan(s7_scheme *sc, s7_pointer args)
{
  #define H_nan "(nan (int 0)) returns a NaN with payload int"
  #define Q_nan s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_integer_symbol)
  #define Nan_Payload_Limit (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): +nan.9007199254740991 -- 52 bits available? */
  s7_pointer payload;
  if (is_null(args)) return(Real_NaN);    /* payload defaults to 0 */
  payload = car(args);
  if (!is_t_integer(payload))
    return(method_or_bust_p(sc, payload, sc->nan_symbol, sc->type_names[T_INTEGER]));
  if (integer(payload) < 0)
    sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), It_Is_Negative_String);
  if (integer(payload) >= Nan_Payload_Limit)
    sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), It_Is_Too_Large_String);
  return(make_nan_with_payload(sc, integer(payload)));
}

static s7_int nan_payload(double x)
{
  decode_float_t num;
  num.fx = x;
  return(num.ix & 0xffffffffffff);
}

static s7_pointer g_nan_payload(s7_scheme *sc, s7_pointer args)
{
  #define H_nan_payload "(nan-payload x) returns the payload associated with the NaN x"
  #define Q_nan_payload s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  const s7_pointer nan = car(args);
  if (!is_t_real(nan))
    return(method_or_bust_p(sc, nan, sc->nan_payload_symbol, sc->type_names[T_REAL]));
  if (!is_NaN(real(nan))) /* for complex case, use real-part etc (see s7test.scm) */
    sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, nan, wrap_string(sc, "a NaN", 5));
  return(make_integer(sc, nan_payload(real(nan))));
}

/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */


/* -------- gmp stuff -------- */
#if With_Gmp
static mp_prec_t mpc_precision = Default_Bignum_Precision;
static mp_prec_t mpc_set_default_precision(mp_prec_t prec) {mpc_precision = prec; return(prec);}
#define mpc_init(Z) mpc_init2(Z, mpc_precision)

static bigint *alloc_bigint(s7_scheme *sc)
{
  bigint *p;
  if (sc->bigints)
    {
      p = sc->bigints;
      sc->bigints = p->nxt;
    }
  else
    {
      p = (bigint *)Malloc(sizeof(bigint));
      /* not permalloc here: gmp must be playing tricky games with realloc or something.  permalloc can lead
       *   to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the
       *   bigint nxt field.  Someday I need to look at the source.
       */
      mpz_init(p->n);
    }
  return(p);
}

static bigrat *alloc_bigrat(s7_scheme *sc)
{
  bigrat *p;
  if (sc->bigrats)
    {
      p = sc->bigrats;
      sc->bigrats = p->nxt;
    }
  else
    {
      p = (bigrat *)Malloc(sizeof(bigrat));
      mpq_init(p->q);
    }
  return(p);
}

static bigflt *alloc_bigflt(s7_scheme *sc)
{
  bigflt *p;
  if (sc->bigflts)
    {
      p = sc->bigflts;
      sc->bigflts = p->nxt;
      mpfr_set_prec(p->x, sc->bignum_precision);
    }
  else
    {
      p = (bigflt *)Malloc(sizeof(bigflt));
      mpfr_init2(p->x, sc->bignum_precision);
    }
  return(p);
}

static bigcmp *alloc_bigcmp(s7_scheme *sc)
{
  bigcmp *p;
  if (sc->bigcmps)
    {
      p = sc->bigcmps;
      sc->bigcmps = p->nxt;
      mpc_set_prec(p->z, sc->bignum_precision);
    }
  else
    {
      p = (bigcmp *)Malloc(sizeof(bigcmp));
      mpc_init(p->z);
    }
  return(p);
}

static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val)
{
  s7_pointer new_bgi;
  new_cell(sc, new_bgi, T_BIG_INTEGER);
  big_integer_bgi(new_bgi) = alloc_bigint(sc);
  mpz_set(big_integer(new_bgi), val);
  add_big_integer(sc, new_bgi);
  return(new_bgi);
}

static s7_pointer mpz_to_integer(s7_scheme *sc, mpz_t val)
{
  if (mpz_fits_slong_p(val))
    return(make_integer(sc, mpz_get_si(val)));
  return(mpz_to_big_integer(sc, val));
}

#if !With_Pure_s7
static s7_pointer mpz_to_big_real(s7_scheme *sc, mpz_t val)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);
  mpfr_set_z(big_real(new_bgf), val, Mpfr_Rndn);
  return(new_bgf);
}
#endif

static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val)
{
  s7_pointer new_bgr;
  new_cell(sc, new_bgr, T_BIG_RATIO);
  big_ratio_bgr(new_bgr) = alloc_bigrat(sc);
  add_big_ratio(sc, new_bgr);
  mpq_set(big_ratio(new_bgr), val);
  return(new_bgr);
}

static s7_pointer mpq_to_rational(s7_scheme *sc, mpq_t val)
{
  if (mpz_cmp_ui(mpq_denref(val), 1) == 0)
    return(mpz_to_integer(sc, mpq_numref(val)));
#if s7_Debugging
  mpq_canonicalize(val);
  if (mpz_cmp_ui(mpq_denref(val), 1) == 0)
    {
      fprintf(stderr, "mpq_to_rational: missing canonicalize\n");
      return(mpz_to_integer(sc, mpq_numref(val)));
    }
#endif
 if ((mpz_fits_slong_p(mpq_numref(val))) && (mpz_fits_slong_p(mpq_denref(val))))
    return(make_simple_ratio(sc, mpz_get_si(mpq_numref(val)), mpz_get_si(mpq_denref(val))));
  return(mpq_to_big_ratio(sc, val));
}

static s7_pointer mpq_to_canonicalized_rational(s7_scheme *sc, mpq_t mpq)
{
  mpq_canonicalize(mpq);
  return(mpq_to_rational(sc, mpq));
}

static s7_pointer mpz_to_rational(s7_scheme *sc, mpz_t n, mpz_t d) /* mpz_3 and mpz_4 */
{
  if (mpz_cmp_ui(d, 1) == 0)
    return(mpz_to_integer(sc, n));
  mpq_set_num(sc->mpq_1, n);
  mpq_set_den(sc->mpq_1, d);
  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
}

#if !With_Pure_s7
static s7_pointer mpq_to_big_real(s7_scheme *sc, mpq_t val)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);
  mpfr_set_q(big_real(new_bgf), val, Mpfr_Rndn);
  return(new_bgf);
}
#endif

static s7_pointer any_rational_to_mpq(s7_scheme *sc, s7_pointer z, mpq_t bigq)
{
  switch (type(z))
    {
    case T_INTEGER:     mpq_set_si(bigq, integer(z), 1);                break;
    case T_BIG_INTEGER: mpq_set_z(bigq, big_integer(z));                break;
    case T_RATIO:       mpq_set_si(bigq, numerator(z), denominator(z)); break;
    case T_BIG_RATIO:   mpq_set(bigq, big_ratio(z));                    break;
    }
  return(z);
}

static s7_pointer mpfr_to_integer(s7_scheme *sc, mpfr_t val)
{
  mpfr_get_z(sc->mpz_4, val, Mpfr_Rndn);
  return(mpz_to_integer(sc, sc->mpz_4));
}

static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  add_big_real(sc, new_bgf);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  mpfr_set(big_real(new_bgf), val, Mpfr_Rndn);
  return(new_bgf);
}

static s7_pointer mpc_to_number(s7_scheme *sc, mpc_t val)
{
  s7_pointer new_bgc;
  if (mpfr_zero_p(mpc_imagref(val)))
    return(mpfr_to_big_real(sc, mpc_realref(val)));
  new_cell(sc, new_bgc, T_BIG_COMPLEX);
  big_complex_bgc(new_bgc) = alloc_bigcmp(sc);
  add_big_complex(sc, new_bgc);
  mpc_set(big_complex(new_bgc), val, MPC_RNDNN);
  return(new_bgc);
}

/* s7.h */
mpz_t  *s7_big_integer(s7_pointer x) {return(&big_integer(x));}
mpq_t  *s7_big_ratio(s7_pointer x)   {return(&big_ratio(x));}
mpfr_t *s7_big_real(s7_pointer x)    {return(&big_real(x));}
mpc_t  *s7_big_complex(s7_pointer x) {return(&big_complex(x));}

bool s7_is_big_integer(s7_pointer x) {return(is_t_big_integer(x));}
bool s7_is_big_ratio(s7_pointer x)   {return(is_t_big_ratio(x));}
bool s7_is_big_real(s7_pointer x)    {return(is_t_big_real(x));}
bool s7_is_big_complex(s7_pointer x) {return(is_t_big_complex(x));}

s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val) {return(mpz_to_integer(sc, *val));}
s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val)   {return(mpq_to_rational(sc, *val));}
s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val)   {return(mpfr_to_big_real(sc, *val));}
s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val) {return(mpc_to_number(sc, *val));}

#if !With_Pure_s7
static s7_pointer big_integer_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpz_to_big_real(sc, big_integer(x)));}
static s7_pointer big_ratio_to_big_real(s7_scheme *sc, s7_pointer x)   {return(mpq_to_big_real(sc, big_ratio(x)));}
#endif

static s7_pointer s7_int_to_big_integer(s7_scheme *sc, s7_int val)
{
  s7_pointer new_bgi;
  new_cell(sc, new_bgi, T_BIG_INTEGER);
  big_integer_bgi(new_bgi) = alloc_bigint(sc);
  mpz_set_si(big_integer(new_bgi), val);
  add_big_integer(sc, new_bgi);
  return(new_bgi);
}

static s7_pointer s7_int_to_big_ratio(s7_scheme *sc, s7_int num, s7_int den)
{
  /* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */
  s7_pointer new_bgr;
  new_cell(sc, new_bgr, T_BIG_RATIO);
  big_ratio_bgr(new_bgr) = alloc_bigrat(sc);
  add_big_ratio(sc, new_bgr);
  mpq_set_si(big_ratio(new_bgr), num, den);
  return(new_bgr);
}

static s7_pointer s7_double_to_big_real(s7_scheme *sc, s7_double rl)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);
  mpfr_set_d(big_real(new_bgf), rl, Mpfr_Rndn);
  return(new_bgf);
}

static s7_pointer s7_double_to_big_complex(s7_scheme *sc, s7_double rl, s7_double im)
{
  s7_pointer new_bgc;
  new_cell(sc, new_bgc, T_BIG_COMPLEX);
  add_big_complex(sc, new_bgc);
  big_complex_bgc(new_bgc) = alloc_bigcmp(sc);
  mpc_set_d_d(big_complex(new_bgc), rl, im, MPC_RNDNN);
  return(new_bgc);
}

static s7_pointer big_pi(s7_scheme *sc)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL | T_Immutable);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);
  mpfr_const_pi(big_real(new_bgf), Mpfr_Rndn);
  return(new_bgf);
}

static bool is_integer_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_integer(p))
    return(true);
  if (has_active_methods(sc, p))
    {
      s7_pointer func = find_method_with_let(sc, p, sc->is_integer_symbol);
      if (func != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p))));
    }
  return(false);
}

#if !With_Pure_s7
static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer num)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);

  switch (type(num))
    {
    case T_INTEGER:
      mpfr_set_si(big_real(new_bgf), integer(num), Mpfr_Rndn);
      break;
    case T_RATIO:
      /* here we can't use fraction(number(num)) even though that uses long_double division because
       *   there are lots of s7_int ratios that will still look the same. We have to do the bignum divide by hand.
       */
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpfr_set_q(big_real(new_bgf), sc->mpq_1, Mpfr_Rndn);
      break;
    default:
      mpfr_set_d(big_real(new_bgf), s7_real(num), Mpfr_Rndn);
      break;
    }
  return(new_bgf);
}
#endif

static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer num)
{
  s7_pointer new_bgc;
  new_cell(sc, new_bgc, T_BIG_COMPLEX);
  big_complex_bgc(new_bgc) = alloc_bigcmp(sc);
  add_big_complex(sc, new_bgc);

  switch (type(num))
    {
    case T_INTEGER:
      mpc_set_si(big_complex(new_bgc), integer(num), MPC_RNDNN);
      break;
    case T_RATIO:
      /* can't use fraction here */
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpfr_set_q(sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
      mpc_set_fr(big_complex(new_bgc), sc->mpfr_1, MPC_RNDNN);
      break;
    case T_REAL:
      mpc_set_d(big_complex(new_bgc), s7_real(num), MPC_RNDNN);
      break;
    default:
      mpc_set_d_d(big_complex(new_bgc), real_part(num), imag_part(num), MPC_RNDNN);
      break;
    }
  return(new_bgc);
}

static s7_pointer any_real_to_mpfr(s7_scheme *sc, s7_pointer num, mpfr_t bigx)
{
  switch (type(num))
    {
    case T_INTEGER:
      mpfr_set_si(bigx, integer(num), Mpfr_Rndn);
      break;
    case T_RATIO:
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpfr_set_q(bigx, sc->mpq_1, Mpfr_Rndn);
      break;
    case T_REAL:
      mpfr_set_d(bigx, real(num), Mpfr_Rndn);
      if (is_NaN(real(num))) return(make_nan_with_payload(sc, __LINE__));
      if (is_inf(real(num))) return(Real_Infinity);
      break;
    case T_BIG_INTEGER:
      mpfr_set_z(bigx, big_integer(num), Mpfr_Rndn);
      break;
    case T_BIG_RATIO:
      mpfr_set_q(bigx, big_ratio(num), Mpfr_Rndn);
      break;
    case T_BIG_REAL:
      mpfr_set(bigx, big_real(num), Mpfr_Rndn);
      if (mpfr_nan_p(big_real(num))) return(make_nan_with_payload(sc, __LINE__));
      if (mpfr_inf_p(big_real(num))) return(Real_Infinity);
      break;
    }
  return(NULL);
}

#define mpc_zero_p(Z) ((mpfr_zero_p(mpc_realref(Z))) && (mpfr_zero_p(mpc_imagref(Z))))

static s7_pointer any_number_to_mpc(s7_scheme *sc, s7_pointer num, mpc_t bigz)
{
  switch (type(num))
    {
    case T_INTEGER:
      mpc_set_si(bigz, integer(num), MPC_RNDNN);
      break;
    case T_RATIO:
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN);
      break;
    case T_REAL:
      if (is_NaN(real(num))) return(make_nan_with_payload(sc, __LINE__));
      if (is_inf(real(num))) return(Real_Infinity);
      mpc_set_d(bigz, real(num), MPC_RNDNN);
      break;
    case T_COMPLEX:
      if (is_NaN(imag_part(num))) return(Complex_NaN);
      if (is_NaN(real_part(num))) return(make_nan_with_payload(sc, __LINE__));
     mpc_set_d_d(bigz, real_part(num), imag_part(num), MPC_RNDNN);
      break;
    case T_BIG_INTEGER:
      mpc_set_z(bigz, big_integer(num), MPC_RNDNN);
      break;
    case T_BIG_RATIO:
      mpc_set_q(bigz, big_ratio(num), MPC_RNDNN);
      break;
    case T_BIG_REAL:
      mpc_set_fr(bigz, big_real(num), MPC_RNDNN);
      if (mpfr_nan_p(big_real(num))) return(make_nan_with_payload(sc, __LINE__));
      if (mpfr_inf_p(big_real(num))) return(Real_Infinity);
      break;
    case T_BIG_COMPLEX:
      if (mpfr_nan_p(mpc_imagref(big_complex(num)))) return(Complex_NaN);
      if (mpfr_nan_p(mpc_realref(big_complex(num)))) return(make_nan_with_payload(sc, __LINE__));
      mpc_set(bigz, big_complex(num), MPC_RNDNN);
      break;
    }
  return(NULL);
}

static s7_pointer make_big_complex(s7_scheme *sc, mpfr_t rl, mpfr_t im)
{
  /* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */
  s7_pointer new_bgc;
  new_cell(sc, new_bgc, T_BIG_COMPLEX);
  big_complex_bgc(new_bgc) = alloc_bigcmp(sc);
  add_big_complex(sc, new_bgc);
  mpc_set_fr_fr(big_complex(new_bgc), rl ,im, MPC_RNDNN);
  return(new_bgc);
}

static block_t *mpfr_to_string(s7_scheme *sc, mpfr_t val, int32_t radix)
{
  if (mpfr_zero_p(val))
    return(string_to_block(sc, "0.0", 3));
  if (mpfr_nan_p(val))
    return(string_to_block(sc, "+nan.0", 6));
  if (mpfr_inf_p(val))
    return((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0", 6) : string_to_block(sc, "-inf.0", 6));
  {
    mp_exp_t expptr;
    block_t *b = callocate(sc, sc->bignum_precision + 32);
    char *str = mpfr_get_str((char *)block_data(b), &expptr, radix, 0, val, Mpfr_Rndn);
    int32_t ep = (int32_t)expptr;
    s7_int i, len = safe_strlen(str);

    /* remove trailing 0's */
    for (i = len - 1; i > 3; i--)
      if (str[i] != '0')
	break;
    if (i < len - 1)
      str[i + 1] = '\0';
    {
      #define Btmp_Bufsize (len + 64)
      block_t *btmp = mallocate(sc, Btmp_Bufsize);
      if (str[0] == '-')
	snprintf((char *)block_data(btmp), Btmp_Bufsize, "-%c.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1);
      else snprintf((char *)block_data(btmp), Btmp_Bufsize, "%c.%s%c%d", str[0], (char *)(str + 1), (radix <= 10) ? 'E' : '@', ep - 1);
      liberate(sc, b);
      return(btmp);
    }}
}

static block_t *mpc_to_string(s7_scheme *sc, mpc_t val, int32_t radix, use_write_t use_write)
{
  block_t *rl, *im, *result;
  s7_int len;

  mpc_real(sc->mpfr_1, val, Mpfr_Rndn);
  rl = mpfr_to_string(sc, sc->mpfr_1, radix);
  mpc_imag(sc->mpfr_2, val, Mpfr_Rndn);
  im = mpfr_to_string(sc, sc->mpfr_2, radix);

  len = safe_strlen((char *)block_data(rl)) + safe_strlen((char *)block_data(im)) + 128;
  result = mallocate(sc, len);
  snprintf((char *)block_data(result), len, "%s%s%si",
	   (char *)block_data(rl),
	   ((((char *)block_data(im))[0] == '-') || (((char *)block_data(im))[0] == '+')) ? "" : "+", (char *)block_data(im));

  liberate(sc, rl);
  liberate(sc, im);
  return(result);
}

static block_t *big_number_to_string_with_radix(s7_scheme *sc, s7_pointer num, int32_t radix, s7_int width, s7_int *nlen, use_write_t use_write)
{
  block_t *str;
  switch (type(num))
    {
    case T_BIG_INTEGER:
      str = callocate(sc, mpz_sizeinbase(big_integer(num), radix) + 64);
      mpz_get_str((char *)block_data(str), radix, big_integer(num));
      break;
    case T_BIG_RATIO:
      mpz_set(sc->mpz_1, mpq_numref(big_ratio(num)));
      mpz_set(sc->mpz_2, mpq_denref(big_ratio(num)));
      str = callocate(sc, mpz_sizeinbase(sc->mpz_1, radix) + mpz_sizeinbase(sc->mpz_2, radix) + 64);
      mpq_get_str((char *)block_data(str), radix, big_ratio(num));
      break;
    case T_BIG_REAL:
      str = mpfr_to_string(sc, big_real(num), radix);
      break;
    default:
      str = mpc_to_string(sc, big_complex(num), radix, use_write);
      break;
    }
  if (width > 0)
    {
      const s7_int len = safe_strlen((char *)block_data(str));
      if (width > len)
	{
	  const int32_t spaces = width - len;
	  block_t *result = (block_t *)mallocate(sc, width + 1);
	  ((char *)block_data(result))[width] = '\0';
	  memmove((void *)((char *)block_data(result) + spaces), (void *)block_data(str), len);
	  local_memset((void *)block_data(result), (int)' ', spaces);
	  (*nlen) = width;
	  liberate(sc, str);
	  return(result);
	}
      (*nlen) = len;
    }
  else (*nlen) = safe_strlen((char *)block_data(str));
  return(str);
}

static s7_pointer string_to_big_integer(s7_scheme *sc, const char *str, int32_t radix)
{
  mpz_set_str(sc->mpz_4, (str[0] == '+') ? (const char *)(str + 1) : str, radix);
  return(mpz_to_integer(sc, sc->mpz_4));
}

static s7_pointer string_to_big_ratio(s7_scheme *sc, const char *str, int32_t radix)
{
  s7_pointer new_bgr;
  mpq_set_str(sc->mpq_1, str, radix);
  mpq_canonicalize(sc->mpq_1);
  if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
    return(mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
  new_cell(sc, new_bgr, T_BIG_RATIO);
  big_ratio_bgr(new_bgr) = alloc_bigrat(sc);
  add_big_ratio(sc, new_bgr);
  mpq_set(big_ratio(new_bgr), sc->mpq_1);
  return(new_bgr);
}

static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t radix)
{
  s7_pointer new_bgf;
  new_cell(sc, new_bgf, T_BIG_REAL);
  big_real_bgf(new_bgf) = alloc_bigflt(sc);
  add_big_real(sc, new_bgf);
  mpfr_set_str(big_real(new_bgf), str, radix, Mpfr_Rndn);
  return(new_bgf);
}

static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow);

static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int32_t radix)
{
  bool overflow = false;
  const s7_int val = string_to_integer(str, radix, &overflow);
  if (!overflow)
    return(make_integer(sc, val));
  return(string_to_big_integer(sc, str, radix));
}

static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const char *dstr, int32_t radix)
{
  bool overflow = false;
  /* gmp segfaults if passed a bignum/0 so this needs to check first that the denominator is not 0 before letting gmp screw up.
   *   Also, if the first character is '+', gmp returns 0!
   */
  const s7_int d = string_to_integer(dstr, radix, &overflow);
  if (!overflow)
    {
      s7_int n;
      if (d == 0) return(make_nan_with_payload(sc, __LINE__)); /* this NaN can end up as a hash-table key -- maybe the payload is confusing? */
      n = string_to_integer(nstr, radix, &overflow);
      if (!overflow)
	return(make_ratio(sc, n, d));
    }
  if (nstr[0] == '+')
    return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix));
  return(string_to_big_ratio(sc, nstr, radix));
}

static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow); /* gmp version */

static s7_pointer string_to_either_real(s7_scheme *sc, const char *str, int32_t radix)
{
  bool overflow = false;
  s7_double val = string_to_double_with_radix((char *)str, radix, &overflow);
  if (!overflow) return(make_real(sc, val));
  return(string_to_big_real(sc, str, radix));
}

static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, int32_t radix, s7_double *d_rl)
{
  bool overflow = false;
  /* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because
   *    its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968
   *    no matter what the bignum-precision.  But we can't just fallback on gmp's reader because (for example)
   *    it reads 1/2+i or 1+0/0i as 1.0.  Also format gets screwed up.  And string->number signals an error
   *    where it should return #f.  I wonder what to do.
   */
  if ((has_dec_point1) ||
      (ex1))
    {
      (*d_rl) = string_to_double_with_radix(q, radix, &overflow);
      if (overflow) return(string_to_big_real(sc, q, radix));
    }
  else
    {
      if (slash1)
	{
	  s7_int d, n = string_to_integer(q, radix, &overflow);  /* q can include the slash and denominator */
	  if (overflow) return(string_to_big_ratio(sc, q, radix));
	  d = string_to_integer(slash1, radix, &overflow);
	  if (overflow) return(string_to_big_ratio(sc, q, radix));
	  (*d_rl) = (s7_double)n / (s7_double)d;
	}
      else
	{
	  const s7_int val = string_to_integer(q, radix, &overflow);
	  if (overflow) return(string_to_big_integer(sc, q, radix));
	  (*d_rl) = (s7_double)val;
	}}
  if ((*d_rl) == -0.0) (*d_rl) = 0.0;
  return(NULL);
}

static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1,
					   char *plus, char *slash2, char *ex2, bool has_dec_point2,
					   int32_t radix, int32_t has_plus_or_minus)
{
  /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */
  double d_rl = 0.0, d_im = 0.0;
  const s7_pointer p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl);
  const s7_pointer p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im);

  if ((d_im == 0.0) &&                     /* 1.0+0.0000000000000000000000000000i */
      ((!p_im) || (is_zero(p_im))))
    return((p_rl) ? p_rl : make_real(sc, d_rl));
  if ((!p_rl) && (!p_im))
    return(make_complex_not_0i(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im));
  if (p_rl)
    any_real_to_mpfr(sc, p_rl, sc->mpfr_1);
  else mpfr_set_d(sc->mpfr_1, d_rl, Mpfr_Rndn);
  if (p_im)
    any_real_to_mpfr(sc, p_im, sc->mpfr_2);
  else mpfr_set_d(sc->mpfr_2, d_im, Mpfr_Rndn);
  if (has_plus_or_minus == -1)
    mpfr_neg(sc->mpfr_2, sc->mpfr_2, Mpfr_Rndn);
  return(make_big_complex(sc, sc->mpfr_1, sc->mpfr_2));
}

static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  /* either or both can be big here, but not neither, and types might not match at all */
  switch (type(x))
    {
    case T_INTEGER:
      return((is_t_big_integer(y)) && (mpz_cmp_si(big_integer(y), integer(x)) == 0));
    case T_BIG_INTEGER:
      if (is_t_big_integer(y)) return(mpz_cmp(big_integer(x), big_integer(y)) == 0);
      return((is_t_integer(y)) && (mpz_cmp_si(big_integer(x), integer(y)) == 0));
    case T_RATIO:
      if (!is_t_big_ratio(y)) return(false);
      mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
      return(mpq_equal(sc->mpq_1, big_ratio(y)));
    case T_BIG_RATIO:
      if (is_t_big_ratio(y)) return(mpq_equal(big_ratio(x), big_ratio(y)));
      if (!is_t_ratio(y)) return(false);
      mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
      return(mpq_equal(sc->mpq_1, big_ratio(x)));
    case T_REAL:
      if (is_NaN(real(x))) return(false);
      return((is_t_big_real(y)) && (!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0));
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x))) return(false);
      if (is_t_big_real(y)) return((!mpfr_nan_p(big_real(y))) && (mpfr_equal_p(big_real(x), big_real(y))));
      return((is_t_real(y)) && (!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0));
    case T_COMPLEX:
      if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x)))) return(false);
      if (!is_t_big_complex(y)) return(false);
      if ((mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y)))))
	return(false);
      mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
      return(mpc_cmp(sc->mpc_1, big_complex(y)) == 0);
    case T_BIG_COMPLEX:
      if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))))
	return(false);
      if (is_t_big_complex(y))
	{
	  if ((mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y)))))
	    return(false);
	  return(mpc_cmp(big_complex(x), big_complex(y)) == 0);
	}
      if (is_t_complex(y))
	{
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(false);
	  mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
	  return(mpc_cmp(big_complex(x), sc->mpc_1) == 0);
	}}
  return(false);
}

static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n)
{
  if (!mpz_fits_slong_p(n))
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "bigint does not fit in s7_int: ~S", 33), mpz_to_big_integer(sc, n)));
  return(mpz_get_si(n));
}
#endif

#ifndef HAVE_OVERFLOW_CHECKS
  #if ((defined(__clang__) && (!Pointer_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && (__GNUC__ >= 5)))
    #define HAVE_OVERFLOW_CHECKS 1
  #else
    #define HAVE_OVERFLOW_CHECKS 0
    #pragma message("no arithmetic overflow checks in this version of s7")
    /* these are untested */
    static bool add_overflow(s7_int A, s7_int B, s7_int *C) {*C = A + B; return(false);}        /* #define add_overflow(A, B, C) 0 */
    static bool subtract_overflow(s7_int A, s7_int B, s7_int *C) {*C = A - B; return(false);}   /* #define subtract_overflow(A, B, C) 0 */
    static bool multiply_overflow(s7_int A, s7_int B, s7_int *C) {*C = A * B; return(false);}   /* #define multiply_overflow(A, B, C) 0 */
  #endif
#endif
#define Have_Overflow_Checks HAVE_OVERFLOW_CHECKS

#if (defined(__clang__) && (!Pointer_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4)))
  #define subtract_overflow(A, B, C)       __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C)
  #define add_overflow(A, B, C)            __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C)
  #define multiply_overflow(A, B, C)       __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C)
  #define int32_add_overflow(A, B, C)      __builtin_sadd_overflow(A, B, C)
  #define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C)
#else
#if (defined(__GNUC__) && (__GNUC__ >= 5))
  #define subtract_overflow(A, B, C)       __builtin_sub_overflow(A, B, C)
  #define add_overflow(A, B, C)            __builtin_add_overflow(A, B, C)
  #define multiply_overflow(A, B, C)       __builtin_mul_overflow(A, B, C)
  #define int32_add_overflow(A, B, C)      __builtin_add_overflow(A, B, C)
  #define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
#endif
#endif

#if WITH_GCC
#define s7_int_abs(X) ({s7_int _X_ = X; _X_ >= 0 ? _X_ : -_X_;})
#else
#define s7_int_abs(X) ((X) >= 0 ? (X) : -(X))
#endif
/* can't use abs even in gcc -- it doesn't work with s7_ints! */

#if !__NetBSD__
  #define s7_fabsl(X) fabsl(X)
#else
  static s7_double s7_fabsl(long_double x) {return((signbit(x)) ? -x : x);}
#endif

/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */
static s7_double s7_round(double number) {return((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));}

#if Have_Complex_Numbers
#if __cplusplus
  #define _Complex_I (complex<s7_double>(0.0, 1.0))
  #define creal(X) Real(X)
  #define cimag(X) Imag(X)
  #define carg(X) arg(X)
  #define cabs(X) abs(X)
  #define csqrt(X) sqrt(X)
  #define cpow(X, Y) pow(X, Y)
  #define clog(X) log(X)
  #define cexp(X) exp(X)
  #define csin(X) sin(X)
  #define ccos(X) cos(X)
  #define ctan(X) tan(X)
  #define csinh(X) sinh(X)
  #define ccosh(X) cosh(X)
  #define ctanh(X) tanh(X)
  #define casin(X) asin(X)
  #define cacos(X) acos(X)
  #define catan(X) atan(X)
  #define casinh(X) asinh(X)
  #define cacosh(X) acosh(X)
  #define catanh(X) atanh(X)
#endif


#if !Have_Complex_Trig
#if __cplusplus

  static s7_complex ctan(s7_complex z)   {return(csin(z) / ccos(z));}
  static s7_complex ctanh(s7_complex z)  {return(csinh(z) / ccosh(z));}
  static s7_complex casin(s7_complex z)  {return(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));}
  static s7_complex cacos(s7_complex z)  {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));}
  static s7_complex catan(s7_complex z)  {return(s7_complex_i * clog((s7_complex_i + z) / (s7_complex_i - z)) / 2.0);}
  static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
  static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
  static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
#else

#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12)
static s7_complex clog(s7_complex z) {return(log(fabs(cabs(z))) + carg(z) * s7_complex_i);}
static s7_complex cpow(s7_complex x, s7_complex y)
{
  s7_double r = cabs(x);
  s7_double theta = carg(x);
  s7_double yre = creal(y);
  s7_double yim = cimag(y);
  s7_double nr = exp(yre * log(r) - yim * theta);
  s7_double ntheta = yre * theta + yim * log(r);
  return(nr * cos(ntheta) + (nr * sin(ntheta)) * s7_complex_i);
}
#endif
#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */
  static s7_complex cexp(s7_complex z) {return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * s7_complex_i);}
#endif

#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10)
  static s7_complex csin(s7_complex z)   {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * s7_complex_i);}
  static s7_complex ccos(s7_complex z)   {return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * s7_complex_i);}
  static s7_complex csinh(s7_complex z)  {return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * s7_complex_i);}
  static s7_complex ccosh(s7_complex z)  {return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * s7_complex_i);}
  static s7_complex ctan(s7_complex z)   {return(csin(z) / ccos(z));}
  static s7_complex ctanh(s7_complex z)  {return(csinh(z) / ccosh(z));}
  static s7_complex casin(s7_complex z)  {return(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));}
  static s7_complex cacos(s7_complex z)  {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));}
  static s7_complex catan(s7_complex z)  {return(s7_complex_i * clog((s7_complex_i + z) / (s7_complex_i - z)) / 2.0);}
  static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
  static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
#endif /* not FreeBSD 10 */
#endif /* not c++ */
#endif /* not Have_Complex_Trig */

#else  /* not Have_Complex_Numbers */
  #define _Complex_I 1.0
  #define creal(X) 0.0
  #define cimag(X) 0.0
  #define csin(X) sin(X)
  #define casin(X) X
  #define ccos(X) cos(X)
  #define cacos(X) X
  #define ctan(X) X
  #define catan(X) X
  #define csinh(X) X
  #define casinh(X) X
  #define ccosh(X) X
  #define cacosh(X) X
  #define ctanh(X) X
  #define catanh(X) X
  #define cexp(X) exp(X)
  #define cpow(X, Y) pow(X, Y)
  #define clog(X) log(X)
  #define csqrt(X) sqrt(X)
  #define conj(X) X
#endif

#ifdef __OpenBSD__
  /* openbsd's builtin versions of these functions are not usable */
  static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
  static s7_complex cacosh_1(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
#endif
#ifdef __NetBSD__
  static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
#endif

bool s7_is_number(s7_pointer p)   {return(is_number(p));}
bool s7_is_complex(s7_pointer p)  {return(is_number(p));}
bool s7_is_real(s7_pointer p)     {return(is_real(p));}
bool s7_is_rational(s7_pointer p) {return(is_rational(p));}

bool s7_is_integer(s7_pointer p)
{
#if With_Gmp
  return((is_t_integer(p)) || (is_t_big_integer(p)));
#else
  return(is_t_integer(p));
#endif
}

bool s7_is_ratio(s7_pointer p)
{
#if With_Gmp
  return((is_t_ratio(p)) || (is_t_big_ratio(p)));
#else
  return(is_t_ratio(p));
#endif
}

static s7_int c_gcd_1(s7_int u, s7_int v)
{
  /* can't take abs of these so do it by hand */
  s7_int divisor = 1;
  if (u == v) return(u);
  while (((u & 1) == 0) && ((v & 1) == 0))
    {
      u /= 2;
      v /= 2;
      divisor *= 2;
    }
  return(divisor);
}

static s7_int c_gcd(s7_int u, s7_int v)
{
  /* #if __cplusplus\n return std::gcd(u, v);\n #else... but this requires #include <algorithm> (else gcd is not defined in std::)
   *   and C++'s gcd returns negative results sometimes -- isn't gcd defined to be positive?  std::gcd is ca 25% faster than the code below.
   */
  s7_int a, b;
  if (u < 0)
    {
      if (u == s7_Int64_Min) return(c_gcd_1(u, v));
      a = -u;
    }
  else a = u;
  if (v < 0)
    {
      if (v == s7_Int64_Min) return(c_gcd_1(u, v));
      b = -v;
    }
  else b = v;
  while (b != 0)
    {
      s7_int temp = a % b;
      a = b;
      b = temp;
    }
  return(a);
}

#define Rationalize_Limit 1.0e12

static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int *denom)
{
  /* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" (available online) */
  double x0, x1;
  s7_int i, p0, q0 = 1, p1, q1 = 1;
  double e0, e1, e0p, e1p;
  int32_t tries = 0;
  /* don't use long_double: the loop below will hang */

  /* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below
   *   it turns into most-negative-fixnum.  1e19 is trouble in many places.
   */
  if (fabs(ux) > Rationalize_Limit)
    {
      /* (rationalize most-positive-fixnum) should not return most-negative-fixnum
       *   but any number > 1e14 here is so inaccurate that rationalize is useless
       *   for example,
       *     default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4
       *     gmp:     (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111
       * can't return false here because that confuses some of the callers!
       */
      (*numer) = (s7_int)ux;
      (*denom) = 1;
      return(true);
    }

  if (error < 0.0) error = -error;
  x0 = ux - error;
  x1 = ux + error;
  i = (s7_int)ceil(x0);

  if (error >= 1.0) /* aw good grief! */
    {
      if (x0 < 0.0)
	(*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0;
      else (*numer) = i;
      (*denom) = 1;
      return(true);
    }
  if (x1 >= i)
    {
      (*numer) = (i >= 0) ? i : (s7_int)floor(x1);
      (*denom) = 1;
      return(true);
    }

  p0 = (s7_int)floor(x0);
  p1 = (s7_int)ceil(x1);
  e0 = p1 - x0;
  e1 = x0 - p0;
  e0p = p1 - x1;
  e1p = x1 - p0;
  while (true)
    {
      s7_int old_p1, old_q1;
      double old_e0, old_e1, old_e0p, r, r1;
      const double val = (double)p0 / (double)q0;

      if (((x0 <= val) && (val <= x1)) || (e1 == 0.0) || (e1p == 0.0) || (tries > 100))
	{
	  if ((q0 == s7_Int64_Min) && (p0 == 1)) /* (rationalize 1.000000004297917e-12) when error is 1e-12 */
	    {
	      (*numer) = 0;
	      (*denom) = 1;
	    }
	  else
	    {
	      (*numer) = p0;
	      (*denom) = q0;
	      if ((s7_Debugging) && (q0 == 0)) fprintf(stderr, "%s[%d]: %f %" ld64 "/0\n", __func__, __LINE__, ux, p0);
	    }
	  if ((s7_Debugging) && (*denom < 0)) fprintf(stderr, "%s[%d]: denominator is %" ld64 "?\n", __func__, __LINE__, *denom);
	  return(true);
	}
      tries++;
      r = (s7_int)floor(e0 / e1);
      r1 = (s7_int)ceil(e0p / e1p);
      if (r1 < r) r = r1;
      /* do handles all step vars in parallel */
      old_p1 = p1;
      p1 = p0;
      old_q1 = q1;
      q1 = q0;
      old_e0 = e0;
      e0 = e1p;
      old_e0p = e0p;
      e0p = e1;
      old_e1 = e1;
      p0 = old_p1 + r * p0;
      q0 = old_q1 + r * q0;
      e1 = old_e0p - r * e1p;  /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */
      e1p = old_e0 - r * old_e1;
    }
  return(false);
}

s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error)
{
  s7_int numer = 0, denom = 1;
  if (c_rationalize(x, error, &numer, &denom))
    return(make_simpler_ratio_or_integer(sc, numer, denom));
  return(make_real(sc, x));
}

s7_pointer s7_make_integer(s7_scheme *sc, s7_int n)
{
  s7_pointer new_int;
  if (is_small_int(n))
    return(small_int(n));
  new_cell(sc, new_int, T_INTEGER);
  set_integer(new_int, n);
  return(new_int);
}

#if s7_Debugging
#define make_mutable_integer(Sc, N) make_mutable_integer_1(Sc, N, __func__, __LINE__)
static s7_pointer make_mutable_integer_1(s7_scheme *sc, s7_int n, const char *func, int line)
#else
static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n)
#endif
{
  s7_pointer new_int;
  new_cell(sc, new_int, T_INTEGER | T_Mutable);
#if s7_Debugging
  new_int->carrier_line = __LINE__;
  new_int->gc_line = line;
  new_int->gc_func = func;
#endif
  set_integer(new_int, n);
  return(new_int);
}

s7_pointer s7_make_real(s7_scheme *sc, s7_double n)
{
  s7_pointer x;
  new_cell(sc, x, T_REAL);
  set_real(x, n);
  return(x);
}

#if s7_Debugging
#define make_mutable_real(Sc, N) make_mutable_real_1(Sc, N, __func__, __LINE__)
static s7_pointer make_mutable_real_1(s7_scheme *sc, s7_double n, const char *func, int line)
{
  s7_pointer x;
  new_cell(sc, x, T_REAL | T_Mutable);
  x->carrier_line = __LINE__;
  x->gc_line = line;
  x->gc_func = func;
  set_real(x, n);
  return(x);
}
#else
#define make_mutable_real(Sc, N) s7_make_mutable_real(Sc, N)
#endif

s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n)
{
  s7_pointer x;
  new_cell(sc, x, T_REAL | T_Mutable);
  set_real(x, n);
  return(x);
}

s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b)
{
  s7_pointer x;
  if (b == 0.0)
    {
      new_cell(sc, x, T_REAL);
      set_real(x, a);
      return(x);
    }
  new_cell(sc, x, T_COMPLEX);
  set_real_part(x, a);
  set_imag_part(x, b);
  return(x);
}

static s7_pointer make_mutable_complex(s7_scheme *sc, s7_double rl, s7_double im)
{
  s7_pointer x;
  new_cell(sc, x, T_COMPLEX | T_Mutable); /* do we need to change to real if imag==0? */
  set_real_part(x, rl);
  set_imag_part(x, im);
  return(x);
}

static s7_complex s7_to_c_complex(s7_pointer z)
{
#if Have_Complex_Numbers
  return(CMPLX(s7_real_part(z), s7_imag_part(z)));
#else
  return(0.0);
#endif
}

static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));}

static no_return void division_by_zero_error_1_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x)
{
  error_nr(sc, sc->division_by_zero_symbol,
	   set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x));
}

static no_return void division_by_zero_error_2_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x, s7_pointer y)
{
  error_nr(sc, sc->division_by_zero_symbol,
	   set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y));
}

static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b)
{
  if (b < 0)
    {
      if (b == s7_Int64_Min)
	{
	  /* This should not trigger an error during reading -- we might have the
	   *   ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance.
	   */
	  /* if (a == b) return(Int_One); */
	  if (a & 1)
	    return(make_real(sc, (long_double)a / (long_double)b));
	  a /= 2;
	  b /= 2;
	}
      if (a == s7_Int64_Min)
	{
	  if (b & 1)
	    return(make_real(sc, (long_double)a / (long_double)b));
	  a /= 2;
	  b /= 2;
	}
      a = -a;
      b = -b;
    }
  if (a == s7_Int64_Min)
    {
      while (((a & 1) == 0) && ((b & 1) == 0))
	{
	  a /= 2;
	  b /= 2;
	}}
  else
    {
      s7_int b1 = b, divisor = s7_int_abs(a);
      do {
	s7_int temp = divisor % b1;
	divisor = b1;
	b1 = temp;
      } while (b1 != 0);
      if (divisor != 1)
	{
	  a /= divisor;
	  b /= divisor;
	}}
  if (b == 1)
    return(make_integer(sc, a));
  {
    s7_pointer new_rat;
    new_cell(sc, new_rat, T_RATIO);
    set_numerator(new_rat, a);
    set_denominator(new_rat, b);
    return(new_rat);
  }
}

/* using make_ratio here is a desperate kludge trying to maintain backwards compatibility; internally we use make_ratio_with_div_check below */
s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b)
{
  if (b == 0)
    division_by_zero_error_2_nr(sc, wrap_string(sc, "s7_make_ratio", 13), wrap_integer(sc, a), Int_Zero);
  return(make_ratio(sc, a, b));
}

static s7_pointer make_ratio_with_div_check(s7_scheme *sc, s7_pointer caller, s7_int a, s7_int b)
{
  if (b == 0)
    division_by_zero_error_2_nr(sc, caller, wrap_integer(sc, a), Int_Zero);
  return(make_ratio(sc, a, b));
}


#define With_Overflow_Error true
#define Without_Overflow_Error false

#define Int64_To_Double_Limit (1LL << 53)
#define Double_To_Int64_Limit (1LL << 53)

/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16
 *   (ceiling (+ 1e16 1)) -> 10000000000000000
 *   (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles
 * but we can't fix this except in the gmp case because:
 *   (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1)
 *   (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1)
 *   (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again
 * i.e. the bits are identical.  We can't even detect when it has happened (without tedious effort), so should
 *   we just give an error for any floor (or whatever) of an arg>1e16?  (sin has a similar problem)?
 *   I think in the non-gmp case I'll throw an error in these cases because the results are bogus:
 *   (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904
 *   (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928
 * another case at the edge: (round 9007199254740992.51) -> 9007199254740992
 * This spells trouble for normal arithmetic in this range.  If no gmp,
 *    (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0)
 *    but we don't currently give an error in this case -- not sure what the right thing is.
 */

s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller)
{
  if (is_t_real(x)) return(real(x));
  switch (type(x))
    {
    case T_INTEGER:     return((s7_double)integer(x));
    case T_RATIO:       return(fraction(x));
#if With_Gmp
    case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x)));
    case T_BIG_RATIO:   return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) /
					   (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x)))));
    case T_BIG_REAL:    return((s7_double)mpfr_get_d(big_real(x), Mpfr_Rndn));
#endif
    default:
      sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_REAL]);
    }
  return(0.0);
}

s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller)
{
  if (is_t_real(x)) return(real(x));
  switch (type(x))
    {
    case T_INTEGER:     return((s7_double)integer(x));
    case T_RATIO:       return(fraction(x));
#if With_Gmp
    case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x)));
    case T_BIG_RATIO:   return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) /
					   (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x)))));
    case T_BIG_REAL:    return((s7_double)mpfr_get_d(big_real(x), Mpfr_Rndn));
#endif
    default:
      sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]);
    }
  return(0.0);
}

s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x) {return(s7_number_to_real_with_location(sc, x, sc->number_to_real_symbol));}

s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller)
{
  if (is_t_integer(x)) return(integer(x));
#if With_Gmp
  if (is_t_big_integer(x)) return(big_integer_to_s7_int(sc, big_integer(x)));
#endif
  sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]);
  return(0);
}

s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x) {return(s7_number_to_integer_with_caller(sc, x, "s7_number_to_integer"));}

s7_int s7_numerator(s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:     return(integer(x));
    case T_RATIO:       return(numerator(x));
#if With_Gmp
    case T_BIG_INTEGER: return(mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */
    case T_BIG_RATIO:   return(mpz_get_si(mpq_numref(big_ratio(x))));
#endif
    }
  return(0);
}

s7_int s7_denominator(s7_pointer x)
{
  if (is_t_ratio(x)) return(denominator(x));
#if With_Gmp
  if (is_t_big_ratio(x)) return(mpz_get_si(mpq_denref(big_ratio(x))));
#endif
  return(1);
}

s7_int s7_integer(s7_pointer p)
{
  if (is_t_integer(p)) return(integer(p));
#if With_Gmp
  if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p)));
#endif
  return(0);
}

s7_double s7_real(s7_pointer x)
{
  if (is_t_real(x)) return(real(x));
  switch (type(x))
    {
    case T_RATIO:       return(fraction(x));
    case T_INTEGER:     return((s7_double)integer(x));
#if With_Gmp
    case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x)));
    case T_BIG_REAL:    return((s7_double)mpfr_get_d(big_real(x), Mpfr_Rndn));
    case T_BIG_RATIO:
      {
	s7_double result;
	mpfr_t bx;
	mpfr_init2(bx, Default_Bignum_Precision);
	mpfr_set_q(bx, big_ratio(x), Mpfr_Rndn);
	result = mpfr_get_d(bx, Mpfr_Rndn);
	mpfr_clear(bx);
	return(result);
      }
#endif
    }
  return(0.0);
}

static bool is_one(s7_pointer x)
{
  return(((is_t_integer(x)) && (integer(x) == 1)) ||
	 ((is_t_real(x)) && (real(x) == 1.0)));
}


/* -------- optimize exponents -------- */

#define Max_Pow 64 /* faster startup if 32, but much slower in tbig; also waiting until use to init_pows is faster at startup, but slower in tbig */
static s7_double **pepow = NULL; /* [17][Max_Pow * 2]; */

static void init_pows(void)
{
  pepow = (double **)Malloc(17 * sizeof(double *));
  pepow[0] = NULL;
  pepow[1] = NULL;
  for (int32_t i = 2; i < 17; i++) pepow[i] = (double *)Malloc((Max_Pow * 2) * sizeof(double));
  for (int32_t i = 2; i < 17; i++)               /* radix between 2 and 16 */
    for (int32_t j = -Max_Pow; j < Max_Pow; j++) /* saved exponent between 0 and +/- Max_Pow */
      pepow[i][j + Max_Pow] = pow((double)i, (double)j);
}

static inline double dpow(int32_t x, int32_t y)
{
  if ((y >= Max_Pow) || (y < -Max_Pow)) /* this can happen */
    return(pow((double)x, (double)y));
  return(pepow[x][y + Max_Pow]);
}


/* -------------------------------- number->string -------------------------------- */
#ifndef WITH_DTOA
  #define WITH_DTOA 1
#endif
/* there was a time when libc was so slow that this code was mandatory, but now (Oct-2024) the difference is smaller (still a ca. factor of 4):
 *   in tbig/callgrind with dtoa 6254M, with C's printf stuff instead 24410M
 */

#if WITH_DTOA
/* fpconv, revised to fit the local coding style

   The MIT License

Copyright (c) 2013 Andreas Samoljuk

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/

#define dtoa_npowers     87
#define dtoa_steppowers  8
#define dtoa_firstpower -348 /* 10 ^ -348 */
#define dtoa_expmax     -32
#define dtoa_expmin     -60

typedef struct dtoa_np {uint64_t frac; int32_t exp;} dtoa_np;

static const dtoa_np dtoa_powers_ten[] = {
    { 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 }, { 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 },
    { 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 }, { 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 },
    { 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 }, { 15227053142812498563U, -954 },  { 11345038669416679861U, -927 },
    { 16905424996341287883U, -901 },  { 12595523146049147757U, -874 }, { 9384396036005875287U,  -847 },  { 13983839803942852151U, -821 },
    { 10418772551374772303U, -794 },  { 15525180923007089351U, -768 }, { 11567161174868858868U, -741 },  { 17236413322193710309U, -715 },
    { 12842128665889583758U, -688 },  { 9568131466127621947U,  -661 }, { 14257626930069360058U, -635 },  { 10622759856335341974U, -608 },
    { 15829145694278690180U, -582 },  { 11793632577567316726U, -555 }, { 17573882009934360870U, -529 },  { 13093562431584567480U, -502 },
    { 9755464219737475723U,  -475 },  { 14536774485912137811U, -449 }, { 10830740992659433045U, -422 },  { 16139061738043178685U, -396 },
    { 12024538023802026127U, -369 },  { 17917957937422433684U, -343 }, { 13349918974505688015U, -316 },  { 9946464728195732843U,  -289 },
    { 14821387422376473014U, -263 },  { 11042794154864902060U, -236 }, { 16455045573212060422U, -210 },  { 12259964326927110867U, -183 },
    { 18268770466636286478U, -157 },  { 13611294676837538539U, -130 }, { 10141204801825835212U, -103 },  { 15111572745182864684U, -77 },
    { 11258999068426240000U, -50 },   { 16777216000000000000U, -24 }, { 12500000000000000000U,   3 },   { 9313225746154785156U,   30 },
    { 13877787807814456755U,  56 },   { 10339757656912845936U,  83 }, { 15407439555097886824U, 109 },   { 11479437019748901445U, 136 },
    { 17105694144590052135U, 162 },   { 12744735289059618216U, 189 }, { 9495567745759798747U,  216 },   { 14149498560666738074U, 242 },
    { 10542197943230523224U, 269 },   { 15709099088952724970U, 295 }, { 11704190886730495818U, 322 },   { 17440603504673385349U, 348 },
    { 12994262207056124023U, 375 },   { 9681479787123295682U,  402 }, { 14426529090290212157U, 428 },   { 10748601772107342003U, 455 },
    { 16016664761464807395U, 481 },   { 11933345169920330789U, 508 }, { 17782069995880619868U, 534 },   { 13248674568444952270U, 561 },
    { 9871031767461413346U,  588 },   { 14708983551653345445U, 614 }, { 10959046745042015199U, 641 },   { 16330252207878254650U, 667 },
    { 12166986024289022870U, 694 },   { 18130221999122236476U, 720 }, { 13508068024458167312U, 747 },   { 10064294952495520794U, 774 },
    { 14996968138956309548U, 800 },   { 11173611982879273257U, 827 }, { 16649979327439178909U, 853 },   { 12405201291620119593U, 880 },
    { 9242595204427927429U,  907 },   { 13772540099066387757U, 933 }, { 10261342003245940623U, 960 },   { 15290591125556738113U, 986 },
    { 11392378155556871081U, 1013 },  { 16975966327722178521U, 1039 },
    { 12648080533535911531U, 1066 }};

static dtoa_np dtoa_find_cachedpow10(int exp, int *k)
{
  const double one_log_ten = 0.30102999566398114;
  const int32_t approx = -(exp + dtoa_npowers) * one_log_ten;
  int32_t idx = (approx - dtoa_firstpower) / dtoa_steppowers;
  while (true)
    {
      int32_t current = exp + dtoa_powers_ten[idx].exp + 64;
      if (current < dtoa_expmin)
	{
	  idx++;
	  continue;
        }
      if (current > dtoa_expmax)
	{
	  idx--;
	  continue;
        }
      *k = (dtoa_firstpower + idx * dtoa_steppowers);
      return(dtoa_powers_ten[idx]);
    }
}

#define dtoa_fracmask  0x000FFFFFFFFFFFFFU
#define dtoa_expmask   0x7FF0000000000000U
#define dtoa_hiddenbit 0x0010000000000000U
#define dtoa_signmask  0x8000000000000000U
#define dtoa_expbias   (1023 + 52)
#define dtoa_absv(N)   ((N) < 0 ? -(N) : (N))
#define dtoa_minv(A, B) ((A) < (B) ? (A) : (B))

static uint64_t dtoa_tens[] =
  { 10000000000000000000U, 1000000000000000000U, 100000000000000000U,
    10000000000000000U, 1000000000000000U, 100000000000000U,
    10000000000000U, 1000000000000U, 100000000000U,
    10000000000U, 1000000000U, 100000000U,
    10000000U, 1000000U, 100000U,
    10000U, 1000U, 100U,
    10U, 1U};

static uint64_t dtoa_get_dbits(double d)
{
  union {double dbl; uint64_t i;} dbl_bits = {d};
  return(dbl_bits.i);
}

static dtoa_np dtoa_build_np(double d)
{
  const uint64_t bits = dtoa_get_dbits(d);
  dtoa_np fp;
  fp.frac = bits & dtoa_fracmask;
  fp.exp = (bits & dtoa_expmask) >> 52;
  if (fp.exp)
    {
      fp.frac += dtoa_hiddenbit;
      fp.exp -= dtoa_expbias;
    }
  else fp.exp = -dtoa_expbias + 1;
  return(fp);
}

static void dtoa_normalize(dtoa_np *fp)
{
  const int32_t shift = 64 - 52 - 1;
  while ((fp->frac & dtoa_hiddenbit) == 0)
    {
      fp->frac <<= 1;
      fp->exp--;
    }
  fp->frac <<= shift;
  fp->exp -= shift;
}

static void dtoa_get_normalized_boundaries(dtoa_np *fp, dtoa_np *lower, dtoa_np *upper)
{
  int32_t u_shift, l_shift;
  upper->frac = (fp->frac << 1) + 1;
  upper->exp  = fp->exp - 1;
  while ((upper->frac & (dtoa_hiddenbit << 1)) == 0)
    {
      upper->frac <<= 1;
      upper->exp--;
    }
  u_shift = 64 - 52 - 2;
  upper->frac <<= u_shift;
  upper->exp = upper->exp - u_shift;
  l_shift = (fp->frac == dtoa_hiddenbit) ? 2 : 1;
  lower->frac = (fp->frac << l_shift) - 1;
  lower->exp = fp->exp - l_shift;
  lower->frac <<= lower->exp - upper->exp;
  lower->exp = upper->exp;
}

static dtoa_np dtoa_multiply(dtoa_np *a, dtoa_np *b) /* const dtoa_np* here and elsewhere is slower!  perverse */
{
  dtoa_np fp;
  const uint64_t lomask = 0x00000000FFFFFFFF;
  const uint64_t ah_bl = (a->frac >> 32)    * (b->frac & lomask);
  const uint64_t al_bh = (a->frac & lomask) * (b->frac >> 32);
  const uint64_t al_bl = (a->frac & lomask) * (b->frac & lomask);
  const uint64_t ah_bh = (a->frac >> 32)    * (b->frac >> 32);
  uint64_t tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32);
  /* round up */
  tmp += 1U << 31;
  fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32);
  fp.exp = a->exp + b->exp + 64;
  return(fp);
}

static void dtoa_round_digit(char *digits, int32_t ndigits, uint64_t delta, uint64_t rem, uint64_t kappa, uint64_t frac)
{
  while ((rem < frac) && (delta - rem >= kappa) &&
	 ((rem + kappa < frac) || (frac - rem > rem + kappa - frac)))
    {
      digits[ndigits - 1]--;
      rem += kappa;
    }
}

static int32_t dtoa_generate_digits(dtoa_np *fp, dtoa_np *upper, dtoa_np *lower, char *digits, int *K)
{
  uint64_t part1, part2, delta = upper->frac - lower->frac;
  const uint64_t wfrac = upper->frac - fp->frac;
  uint64_t *unit;
  int32_t idx = 0, kappa = 10;
  dtoa_np one;

  one.frac = 1ULL << -upper->exp;
  one.exp  = upper->exp;
  part1 = upper->frac >> -one.exp;
  part2 = upper->frac & (one.frac - 1);

  /* 1000000000 */
  for (uint64_t *divp = dtoa_tens + 10; kappa > 0; divp++)
    {
      uint64_t tmp, div = *divp;
      unsigned digit = part1 / div;
      if (digit || idx)
	digits[idx++] = digit + '0';
      part1 -= digit * div;
      kappa--;
      tmp = (part1 << -one.exp) + part2;
      if (tmp <= delta)
	{
	  *K += kappa;
	  dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, wfrac);
	  return(idx);
        }}

  /* 10 */
  unit = dtoa_tens + 18;
  while(true)
    {
      unsigned digit;
      part2 *= 10;
      delta *= 10;
      kappa--;
      digit = part2 >> -one.exp;
      if (digit || idx)
	digits[idx++] = digit + '0';
      part2 &= one.frac - 1;
      if (part2 < delta)
	{
	  *K += kappa;
	  dtoa_round_digit(digits, idx, delta, part2, one.frac, wfrac * *unit);
	  return(idx);
	}
      unit--;
    }
}

static int32_t dtoa_grisu2(double d, char *digits, int *K)
{
  int32_t k;
  dtoa_np cp, lower, upper;
  dtoa_np w = dtoa_build_np(d);
  dtoa_get_normalized_boundaries(&w, &lower, &upper);
  dtoa_normalize(&w);
  cp = dtoa_find_cachedpow10(upper.exp, &k);
  w = dtoa_multiply(&w, &cp);
  upper = dtoa_multiply(&upper, &cp);
  lower = dtoa_multiply(&lower, &cp);
  lower.frac++;
  upper.frac--;
  *K = -k;
  return(dtoa_generate_digits(&w, &upper, &lower, digits, K));
}

static int32_t dtoa_emit_digits(char *digits, int32_t ndigits, char *dest, int32_t K, bool neg)
{
  int32_t idx, cent;
  char sign;
  int32_t exp = dtoa_absv(K + ndigits - 1);

  /* write plain integer */
  if ((K >= 0) && (exp < (ndigits + 7)))
    {
      memcpy(dest, digits, ndigits);
      local_memset(dest + ndigits, '0', K); /* unaligned */
      dest[ndigits + K] = '.';
      dest[ndigits + K + 1] = '0';
      return(ndigits + K + 2);
    }

  /* write decimal w/o scientific notation */
  if ((K < 0) && (K > -7 || exp < 4))
    {
      int32_t offset = ndigits - dtoa_absv(K);
      /* fp < 1.0 -> write leading zero */
      if (offset <= 0)
	{
	  offset = -offset;
	  dest[0] = '0';
	  dest[1] = '.';
	  local_memset(dest + 2, '0', offset); /* unaligned */
	  memcpy(dest + offset + 2, digits, ndigits);
	  return(ndigits + 2 + offset);
	  /* fp > 1.0 */
	}
      else
	{
	  memcpy(dest, digits, offset);
	  dest[offset] = '.';
	  memcpy(dest + offset + 1, digits + offset, ndigits - offset);
	  return(ndigits + 1);
	}}

  /* write decimal w/ scientific notation */
  ndigits = dtoa_minv(ndigits, 18 - neg);
  idx = 0;
  dest[idx++] = digits[0];
  if (ndigits > 1)
    {
      dest[idx++] = '.';
      memcpy(dest + idx, digits + 1, ndigits - 1);
      idx += ndigits - 1;
    }
  dest[idx++] = 'e';
  sign = K + ndigits - 1 < 0 ? '-' : '+';
  dest[idx++] = sign;
  cent = 0;
  if (exp > 99)
    {
      cent = exp / 100;
      dest[idx++] = cent + '0';
      exp -= cent * 100;
    }
  if (exp > 9)
    {
      int32_t dec = exp / 10;
      dest[idx++] = dec + '0';
      exp -= dec * 10;
    }
  else
    if (cent)
      dest[idx++] = '0';

  dest[idx++] = exp % 10 + '0';
  return(idx);
}

static int32_t dtoa_filter_special(double fp, char *dest, bool neg)
{
  uint64_t bits;
  bool nan;
  if (fp == 0.0)
    {
      dest[0] = '0'; dest[1] = '.'; dest[2] = '0';
      return(3);
    }
  bits = dtoa_get_dbits(fp);
  nan = (bits & dtoa_expmask) == dtoa_expmask;
  if (!nan) return(0);

  if (!neg)
    {
      dest[0] = '+'; /* else 1.0-nan...? */
      dest++;
    }
  if (bits & dtoa_fracmask)
    {
      s7_int payload = nan_payload(fp);
      int32_t len = (int32_t)snprintf(dest, 22, "nan.%" ld64, payload); /* dest size = 23, below */
      return((neg) ? len : len + 1);
    }
  dest[0] = 'i'; dest[1] = 'n'; dest[2] = 'f'; dest[3] = '.'; dest[4] = '0';
  return((neg) ? 5 : 6);
}

static inline int32_t fpconv_dtoa(double d, char dest[24])
{
  char digit[23];
  int32_t str_len = 0, spec, K, ndigits;
  bool neg = false;

  if (dtoa_get_dbits(d) & dtoa_signmask)
    {
      dest[0] = '-';
      str_len++;
      neg = true;
    }
  spec = dtoa_filter_special(d, dest + str_len, neg);
  if (spec) return(str_len + spec);
  K = 0;
  ndigits = dtoa_grisu2(d, digit, &K);
  str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg);
  return(str_len);
}
#endif


/* -------------------------------- number->string -------------------------------- */
static const char dignum[] = "0123456789abcdef";

static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix)  /* called by number_to_string_with_radix */
{
  s7_int i, len, end;
  const bool sign = (n < 0);
  s7_int pown;

  if ((radix < 2) || (radix > 16))
    return(0);
  if (sign)
    {
      if (n == s7_Int64_Min) /* can't negate this, so do it by hand */
	{
	  static const char *mnfs[17] = {"","",
					 "-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222",
					 "-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212",
					 "-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828", "-9223372036854775808",
					 "-1728002635214590698", "-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808",
					 "-8000000000000000"};
	  len = safe_strlen(mnfs[radix]);
	  memcpy((void *)p, (const void *)mnfs[radix], len);
	  p[len] = '\0';
	  return(len);
	}
      n = -n;
    }
  /* the previous version that counted up to n, rather than dividing down below n, as here, could be confused by large ints on 64 bit machines  */
  pown = n;
  for (i = 1; i < 100; i++)
    {
      if (pown < radix)
	break;
      pown /= (s7_int)radix;
    }
  len = i - 1;
  if (sign) len++;
  end = 0;
  if (sign)
    {
      p[0] = '-';
      end++;
    }
  for (i = len; i >= end; i--)
    {
      p[i] = dignum[n % radix];
      n /= radix;
    }
  p[len + 1] = '\0';
  return(len + 1);
}

static const char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) /* do not free the returned string */
{
  char *p, *op;
  const bool sign = (num < 0);
  if (sign)
    {
      if (num == s7_Int64_Min)
	{
	  (*nlen) = 20;
	  return((const char *)"-9223372036854775808");
	}
      num = -num;  /* we need a positive index below */
    }
  p = (char *)(sc->int_to_str1 + Int_To_Str_Size - 1);
  op = p;
  *p-- = '\0';
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  if (sign)
    {
      *p = '-';
      (*nlen) = op - p;
      return(p);
    }
  (*nlen) = op - p - 1;
  return(++p);
}

static const char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */
{
  char *p;
  const bool sign = (num < 0);
  if (sign)
    {
      if (num == s7_Int64_Min)
	return("-9223372036854775808");
      num = -num;
    }
  p = (char *)(sc->int_to_str2 + Int_To_Str_Size - 1);
  *p-- = '\0';
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  if (sign)
    {
      *p = '-';
      return(p);
    }
  return(++p);
}

static char *floatify(char *str, s7_int *nlen)
{
  if ((!strchr(str, '.')) && (!strchr(str, 'e'))) /* faster than (strcspn(str, ".e") >= (size_t)(*nlen)) */
    {
      s7_int len = *nlen;
      /* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */
      if (len == 3)
	{
	  if (str[0] == 'n')
	    {
	      str[0] = '+'; str[1] = 'n'; str[2] = 'a'; str[3] = 'n'; /* need to retain 'str' as output */
	      len = 4;
	    }
	  else
	    if (str[0] == 'i')
	      {
		str[0] = '+'; str[1] = 'i'; str[2] = 'n'; str[3] = 'f';
		len = 4;
	      }}
      str[len]='.';
      str[len + 1]='0';
      str[len + 2]='\0';
      (*nlen) = len + 2;
    }
  return(str);
}

static void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len)
{
  const s7_int spaces = width - len;
  if (width >= sc->num_to_str_size)
    {
      sc->num_to_str_size = width + 1;
      sc->num_to_str = (char *)Realloc(sc->num_to_str, sc->num_to_str_size);
    }
  sc->num_to_str[width] = '\0';
  memmove((void *)(sc->num_to_str + spaces), (const void *)src, len);
  local_memset((void *)(sc->num_to_str), (int)' ', spaces);
}

static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision,
				      char float_choice, s7_int *nlen, use_write_t choice) /* don't free result */
{
  /* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */
  /* the rest of s7 assumes nlen is set to the correct length
   *   a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small.
   *   but then even worse: (format #f "~F" 1e308+1e308i)!
   */
  s7_int len = width + precision;
  len = (len > 512) ? (512 + 2 * len) : 1024;
  if (len > sc->num_to_str_size)
    {
      sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len);
      sc->num_to_str_size = len;
    }

  /* bignums can't happen here */
  if ((s7_Debugging) && (is_big_number(obj))) fprintf(stderr, "%s[%d]: we got a bignum: %s\n", __func__, __LINE__, display(obj));
  if (is_t_integer(obj))
    {
      const char *p;
      if (width == 0)
	return((char *)integer_to_string(sc, integer(obj), nlen));
      p = integer_to_string(sc, integer(obj), &len);
      if (width > len)
	{
	  insert_spaces(sc, p, width, len); /* writes sc->num_to_str */
	  (*nlen) = width;
	  return(sc->num_to_str);
	}
      (*nlen) = len;
      return((char *)p);
    }

  if (is_t_real(obj))
    {
      if (width == 0)
	{
#if WITH_DTOA
	  if ((float_choice == 'g') &&
	      (precision == Write_Real_Precision)) /* set to 6 in format! need ~,16G to hit this code */
	    {
	      /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001
	       *    because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug.
	       */
	      if (obj == Real_Pi)
		{
		  static const char pi_name[] = "3.141592653589793"; /* array form for ISO C++ */
		  (*nlen) = 17;
		  memcpy((void *)(sc->num_to_str), (void *)pi_name, 17);
		  return(sc->num_to_str); /* code below assumes we return sc->num_to_str in this case -- ugly! */
		}
	      len = fpconv_dtoa(real(obj), sc->num_to_str);
	      sc->num_to_str[len] = '\0';
	      (*nlen) = len;
	      return(sc->num_to_str);
	    }
#endif
	  len = snprintf(sc->num_to_str, sc->num_to_str_size - 4,
			 (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"),
			 (int32_t)precision, real(obj)); /* -4 for floatify */
	}
      else len = snprintf(sc->num_to_str, sc->num_to_str_size - 4,
			  (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"),
			  (int32_t)width, (int32_t)precision, real(obj)); /* -4 for floatify */
      (*nlen) = len;
      floatify(sc->num_to_str, nlen);
      return(sc->num_to_str);
    }

  if (is_t_complex(obj))
    {
      char *imag;
      sc->num_to_str[0] = '\0';
      imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, imag_part(obj)), 0, precision, float_choice, &len, choice));

      sc->num_to_str[0] = '\0';
      number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 0, precision, float_choice, &len, choice);

      sc->num_to_str[len] = '\0';
      len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL);
      free(imag);

      if (width > len)  /* (format #f "~20g" 1+i) */
	{
	  insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */
	  (*nlen) = width;
	}
      else (*nlen) = len;
      return(sc->num_to_str);
    }

  /* ratio */
  len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL);
  if (width > len)
    {
      insert_spaces(sc, sc->num_to_str, width, len);
      (*nlen) = width;
    }
  else (*nlen) = len;
  return(sc->num_to_str);
}

#define Base_10 10

static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t radix, s7_int width, s7_int precision, char float_choice, s7_int *nlen)
{
  /* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */
  /* the rest of s7 assumes nlen is set to the correct length */
  block_t *b;
  char *p;
  s7_int len, str_len;

#if With_Gmp
  if (s7_is_bignum(obj))
    return(big_number_to_string_with_radix(sc, obj, radix, width, nlen, p_Write));
  /* this ignores precision because it's way too hard to get the mpfr string to look like
   *   C's output -- we either have to call mpfr_get_str twice (the first time just to
   *   find out what the exponent is and how long the string actually is), or we have
   *   to do messy string manipulations.  So (format #f "",3F" pi) ignores the "3" and
   *   prints the full string.  And don't even think about mpfr_snprintf!
   */
#endif
  if (radix == Base_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 >= 15) ? "@" : "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';
	#define Str_Len 256
	b = inline_mallocate(sc, Str_Len);
        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 = Str_Len;
      }
      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);
	#define Another_Str_Len 512
	b = inline_mallocate(sc, Another_Str_Len);
	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 = Another_Str_Len;
	liberate(sc, n);
	liberate(sc, d);
      }
      break;
    }
  if (width > len)
    {
      s7_int spaces;
      if (width >= str_len)
	{
	  str_len = width + 1;
	  b = reallocate(sc, b, str_len);
	  p = (char *)block_data(b);
	}
      spaces = width - len;
      p[width] = '\0';
      memmove((void *)(p + spaces), (void *)p, len);
      local_memset((void *)p, (int)' ', spaces);
      (*nlen) = width;
    }
  else (*nlen) = len;
  return(b);
}

char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix)
{
  s7_int nlen = 0;
  block_t *b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen);  /* (log top 10) so we get all the digits in base 10 (??) */
  char *str = copy_string_with_length((char *)block_data(b), nlen);
  liberate(sc, b);
  return(str);
}

static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_number_to_string "(number->string num (radix 10)) converts the number num into a string."
  #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol)

  s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */
  const char *result;
  s7_pointer x = car(args);

  if (!is_number(x))
    return(method_or_bust(sc, x, sc->number_to_string_symbol, args, A_Number_String, 1));

  if (is_pair(cdr(args)))
    {
      const s7_pointer base = cadr(args);
      if (s7_is_integer(base))
	radix = s7_integer_clamped_if_gmp(sc, base);
      else return(method_or_bust(sc, base, sc->number_to_string_symbol, args, sc->type_names[T_INTEGER], 2));
      if ((radix < 2) || (radix > 16))
	out_of_range_error_nr(sc, sc->number_to_string_symbol, Int_Two, base, A_Valid_Radix_String);
#if With_Gmp
      if (!s7_is_bignum(x))
#endif
	{
	  block_t *b = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen);
	  return(block_to_string(sc, b, nlen));
	}}
#if With_Gmp
  else radix = 10;
  if (s7_is_bignum(x))
    {
      block_t *b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen, p_Write);
      return(block_to_string(sc, b, nlen));
    }
  result = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, p_Write);
#else
  if (is_t_integer(x))
    result = integer_to_string(sc, integer(x), &nlen);
  else result = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, p_Write);
#endif
  return(inline_make_string_with_length(sc, result, nlen));
}

static s7_pointer number_to_string_p_p(s7_scheme *sc, s7_pointer p)
{
#if With_Gmp
  return(g_number_to_string(sc, set_plist_1(sc, p)));
#else
  s7_int nlen = 0;
  char *result;
  if (!is_number(p))
    return(method_or_bust_p(sc, p, sc->number_to_string_symbol, A_Number_String));
  result = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, p_Write);
  return(inline_make_string_with_length(sc, result, nlen));
#endif
}

static s7_pointer integer_to_string_p_i(s7_scheme *sc, s7_int p)
{
  s7_int nlen = 0;
  const char *result = integer_to_string(sc, p, &nlen);
  return(inline_make_string_with_length(sc, result, nlen));
}
/* not number_to_string_p_d! */

static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer num, s7_pointer base)
{
#if With_Gmp
  return(g_number_to_string(sc, set_plist_2(sc, num, base)));
#else
  s7_int nlen = 0, radix;
  if (!is_number(num))
    wrong_type_error_nr(sc, sc->number_to_string_symbol, 1, num, A_Number_String);
  if (!is_t_integer(base))
    wrong_type_error_nr(sc, sc->number_to_string_symbol, 2, base, sc->type_names[T_INTEGER]);
  radix = integer(base);
  if ((radix < 2) || (radix > 16))
    out_of_range_error_nr(sc, sc->number_to_string_symbol, Int_Two, base, A_Valid_Radix_String);
  {
    block_t *b = number_to_string_with_radix(sc, num, radix, 0, sc->float_format_precision, 'g', &nlen);
    return(block_to_string(sc, b, nlen));
  }
#endif
}


/* -------------------------------------------------------------------------------- */
#define Ctable_Size 256
static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space, *number_table, *symbol_slashify_table;
static int32_t *digits;

static void init_ctables(void)
{
  exponent_table = (bool *)Calloc(Ctable_Size, sizeof(bool));
  slashify_table = (bool *)Calloc(Ctable_Size, sizeof(bool));
  symbol_slashify_table = (bool *)Calloc(Ctable_Size, sizeof(bool));
  char_ok_in_a_name = (bool *)Malloc(Ctable_Size * sizeof(bool));
  white_space = (bool *)Calloc(Ctable_Size + 1, sizeof(bool));
  white_space++;      /* leave white_space[-1] false for white_space[EOF] */
  number_table = (bool *)Calloc(Ctable_Size, sizeof(bool));
  digits = (int32_t *)Malloc(Ctable_Size * sizeof(int32_t));

  for (int32_t i = 0; i < Ctable_Size; i++)
    {
      char_ok_in_a_name[i] = true;
      /* white_space[i] = false; */
      digits[i] = 256;
      /* number_table[i] = false; */
    }

  char_ok_in_a_name[0] = false;
  char_ok_in_a_name[(uint8_t)'('] = false;  /* cast for C++ */
  char_ok_in_a_name[(uint8_t)')'] = false;
  char_ok_in_a_name[(uint8_t)';'] = false;
  char_ok_in_a_name[(uint8_t)'\t'] = false;
  char_ok_in_a_name[(uint8_t)'\n'] = false;
  char_ok_in_a_name[(uint8_t)'\r'] = false;
  char_ok_in_a_name[(uint8_t)' '] = false;
  char_ok_in_a_name[(uint8_t)'"'] = false;

  white_space[(uint8_t)'\t'] = true;
  white_space[(uint8_t)'\n'] = true;
  white_space[(uint8_t)'\r'] = true;
  white_space[(uint8_t)'\f'] = true;
  white_space[(uint8_t)'\v'] = true;
  white_space[(uint8_t)' '] = true;
  white_space[(uint8_t)'\205'] = true; /* 133 */
  white_space[(uint8_t)'\240'] = true; /* 160 */

  /* surely only 'e' is needed... */
  exponent_table[(uint8_t)'e'] = true; exponent_table[(uint8_t)'E'] = true;
  exponent_table[(uint8_t)'@'] = true;
#if With_Extra_Exponent_Markers
  exponent_table[(uint8_t)'s'] = true; exponent_table[(uint8_t)'S'] = true;
  exponent_table[(uint8_t)'f'] = true; exponent_table[(uint8_t)'F'] = true;
  exponent_table[(uint8_t)'d'] = true; exponent_table[(uint8_t)'D'] = true;
  exponent_table[(uint8_t)'l'] = true; exponent_table[(uint8_t)'L'] = true;
#endif
  for (int32_t i = 0; i < 32; i++) slashify_table[i] = true;
  /* for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; */ /* 6-Apr-24 for utf-8, but this has no effect on s7test?? */
  slashify_table[(uint8_t)'\\'] = true;
  slashify_table[(uint8_t)'"'] = true;
#if With_r7rs
  /* In R7RS mode, newlines should be escaped to ensure proper serialization */
  slashify_table[(uint8_t)'\n'] = true;
#else
   slashify_table[(uint8_t)'\n'] = false;
#endif

  for (int32_t i = 0; i < Ctable_Size; i++)
    symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */

  digits[(uint8_t)'0'] = 0; digits[(uint8_t)'1'] = 1; digits[(uint8_t)'2'] = 2; digits[(uint8_t)'3'] = 3; digits[(uint8_t)'4'] = 4;
  digits[(uint8_t)'5'] = 5; digits[(uint8_t)'6'] = 6; digits[(uint8_t)'7'] = 7; digits[(uint8_t)'8'] = 8; digits[(uint8_t)'9'] = 9;
  digits[(uint8_t)'a'] = 10; digits[(uint8_t)'A'] = 10;
  digits[(uint8_t)'b'] = 11; digits[(uint8_t)'B'] = 11;
  digits[(uint8_t)'c'] = 12; digits[(uint8_t)'C'] = 12;
  digits[(uint8_t)'d'] = 13; digits[(uint8_t)'D'] = 13;
  digits[(uint8_t)'e'] = 14; digits[(uint8_t)'E'] = 14;
  digits[(uint8_t)'f'] = 15; digits[(uint8_t)'F'] = 15;

  number_table[(uint8_t)'0'] = true; number_table[(uint8_t)'1'] = true; number_table[(uint8_t)'2'] = true; number_table[(uint8_t)'3'] = true;
  number_table[(uint8_t)'4'] = true; number_table[(uint8_t)'5'] = true; number_table[(uint8_t)'6'] = true; number_table[(uint8_t)'7'] = true;
  number_table[(uint8_t)'8'] = true; number_table[(uint8_t)'9'] = true; number_table[(uint8_t)'.'] = true;
  number_table[(uint8_t)'+'] = true;
  number_table[(uint8_t)'-'] = true;
  number_table[(uint8_t)'#'] = true;
}

#define is_white_space(C) white_space[C]
  /* this is much faster than C's isspace, and does not depend on the current locale.
   * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space
   */

/* -------------------------------- *#readers* -------------------------------- */
static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
{
  s7_pointer value = sc->F;
  const bool need_loader_port = is_loader_port(current_input_port(sc));

  /* *#reader* is assumed to be an alist of (char . proc)
   *    where each proc takes one argument, the string from just beyond the "#" to the next delimiter.
   *    The procedure can call read-char to read ahead in the current-input-port.
   *    If it returns anything other than #f, that is the value of the sharp expression.
   *    Since #f means "nothing found", it is tricky to handle #F:
   *       (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm
   * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback.  Added #_ later)
   */
  if (need_loader_port)
    clear_loader_port(current_input_port(sc));

  /* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible */
  for (s7_pointer 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);
}

static void backchar(char c, s7_pointer port)
{
  if (c == '\n')
    port_line_number(port)--;
  if (is_file_port(port))
    ungetc(c, port_file(port));
  else
    if (port_position(port) > 0)
      port_position(port)--;
}

static void resize_strbuf(s7_scheme *sc, s7_int needed_size)
{
  const s7_int old_size = sc->strbuf_size;
  while (sc->strbuf_size <= needed_size) sc->strbuf_size *= 2;
  sc->strbuf = (char *)Realloc(sc->strbuf, sc->strbuf_size);
  for (s7_int i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0';
}

static s7_pointer *chars;

static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_pointer port)
{
  /* if name[len - 1] != '>' there's no > delimiter at the end */
  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, name); /* #<lambda (x)> for example */

  if (hook_has_functions(sc->read_error_hook))  /* check *read-error-hook* */
    {
      const bool old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */
      const 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 #<x y> etc -- what would this break? maybe extend section below */

	  if (is_string_port(port)) /* probably unnecessary (see below) */
	    {
	      s7_int c = inchar(port);
	      const char *pstart = (const char *)(port_data(port) + port_position(port));
	      const char *p = strchr(pstart, (int)'"');
	      s7_int added_len;
	      char *buf;
	      if (!p)
		{
		  backchar(c, port);
		  return(make_undefined(sc, name));
		}
	      p++;
	      while (char_ok_in_a_name[(uint8_t)(*p)]) {p++;}
	      added_len = (s7_int)(p - pstart);                 /* p is one past '>' presumably */
	      /* we can't use strbuf here -- it might be the source of the "name" argument! */
	      buf = (char *)Malloc(len + added_len + 2);
	      memcpy((void *)buf, (const void *)name, len);
	      buf[len] = '"';                                   /* from inchar */
	      memcpy((void *)(buf + len + 1), (const void *)pstart, added_len);
	      buf[len + added_len + 1] = 0;
	      port_position(port) += added_len;
	      {
		s7_pointer result = make_undefined(sc, (const char *)buf);
		free(buf);
		return(result);
	      }}}}
  return(make_undefined(sc, name));
}

static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error);
#define Symbol_Ok true
#define No_Symbols false

static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer port, bool error_if_bad_number)
{
  /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */
  if ((!name) || (!*name)) /* (string->number "#") for example */
    return(make_undefined(sc, name));

  /* stupid r7rs special cases */
  if ((name[0] == 't') &&
      ((name[1] == '\0') || (c_strings_are_equal(name, "true"))))
    return(sc->T);

  if ((name[0] == 'f') &&
      ((name[1] == '\0') || (c_strings_are_equal(name, "false"))))
    return(sc->F);

  if (name[0] == '_')
    {
      /* we handle #_ before looking at *#readers* below (via check_sharp_readers) because #_ needs to be unsettable via *#readers*:
       *    (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
       *    (let ((+ -)) (#_+ 1 2)): -1
       */
      const s7_pointer sym = make_symbol_with_strlen(sc, (const char *)(name + 1));
      if ((!is_gensym(sym)) && (initial_value_is_defined(sc, sym)))
	{
	  if (!is_initial_value(initial_value(sym)))
	    copy_initial_value(sc, sym);
	  return(initial_value(sym));
	}
      /* here we should not necessarily raise an error that *_... is undefined.  reader-cond, for example, needs to
       *    read undefined #_ vals that it will eventually discard.
       */
      return(make_undefined(sc, name));    /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */
    }

  if (is_pair(slot_value(sc->sharp_readers)))
    {
      s7_pointer reader = check_sharp_readers(sc, name);
      if (reader != sc->F)
	return(reader);
    }

  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, "<unspecified>")) return(sc->unspecified);
      if (c_strings_are_equal(name, "<undefined>"))   return(sc->undefined);
      if (c_strings_are_equal(name, "<eof>"))         return(eof_object);
      if (c_strings_are_equal(name, "<do-unspecified>")) return(sc->do_unspecified); /* an experiment 2-May-26 */
#if s7_Debugging
      if (c_strings_are_equal(name, "<no-value>")) return(sc->no_value);
#endif
      return(unknown_sharp_constant(sc, name, port));

      /* -------- #o #x #b -------- */
    case 'o':   /* #o (octal) */
    case 'x':   /* #x (hex) */
    case 'b':   /* #b (binary) */
      {
	const s7_pointer result = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), No_Symbols, with_error);
	if ((error_if_bad_number) && (result == sc->F)) /* #b32 etc but not if called from string->number */
	  error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "#~A is not a number", 19), wrap_string(sc, name, safe_strlen(name))));
	return(result);
      }

      /* -------- #\... -------- */
    case '\\':
      if (name[2] == 0)                             /* the most common case: #\a */
	return(chars[(uint8_t)(name[1])]);
      /* not uint32_t here!  (uint32_t)255 (as a char) returns -1!! */
      switch (name[1])
	{
	case 'n':
	  if ((c_strings_are_equal(name + 1, "null")) ||
	      (c_strings_are_equal(name + 1, "nul")))
	    return(chars[0]);

	  if (c_strings_are_equal(name + 1, "newline"))
	    return(chars[(uint8_t)'\n']);
	  break;

	case 'a': if (c_strings_are_equal(name + 1, "alarm"))     return(chars[7]);             break;
	case 'b': if (c_strings_are_equal(name + 1, "backspace")) return(chars[8]);             break;
	case 'd': if (c_strings_are_equal(name + 1, "delete"))    return(chars[0x7f]);          break;
	case 'e': if (c_strings_are_equal(name + 1, "escape"))    return(chars[0x1b]);          break;
	case 'l': if (c_strings_are_equal(name + 1, "linefeed"))  return(chars[(uint8_t)'\n']); break;
	case 'r': if (c_strings_are_equal(name + 1, "return"))    return(chars[(uint8_t)'\r']); break;
	case 's': if (c_strings_are_equal(name + 1, "space"))     return(chars[(uint8_t)' ']);  break;
	case 't': if (c_strings_are_equal(name + 1, "tab"))       return(chars[(uint8_t)'\t']); break;
	  /* to print something in bold-face: (format *stderr* "~Ahiho~A~%" (string-append (string #\escape) "[1m") (string-append (string #\escape) "[22m")) */

	case 'x':
	  /* #\x is just x, but apparently #\x<num> is int->char? #\x65 -> #\e, and #\xcebb is lambda? */
	  {
	    /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3,
	     *   #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level.
	     * another problem: #\xbdca2cbec overflows so 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 < 256))
	      {
		int32_t dig = digits[(int32_t)(*tmp++)];
		if (dig < 16)
		  new_int = dig + (new_int * 16);
		else happy = false;
	      }
	    if ((happy) &&
		(new_int < 256) &&
		(new_int >= 0))
	      return(chars[new_int]);
	  }
	  break;
	}}
  return(unknown_sharp_constant(sc, name, NULL));
}

static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow)
{
  bool negative = false;
  s7_int new_int = 0;
  int32_t dig;
  const char *tmp = (const char *)str;
#if With_Gmp
  const char *tmp1;
#endif
  if (str[0] == '+')
    tmp++;
  else
    if (str[0] == '-')
      {
	negative = true;
	tmp++;
      }
  while (*tmp == '0') {tmp++;};
#if With_Gmp
  tmp1 = tmp;
#endif
 if (radix == Base_10)
    {
      while (true)
	{
	  dig = digits[(uint8_t)(*tmp++)];
	  if (dig > 9) break;
#if Have_Overflow_Checks
	  if ((multiply_overflow(new_int, (s7_int)10, &new_int)) ||
	      (add_overflow(new_int, (s7_int)dig, &new_int)))
	    {
	      if ((radix == Base_10) &&
		  (strncmp(str, "-9223372036854775808", 20) == 0) &&
		  (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */
		return(s7_Int64_Min);
	      *overflow = true;
	      return((negative) ? s7_Int64_Min : s7_Int64_Max);
	    }
#else
	  new_int = dig + (new_int * 10);
	  dig = digits[(uint8_t)(*tmp++)];
	  if (dig > 9) break;
	  new_int = dig + (new_int * 10);
#endif
	}}
  else
    while (true)
      {
	dig = digits[(uint8_t)(*tmp++)];
	if (dig >= radix) break;
#if Have_Overflow_Checks && (!With_Gmp)
	{
	  s7_int oval = 0;
	  if (multiply_overflow(new_int, (s7_int)radix, &oval))
	    {
	      /* maybe a bad idea!  #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */
	      if ((radix >= 15) &&
		  (digits[(uint8_t)(*tmp)] >= radix))
		{
		  new_int -= 576460752303423488LL; /* turn off sign bit */
		  new_int *= radix;
		  new_int += dig;
		  new_int -= 9223372036854775807LL;
		  return(new_int - 1);
		}
	      new_int = oval; /* old case */
	      if ((new_int == s7_Int64_Min)  && (digits[(uint8_t)(*tmp++)] > 9))
		return(new_int);
	      *overflow = true;
	      break;
	    }
	  else new_int = oval;
	  if (add_overflow(new_int, (s7_int)dig, &new_int))
	    {
	      if (new_int == s7_Int64_Min) return(new_int);
	      *overflow = true;
	      break;
	    }}
#else
	new_int = dig + (new_int * radix);
	dig = digits[(uint8_t)(*tmp++)];
	if (dig >= radix) break;
	new_int = dig + (new_int * radix);
#endif
      }

#if With_Gmp
 if (!*overflow)
   (*overflow) = ((new_int > s7_Int32_Max) ||
		  ((tmp - tmp1) > s7_int_digits_by_radix[radix]));
  /* this tells the string->number readers to create a bignum.  We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */
#endif
  return((negative) ? -new_int : new_int);
}

static const char *radstr[17] = {NULL, NULL, "01", "012", "0123", "01234", "012345", "0123456", "01234567", "012345678", "0123456789",
  "0123456789aA", "0123456789aAbB", "0123456789aAbBcC", "0123456789aAbBcCdD", "0123456789aAbBcCdDeE", "0123456789aAbBcCdDeEfF"};

#if With_Gmp
static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow)
#else
static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix)
#endif
{
  /* strtod follows LANG which is not what we want (only "." is decimal point in Scheme).
   *   To overcome LANG in strtod would require screwing around with setlocale which never works.
   *   So we use our own code -- according to valgrind, this function is much faster than strtod.
   * comma as decimal point causes ambiguities: `(+ ,1 2) etc
   */
  int32_t sign = 1, frac_len, int_len, dig, exponent = 0;
  const int32_t max_len = s7_int_digits_by_radix[radix];
  s7_int int_part = 0, frac_part = 0;
  const char *str = ur_str;
  const char *ipart, *fpart;
  s7_double dval = 0.0;

  /* there's an ambiguity in number notation here if we allow "1e1" or "1.e1" in base 16 (or 15) -- is e a digit or an exponent marker?
   *   but 1e+1, for example disambiguates it -- kind of messy! -- the scheme spec says "e" can only occur in base 10.
   * '@' can now be used as the exponent marker (26-Mar-12).
   * Another slight ambiguity: 1+1/2i is parsed as 1 + 0.5i, not 1+1/(2i), or (1+1)/(2i) or (1+1/2)i etc
   */
  if (*str == '-')
    {
      str++;
      sign = -1;
    }
  else
    if (*str == '+')
      str++;
  while (*str == '0') {str++;};

  ipart = str;
  /* while (digits[(int32_t)(*str)] < radix) str++; */
  /* int_len = str - ipart; */
  int_len = strspn((const char *)str, radstr[radix]); /* this is faster than the while loop with digits[] */
  str += int_len;

  if (*str == '.') str++;
  fpart = str;
  /* while (digits[(int32_t)(*str)] < radix) str++; */
  /* frac_len = str - fpart; */
  frac_len = strspn((const char *)str, radstr[radix]);
  str += frac_len;

  if ((*str) && (exponent_table[(uint8_t)(*str)]))
    {
      bool exp_negative = false;
      str++;
      if (*str == '+')
	str++;
      else
	if (*str == '-')
	  {
	    str++;
	    exp_negative = true;
	  }
      while ((dig = digits[(int32_t)(*str++)]) < 10) /* exponent itself is always base 10 */
	{
#if Have_Overflow_Checks
	  if ((int32_multiply_overflow(exponent, 10, &exponent)) ||
	      (int32_add_overflow(exponent, dig, &exponent)))
	    {
	      exponent = 1000000; /* see below */
	      break;
	    }
#else
	  exponent = dig + (exponent * 10);
#endif
	}
#if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__)))
      if (exponent < 0)         /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */
	exponent = 1000000;     /*   see below for examples -- this number needs to be very big but not too big for add */
#endif
      if (exp_negative)
	exponent = -exponent;

      /*           2e12341234123123123123213123123123 -> 0.0
       * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0
       * first zero: 2e123412341231231231231
       * then:     2e12341234123123123123123123 -> inf
       * then:     2e123412341231231231231231231231231231 -> 0.0
       *           2e-123412341231231231231 -> inf
       * but:      0e123412341231231231231231231231231231
       */
    }

#if With_Gmp
  /* 9007199254740995.0 since 2^53=9007199254740992 */
  if (int_len + frac_len >= max_len)
    {
      (*overflow) = true;
      return(0.0);
    }
  /* trouble in non-gmp case if int_len>19 (9223372036854775808), or frac_len>0 and int_len>16 (2^53 above) -- should we warn
   *   about this if sc->safety != No_Safety? (need to ignore leading and (in frac case) trailing zeros, of course).
   */
#endif
  str = ipart;
  if ((int_len + exponent) > max_len)
    {
      /*  12341234.56789e12                   12341234567889999872.0              1.234123456789e+19
       * -1234567890123456789.0              -1234567890123456768.0              -1.2345678901235e+18
       *  12345678901234567890.0              12345678901234567168.0              1.2345678901235e+19
       *  123.456e30                          123456000000000012741097792995328.0 1.23456e+32
       *  12345678901234567890.0e12           12345678901234569054409354903552.0  1.2345678901235e+31
       *  1.234567890123456789012e30          1234567890123456849145940148224.0   1.2345678901235e+30
       *  1e20                                100000000000000000000.0             1e+20
       *  1234567890123456789.0               1234567890123456768.0               1.2345678901235e+18
       *  123.456e16                          1234560000000000000.0               1.23456e+18
       *  98765432101234567890987654321.0e-5  987654321012345728401408.0          9.8765432101235e+23
       *  98765432101234567890987654321.0e-10 9876543210123456512.0               9.8765432101235e+18
       *  0.00000000000000001234e20           1234.0
       *  0.000000000000000000000000001234e30 1234.0
       *  0.0000000000000000000000000000000000001234e40 1234.0
       *  0.000000000012345678909876543210e15 12345.678909877
       *  0e1000                              0.0
       */

      for (int32_t i = 0; i < max_len; i++)
	{
	  dig = digits[(int32_t)(*str++)];
	  if (dig < radix)
	    int_part = dig + (int_part * radix);
	  else break;
	}

      /* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000) */
      if ((int_part == 0) &&
	  (exponent > max_len))
	{
	  /* if frac_part is also 0, return 0.0 */
	  if (frac_len == 0) return(0.0);
	  str = fpart;
	  while ((dig = digits[(int32_t)(*str++)]) < radix)
	    frac_part = dig + (frac_part * radix);
	  if (frac_part == 0) return(0.0);
#if With_Gmp
	  (*overflow) = true;
#endif
	}
#if With_Gmp
      (*overflow) = ((int_part > 0) || (exponent > 20));    /* .1e310 is a tricky case */
#endif
      if (int_part != 0) /* 0.<310 zeros here>1e310 for example -- pow (via dpow) thinks it has to be too big, returns Nan,
			  *   then Nan * 0 -> Nan and the NaN propagates
			  */
	{
	  if (int_len <= max_len)
	    dval = int_part * dpow(radix, exponent);
	  else dval = int_part * dpow(radix, exponent + int_len - max_len);
	}
      else dval = 0.0;

      /* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */
      /*   using int_to_int or table lookups here instead of pow did not make any difference in speed */

      if (int_len < max_len)
	{
	  str = fpart;
	  for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len)
	    {
	      int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */
	      frac_len -= max_len;
	      frac_part = 0;
	      for (int32_t i = 0; i < flen; i++)
		frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);
	      if (frac_part != 0)                                /* same pow->NaN problem as above can occur here */
		dval += frac_part * dpow(radix, exponent - flen - k);
	    }}
      else
	/* some of the fraction is in the integer part before the negative exponent shifts it over */
	if (int_len > max_len)
	  {
	    int32_t ilen = int_len - max_len;                          /* we read these above */
	    /* str should be at the last digit we read */
	    if (ilen > max_len)
	      ilen = max_len;
	    for (int32_t i = 0; i < ilen; i++)
	      frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);
	    dval += frac_part * dpow(radix, exponent - ilen);
	  }
      return(sign * dval);
    }

  /* int_len + exponent <= max_len */
  if (int_len <= max_len)
    {
      int32_t int_exponent = exponent;
      /* a better algorithm (since the inaccuracies are in the radix^exponent portion):
       *   strip off leading zeros and possible sign,
       *   strip off digits beyond max_len, then remove any trailing zeros.
       *     (maybe fiddle with the lowest order digit here for rounding, but I doubt it matters)
       *   read digits until end of number or max_len reached, ignoring the decimal point
       *   get exponent and use it and decimal point location to position the current result integer
       * this always combines the same integer and the same exponent no matter how the number is expressed.
       */
      if (int_len > 0)
	{
	  const char *iend = (const char *)(str + int_len - 1);
	  while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;}
	  while (str <= iend)
	    int_part = digits[(int32_t)(*str++)] + (int_part * radix);
	}
      dval = (int_exponent == 0) ? (s7_double)int_part : int_part * dpow(radix, int_exponent);
    }
  else
    {
      int32_t flen;
      const int32_t len = int_len + exponent;
      s7_int frpart = 0;

      /* 98765432101234567890987654321.0e-20    987654321.012346
       * 98765432101234567890987654321.0e-29    0.98765432101235
       * 98765432101234567890987654321.0e-30    0.098765432101235
       * 98765432101234567890987654321.0e-28    9.8765432101235
       */
      for (int32_t i = 0; i < len; i++)
	int_part = digits[(int32_t)(*str++)] + (int_part * radix);
      flen = -exponent;
      if (flen > max_len)
	flen = max_len;
      for (int32_t i = 0; i < flen; i++)
	frpart = digits[(int32_t)(*str++)] + (frpart * radix);
      if (len <= 0)
	dval = int_part + frpart * dpow(radix, len - flen);
      else dval = int_part + frpart * dpow(radix, -flen);
    }

  if (frac_len > 0)
    {
      str = fpart;
      if (frac_len <= max_len)
	{
	  /* splitting out base 10 case saves very little here */
	  /* this ignores trailing zeros, so that 0.3 equals 0.300 */
	  const char *fend = (const char *)(str + frac_len - 1);

	  while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */
	  if ((frac_len & 1) == 0)
	    {
	      while (str <= fend)
		{
		  frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);
		  frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);
		}}
	  else
	    while (str <= fend)
	      frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);

	  dval += frac_part * dpow(radix, exponent - frac_len);

	  /* 0.6:    frac:    6, exp: 0.10000000000000000555, val: 0.60000000000000008882
	   * 0.60:   frac:   60, exp: 0.01000000000000000021, val: 0.59999999999999997780
	   * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780
	   * (= 0.6 0.60): #f
	   * (= #i3/5 0.6): #f
	   * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky)
	   * (= 0.6 6e-1): #t ; but not 60e-2
	   * to fix the 0.60 case, we need to ignore trailing post-dot zeros.
	   */
	}
      else
	{
	  if (exponent <= 0)
	    {
	      for (int32_t i = 0; i < max_len; i++)
		frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);

	      dval += frac_part * dpow(radix, exponent - max_len);
	    }
	  else
	    {
	      /* 1.0123456789876543210e1         10.12345678987654373771
	       * 1.0123456789876543210e10        10123456789.87654304504394531250
	       * 0.000000010000000000000000e10   100.0
	       * 0.000000010000000000000000000000000000000000000e10 100.0
	       * 0.000000012222222222222222222222222222222222222e10 122.22222222222222
	       * 0.000000012222222222222222222222222222222222222e17 1222222222.222222
	       */
	      int_part = 0;
	      for (int32_t i = 0; i < exponent; i++)
		int_part = digits[(int32_t)(*str++)] + (int_part * radix);
	      frac_len -= exponent;
	      if (frac_len > max_len)
		frac_len = max_len;
	      for (int32_t i = 0; i < frac_len; i++)
		frac_part = digits[(int32_t)(*str++)] + (frac_part * radix);
	      dval += int_part + frac_part * dpow(radix, -frac_len);
	    }}}
#if With_Gmp
  if ((int_part == 0) &&
      (frac_part == 0))
    return(0.0);
  (*overflow) = ((frac_len - exponent) > max_len);
#endif
  return(sign * dval);
}

#if !With_Gmp
static s7_pointer make_undefined_bignum(s7_scheme *sc, const char *name)
{
  const 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, "<bignum: %s>", name);
  result = make_undefined(sc, (const char *)buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now #<bignum: 123123...> */
  liberate(sc, b);
  return(result);
}
#endif

static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, const char *p, const char *q, int32_t radix, bool want_symbol, int32_t offset)
{
  const s7_int len = safe_strlen(p);
  if (p[len - 1] == 'i')       /* +nan.0[+/-]...i */
    {
      if (len == (offset + 2))            /* +nan.0+i */
	return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0));
      if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */
	{
	  char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1);
	  s7_pointer imag = make_atom(sc, ip, radix, No_Symbols, Without_Overflow_Error);
	  free(ip);
	  if (is_real(imag))
	    return(make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */
	}}
  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
}

static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, const char *q, int32_t radix, bool want_symbol, s7_int rl_len)
{
  const s7_int len = safe_strlen(q);
  if ((len > rl_len) && (len < 1024)) /* make compiler happy */
    {
      char *ip = copy_string_with_length(q, rl_len);
      s7_pointer rl = make_atom(sc, ip, radix, No_Symbols, Without_Overflow_Error);
      free(ip);
      if (is_real(rl))
	return(make_complex(sc, real_to_double(sc, rl, __func__), x));
    }
  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
}

#if With_Number_Separator
static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix);

static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t radix, bool want_symbol)
{
  block_t *b;
  char *new_name;
  const char sep = sc->number_separator;
  s7_int len, j = 0;

  if (name[0] == sep)
    return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F);
  len = safe_strlen(name);
  b = mallocate(sc, len + 1);
  new_name = (char *)block_data(b);
  memcpy((void *)new_name, (const void *)name, len);
  new_name[len] = 0;

  for (s7_int i = 0; i < len; i++)
    if (name[i] != sep)
      {
	if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]]))
	  new_name[j++] = name[i];
	else
	  {
	    liberate(sc, b);
	    return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F);
	  }}
    else  /* sep has to be between two digits */
      if ((digits[(uint8_t)(name[i - 1])] >= radix) || (digits[(uint8_t)(name[i + 1])] >= radix))
	{
	  liberate(sc, b);
	  return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F);
	}
  new_name[j] = '\0';
  {
    s7_pointer result = string_to_number(sc, new_name, radix);
    liberate(sc, b);
    return(result);
  }
}
#endif

static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error)
{
  /* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */
#if With_Number_Separator
  #define is_digit(Chr, Rad) ((digits[(uint8_t)Chr] < Rad) || ((Chr == sc->number_separator) && (sc->number_separator != '\0')))
#else
  #define is_digit(Chr, Rad) (digits[(uint8_t)Chr] < Rad)
#endif
  char c, *p = q;
  bool has_dec_point1 = false;

  c = *p++;
  switch (c)
    {
    case '#':
      /* from string->number, (string->number #xc) */
      return(make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */

    case '+':
    case '-':
      c = *p++;
      if (c == '.')
	{
	  has_dec_point1 = true;
	  c = *p++;
	}
      if (!c)
	return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
      if (!is_digit(c, radix))
	{
	  if (has_dec_point1)
	    return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
	  if (c == 'n')
	    {
	      if (local_strcmp(p, "an.0"))            /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */
		return(Real_NaN);                     /* not make_nan_with_payload(sc, __LINE__) here since it says "0" */
	      if ((local_strncmp(p, "an.0", 4)) &&    /* +nan.0[+/-]...i */
		  ((p[4] == '+') || (p[4] == '-')))
		return(nan1_or_bust(sc, Nan, p, q, radix, want_symbol, 4));
	      /* read +/-nan.<int> or +/-nan.<int>+/-...i */
	      if (local_strncmp(p, "an.", 3))         /* +nan.<int> */
		{
		  bool overflow = false;
		  int32_t i;
		  for (i = 3; is_digit(p[i], 10); i++);
		  if ((p[i] == '+') || (p[i] == '-')) /* complex case */
		    {
		      s7_int payload = string_to_integer((char *)(p + 3), 10, &overflow);
		      return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i));
		    }
		  /* check for "+nan." or "nan.a" -> symbol but "+nan.0+i" is a number */
		  if ((i == 3) || ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])]))) /* check for +nan.0i etc, '\0' is not white_space apparently */
		    return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
		  return(make_nan_with_payload(sc, string_to_integer((char *)(p + 3), 10, &overflow)));
		}}
	  if (c == 'i')
	    {
	      if (local_strcmp(p, "nf.0"))  /* +inf.0 */
		return((q[0] == '+') ? Real_Infinity : Real_Minus_Infinity);
	      if ((local_strncmp(p, "nf.0", 4)) && /* unaligned */
		  ((p[4] == '+') || (p[4] == '-')))
		return(nan1_or_bust(sc, (q[0] == '-') ? -Infinity : Infinity, p, q, radix, want_symbol, 4));
	    }
	  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
	}
      break;

    case '.':
      has_dec_point1 = true;
      c = *p++;
      if ((!c) || (!is_digit(c, radix)))
	return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
      break;

    case 'n':
      return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

    case 'i':
      return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

    case '0': case '1':    /* these two are always digits */
      break;

    default:
      if (!is_digit(c, radix))
	return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
      break;
    }

  /* now it's possibly a number -- the first character(s) could be part of a number in the current radix */
  {
    char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 = NULL, *ex2 = NULL;
    bool has_i = false, has_dec_point2 = false;
    int32_t has_plus_or_minus = 0, current_radix;
#if !With_Gmp
    bool overflow = false; /* for string_to_integer */
#endif
    current_radix = radix;  /* current_radix is 10 for the exponent portions, but radix for all the rest */

    for ( ; (c = *p) != 0; ++p)
      {
	/* what about embedded null? (string->number (string #\1 (integer->char 0) #\0))
	 *   currently we stop and return 1, but Guile returns #f.
	 *   this also means we can't use substring_uncopied if (string->number (substring...))
	 */
	if (!is_digit(c, current_radix))         /* moving this inside the switch statement was much slower */
	  {
	    current_radix = radix;

	    switch (c)
	      {
		/* -------- decimal point -------- */
	      case '.':
		if ((!is_digit(p[1], current_radix)) &&
		    (!is_digit(p[-1], current_radix)))
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if (has_plus_or_minus == 0)
		  {
		    if ((has_dec_point1) || (slash1))
		      return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
		    has_dec_point1 = true;
		  }
		else
		  {
		    if ((has_dec_point2) || (slash2))
		      return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
		    has_dec_point2 = true;
		  }
		continue;

		/* -------- exponent marker -------- */
#if With_Extra_Exponent_Markers
		/* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */
	      case 's': case 'S':
	      case 'd': case 'D':
	      case 'f': case 'F':
	      case 'l': case 'L':
		if (current_radix > 10)
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
#endif

	      case 'e': case 'E':
	      case '@':
		current_radix = 10;

		if (((ex1) ||
		     (slash1)) &&
		    (has_plus_or_minus == 0)) /* ee */
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if (((ex2) ||
		     (slash2)) &&
		    (has_plus_or_minus != 0)) /* 1+1.0ee */
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if ((!is_digit(p[-1], radix)) && /* was current_radix but that's always 10! */
		    (p[-1] != '.'))
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if (has_plus_or_minus == 0)
		  {
		    ex1 = p;
		    has_dec_point1 = true; /* decimal point illegal from now on */
		  }
		else
		  {
		    ex2 = p;
		    has_dec_point2 = true;
		  }
		p++;
		if ((*p == '-') || (*p == '+')) p++;
		if (is_digit(*p, current_radix))
		  continue;
		break;

		/* -------- internal + or - -------- */
	      case '+':
	      case '-':
		if (has_plus_or_minus != 0) /* already have the separator */
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		has_plus_or_minus = (c == '+') ? 1 : -1;
		plus = (char *)(p + 1);
		/* now check for nan/inf as imaginary part */

		if ((plus[0] == 'n') &&
		    (local_strncmp(plus, "nan.", 4)))
		  {
		    bool overflow1 = false;
		    s7_int payload = string_to_integer((char *)(p + 5), 10, &overflow1);
		    return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q)));
		  }
		if ((plus[0] == 'i') &&
		    (local_strcmp(plus, "inf.0i")))
		  return(nan2_or_bust(sc, (c == '+') ? Infinity : -Infinity, q, radix, want_symbol, (intptr_t)(p - q)));
		continue;

		/* ratio marker */
	      case '/':
		if ((has_plus_or_minus == 0) &&
		    ((ex1) ||
		     (slash1) ||
		     (has_dec_point1)))
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if ((has_plus_or_minus != 0) &&
		    ((ex2) ||
		     (slash2) ||
		     (has_dec_point2)))
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		if (has_plus_or_minus == 0)
		  slash1 = (char *)(p + 1);
		else slash2 = (char *)(p + 1);

		if ((!is_digit(p[1], current_radix)) ||
		    (!is_digit(p[-1], current_radix)))
		  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

		continue;

		/* -------- i for the imaginary part -------- */
	      case 'i':
		if ((has_plus_or_minus != 0) &&
		    (!has_i))
		  {
		    has_i = true;
		    continue;
		  }
		break;

	      default: break;
	      }
	    return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
	  }}

    if ((has_plus_or_minus != 0) &&        /* that is, we have an internal + or - */
	(!has_i))                          /*   but no i for the imaginary part */
      return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

#if With_Number_Separator
    if ((sc->number_separator != '\0') && (strchr(q, (int)(sc->number_separator))))
      return(make_symbol_or_number(sc, q, radix, want_symbol));
#endif

    if (has_i)
      {
#if !With_Gmp
	s7_double rl = 0.0, im = 0.0;
#else
	char e1 = 0, e2 = 0;
#endif
	s7_pointer result;
	s7_int len = safe_strlen(q);
	char ql1, pl1;

	if (q[len - 1] != 'i')
	  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);

	/* save original string */
	ql1 = q[len - 1];
	pl1 = (*(plus - 1));
#if With_Gmp
	if (ex1) {e1 = *ex1; (*ex1) = '@';} /* for mpfr */
	if (ex2) {e2 = *ex2; (*ex2) = '@';}
#endif
	/* look for cases like 1+i */
	q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */

	(*((char *)(plus - 1))) = '\0';

#if !With_Gmp
	if ((has_dec_point1) ||
	    (ex1))  /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */
	  rl = string_to_double_with_radix(q, radix);
	else /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */
	  {
	    if (slash1)
	      {
		/* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */
		s7_int den;
		const s7_int num = string_to_integer(q, radix, &overflow);
		if (overflow) return(make_undefined_bignum(sc, q));
		den = string_to_integer(slash1, radix, &overflow);
		if (den == 0)
		  rl = Nan;        /* real_part if complex */
		else
		  {
		    if (num == 0)
		      {
			rl = 0.0;
			overflow = false;
		      }
		    else
		      {
			if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */
			rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */
		      }}}
	    else
	      {
		rl = (s7_double)string_to_integer(q, radix, &overflow);
		if (overflow) return(make_undefined_bignum(sc, q));
	      }}
	if (rl == -0.0) rl = 0.0;

	if ((has_dec_point2) ||
	    (ex2))
	  im = string_to_double_with_radix(plus, radix);
	else
	  {
	    if (slash2) /* complex part I think */
	      {
		/* same as above: 0-0/100000000000000000000000000000000000000i */
		s7_int den;
		const s7_int num = string_to_integer(plus, radix, &overflow);
		if (overflow) return(make_undefined_bignum(sc, q));
		den = string_to_integer(slash2, radix, &overflow);
		if (den == 0)
		  im = Nan;
		else
		  {
		    if (num == 0)
		      {
			im = 0.0;
			overflow = false;
		      }
		    else
		      {
			if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */
			im = (long_double)num / (long_double)den;
		      }}}
	    else
	      {
		im = (s7_double)string_to_integer(plus, radix, &overflow);
		if (overflow) return(make_undefined_bignum(sc, q));
	      }}
	if ((has_plus_or_minus == -1) &&
	    (im != 0.0))
	  im = -im;
	result = make_complex(sc, rl, im);
#else
	result = string_to_either_complex(sc, q, slash1, ex1, has_dec_point1, plus, slash2, ex2, has_dec_point2, radix, has_plus_or_minus);
#endif
	/* restore original string */
	q[len - 1] = ql1;
	(*((char *)(plus - 1))) = pl1;
#if With_Gmp
	if (ex1) (*ex1) = e1;
	if (ex2) (*ex2) = e2;
#endif
	return(result);
      }
    
    /* not complex */
    if ((has_dec_point1) ||
	(ex1))
      {
	s7_pointer result;
	if (slash1)  /* not complex, so slash and "." is not a number */
	  return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
	
#if !With_Gmp
	result = make_real(sc, string_to_double_with_radix(q, radix));
#else
	{
	  char old_e = 0;
	  if (ex1)
	    {
	      old_e = (*ex1);
	      (*ex1) = '@';
	    }
	  result = string_to_either_real(sc, q, radix);
	  if (ex1)
	    (*ex1) = old_e;
	}
#endif
	return(result);
      }
    
    /* rational */
    if (slash1)
#if !With_Gmp
      {
	s7_int d;
	const s7_int n = string_to_integer(q, radix, &overflow);
	if (overflow) return(make_undefined_bignum(sc, q));
	d = string_to_integer(slash1, radix, &overflow);
	
	if ((n == 0) && (d != 0))                        /* 0/100000000000000000000000000000000000000 */
	  return(Int_Zero);
	if (d == 0) return(Real_NaN);                    /* nan.__LINE__ here seems less than optimal */
	if (overflow) return(make_undefined_bignum(sc, q));
	/* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000
	 *   but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every
	 *   big number comes through here, so there's no clean and safe way to check that q == slash1.
	 */
	return(make_ratio(sc, n, d));
      }
#else
    return(string_to_either_ratio(sc, q, slash1, radix));
#endif
    /* integer */
#if !With_Gmp
    {
      s7_int x = string_to_integer(q, radix, &overflow);
      if (overflow) return(make_undefined_bignum(sc, q));
      return(make_integer(sc, x));
    }
#else
    return(string_to_either_integer(sc, q, radix));
#endif
  }
}


/* -------------------------------- string->number -------------------------------- */
static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix)
{
  s7_pointer num = make_atom(sc, str, radix, No_Symbols, Without_Overflow_Error);
  return((is_number(num)) ? num : sc->F);  /* only needed because str might start with '#' and not be a number (#t for example) */
}

static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1)
{
  char *str;
  if (!is_string(str1))
    wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]);
  str = (char *)string_value(str1);
  return(((!str) || (!*str)) ? sc->F : string_to_number(sc, str, 10));
}

static s7_pointer string_to_number_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer radix1)
{
  s7_int radix;
  char *str;
  if (!is_string(str1))
    wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]);
  if (!is_t_integer(radix1))
    wrong_type_error_nr(sc, sc->string_to_number_symbol, 2, radix1, sc->type_names[T_INTEGER]);
  radix = integer(radix1);
  if ((radix < 2) || (radix > 16))
    out_of_range_error_nr(sc, sc->string_to_number_symbol, Int_Two, radix1, A_Valid_Radix_String);

  str = (char *)string_value(str1);
  if ((!str) || (!*str))
    return(sc->F);
  return(string_to_number(sc, str, radix));
}

static s7_pointer string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  s7_int radix;
  char *str;
  if (!is_string(car(args)))
    return(method_or_bust(sc, car(args), caller, args, sc->type_names[T_STRING], 1));

  if (is_pair(cdr(args)))
    {
      const s7_pointer rad = cadr(args);
      if (!s7_is_integer(rad))
	return(method_or_bust(sc, rad, caller, args, sc->type_names[T_INTEGER], 2));
      radix = s7_integer_clamped_if_gmp(sc, rad);
      if ((radix < 2) || (radix > 16))
	out_of_range_error_nr(sc, caller, Int_Two, rad, A_Valid_Radix_String);
    }
  else radix = 10;
  str = (char *)string_value(car(args));
  if ((!str) || (!*str))
    return(sc->F);
  return(string_to_number(sc, str, radix));
}

static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_number "(string->number str (radix 10)) converts str into a number. \
If str does not represent a number, string->number returns #f.  If 'str' has an embedded radix, \
the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3."
  #define Q_string_to_number s7_make_signature(sc, 3, \
                               s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \
                               sc->is_string_symbol, sc->is_integer_symbol)
  return(string_to_number_1(sc, args, sc->string_to_number_symbol));
}


/* -------------------------------- abs -------------------------------- */
static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x)
{
#if !With_Gmp
  if (is_t_integer(x))
    {
      if (integer(x) >= 0) return(x);
      if (integer(x) > s7_Int64_Min) return(make_integer(sc, -integer(x)));
    }
  if (is_t_real(x))
    {
#if 0
      if (is_NaN(real(x)))
	return((nan_payload(real(x)) > 0) ? x : Real_NaN);         /* (abs -nan.0) -> +nan.0?? */
#endif
      return((signbit(real(x))) ? make_real(sc, -real(x)) : x);
    }
#endif
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) >= 0) return(x);
#if With_Gmp
      if (integer(x) == s7_Int64_Min)
	{
	  x = s7_int_to_big_integer(sc, integer(x));
	  mpz_neg(big_integer(x), big_integer(x));
	  return(x);
	}
#else
      if (integer(x) == s7_Int64_Min)
	sole_arg_out_of_range_error_nr(sc, sc->abs_symbol, set_elist_1(sc, x), Result_Is_Too_Large_String);
#endif
      return(make_integer(sc, -integer(x)));

    case T_RATIO:
      if (numerator(x) >= 0) return(x);
#if With_Gmp && (!Pointer_32)
      if (numerator(x) == s7_Int64_Min)
	{
	  s7_pointer new_bgr;
	  mpz_set_si(sc->mpz_1, s7_Int64_Min);
	  mpz_neg(sc->mpz_1, sc->mpz_1);
	  mpz_set_si(sc->mpz_2, denominator(x));
	  new_cell(sc, new_bgr, T_BIG_RATIO);
	  big_ratio_bgr(new_bgr) = alloc_bigrat(sc);
	  add_big_ratio(sc, new_bgr);
	  mpq_set_num(big_ratio(new_bgr), sc->mpz_1);
	  mpq_set_den(big_ratio(new_bgr), sc->mpz_2);
	  return(new_bgr);
	}
#else
      if (numerator(x) == s7_Int64_Min)
	return(make_ratio(sc, s7_Int64_Max, denominator(x))); /* not rationalized, so can't call make_simpler_ratio */
#endif
      return(make_simpler_ratio(sc, -numerator(x), denominator(x)));

    case T_REAL:
      if (is_NaN(real(x)))                  /* (abs -nan.0) -> +nan.0, not -nan.0 */
	return((nan_payload(real(x)) > 0) ? x : Real_NaN);
      return((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */
#if With_Gmp
    case T_BIG_INTEGER:
      mpz_abs(sc->mpz_1, big_integer(x));
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO:
      mpq_abs(sc->mpq_1, big_ratio(x));
      return(mpq_to_rational(sc, sc->mpq_1));
    case T_BIG_REAL:
      mpfr_abs(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->abs_symbol, sc->type_names[T_REAL]));
    }
}

static s7_pointer g_abs(s7_scheme *sc, s7_pointer args)
{
  #define H_abs "(abs x) returns the absolute value of the real number x"
  #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
  return(abs_p_p(sc, car(args)));
}

#ifdef __TINYC__
  static s7_double abs_d_d(s7_double x) {return((x < 0) ? (-x) : x);} /* signbit is very slow in tcc */
#else
  static s7_double abs_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);}
#endif
static s7_int abs_i_i(s7_int x) {return((x < 0) ? (-x) : x);}
/* (abs|magnitude -9223372036854775808) won't work here */


/* -------------------------------- magnitude -------------------------------- */
static s7_double my_hypot(double x, double y)
{
  /* useless: if (x == 0.0) return(fabs(y)); if (y == 0.0) return(fabs(x)); if (is_NaN(x)) return(x); if (is_NaN(y)) return(y); */
  if ((fabs(x) < 1.0e6) && (fabs(y) < 1.0e6)) /* max error is ca. e-14 */
    return(sqrt(x * x + y * y));              /* timing diffs: 62 for this form, 107 if just libm's hypot */
  return(hypot(x, y));                        /* libm's hypot protects against over/underflow */
}

static s7_pointer magnitude_uncomplex(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) < 0)
	{
	  if (integer(x) == s7_Int64_Min) return(MostFix);
	  /* (magnitude -9223372036854775808) -> -9223372036854775808
	   *   same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808
	   */
	  return(make_integer(sc, -integer(x)));
	}
      return(x);
    case T_RATIO:
      return((numerator(x) < 0) ? make_simpler_ratio(sc, -numerator(x), denominator(x)) : x);
    case T_REAL:
      if (is_NaN(real(x)))                 /* (magnitude -nan.0) -> +nan.0, not -nan.0 */
	return((nan_payload(real(x)) > 0) ? x : Real_NaN);
      return((signbit(real(x))) ? make_real(sc, -real(x)) : x);
    case T_COMPLEX:
      return(make_real(sc, my_hypot(real_part(x), imag_part(x))));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
      return(abs_p_p(sc, x));
    case T_BIG_COMPLEX:
      mpc_abs(sc->mpfr_1, big_complex(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->magnitude_symbol, A_Number_String));
    }
}

static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_complex(x))
    return(make_real(sc, my_hypot(real_part(x), imag_part(x))));
  return(magnitude_uncomplex(sc, x));
}

static s7_pointer magnitude_p_p_wrapped(s7_scheme *sc, s7_pointer x)
{
  if (is_t_complex(x))
    return(wrap_real(sc, my_hypot(real_part(x), imag_part(x))));
  return(magnitude_uncomplex(sc, x));
}

static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
{
  #define H_magnitude "(magnitude z) returns the magnitude of z"
  #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
  return(magnitude_p_p(sc, car(args)));
}

static s7_int magnitude_i_i(s7_int x) {return((x < 0) ? (-x) : x);}
static s7_double magnitude_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);}
static s7_pointer magnitude_p_z(s7_scheme *sc, s7_pointer z) {return(make_real(sc, my_hypot(real_part(z), imag_part(z))));}
static s7_pointer magnitude_p_z_wrapped(s7_scheme *sc, s7_pointer z) {return(wrap_real(sc, my_hypot(real_part(z), imag_part(z))));}

#if !With_Gmp
static s7_double magnitude_d_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_complex(x)) return(my_hypot(real_part(x), imag_part(x)));
  if (is_t_real(x)) return((real(x) < 0) ? -real(x) : real(x));
  if (is_t_integer(x)) return((integer(x) < 0) ? (s7_double)(-integer(x)) : (s7_double)(integer(x)));
  if (is_t_ratio(x)) return((numerator(x) < 0) ? -fraction(x) : fraction(x));
  sole_arg_wrong_type_error_nr(sc, sc->magnitude_symbol, x, A_Number_String);
#ifdef __TINYC__
  return(0.0);
#endif
}
#endif


/* -------------------------------- rationalize -------------------------------- */
#if With_Gmp

static rat_locals_t *init_rat_locals_t(s7_scheme *sc)
{
  rat_locals_t *r = (rat_locals_t *)Malloc(sizeof(rat_locals_t));
  sc->ratloc = r;
  mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL);
  mpq_init(r->q);
  mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL);
  return(r);
}

static void free_rat_locals(s7_scheme *sc)
{
  rat_locals_t *r = sc->ratloc;
  mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL);
  mpq_clear(r->q);
  mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL);
  free(r);
}

static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
{
  /* can return be non-rational? */
  /* currently (rationalize 1/0 1e18) -> 0
   * remember to pad with many trailing zeros:
   *    (rationalize 0.1 0)                -> 3602879701896397/36028797018963968
   *    (rationalize 0.1000000000000000 0) -> 1/10
   * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem?  (why is the non-gmp case ok?)
   *         also the bignum function is faking it.
   *         (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968
   * a confusing case:
   *   (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000
   * but that requires more than 128 bits of bignum-precision.
   */

  const s7_pointer num = car(args);
  rat_locals_t *r = (sc->ratloc) ? sc->ratloc : init_rat_locals_t(sc);

  switch (type(num))
    {
    case T_INTEGER:
      mpfr_set_si(r->ux, integer(num), Mpfr_Rndn);
      break;
    case T_RATIO:
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpfr_set_q(r->ux, sc->mpq_1, Mpfr_Rndn);
      break;
    case T_REAL:
      if (is_NaN(real(num)))
	out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, num, It_Is_Nan_String);
      if (is_inf(real(num)))
	out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, num, It_Is_Infinite_String);
      mpfr_set_d(r->ux, real(num), Mpfr_Rndn);
      break;
    case T_BIG_INTEGER:
      mpfr_set_z(r->ux, big_integer(num), Mpfr_Rndn);
      break;
    case T_BIG_RATIO:
      mpfr_set_q(r->ux, big_ratio(num), Mpfr_Rndn);
      break;
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(num)))
	out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, num, It_Is_Nan_String);
      if (mpfr_inf_p(big_real(num)))
	out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, num, It_Is_Infinite_String);
      mpfr_set(r->ux, big_real(num), Mpfr_Rndn);
      break;
    case T_COMPLEX: case T_BIG_COMPLEX:
      wrong_type_error_nr(sc, sc->rationalize_symbol, 1, num, sc->type_names[T_REAL]);
    default:
      return(method_or_bust(sc, num, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1));
    }

  if (is_null(cdr(args)))
    mpfr_set_d(r->error, sc->default_rationalize_error, Mpfr_Rndn);
  else
    {
      const s7_pointer err = cadr(args);
      switch (type(err))
	{
	case T_INTEGER:
	  mpfr_set_si(r->error, integer(err), Mpfr_Rndn);
	  break;
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(err), denominator(err));
	  mpfr_set_q(r->error, sc->mpq_1, Mpfr_Rndn);
	  break;
	case T_REAL:
	  if (is_NaN(real(err)))
	    out_of_range_error_nr(sc, sc->rationalize_symbol, Int_Two, err, It_Is_Nan_String);
	  if (is_inf(real(err)))
	    return(Int_Zero);
	  mpfr_set_d(r->error, real(err), Mpfr_Rndn);
	  break;
	case T_BIG_INTEGER:
	  mpfr_set_z(r->error, big_integer(err), Mpfr_Rndn);
	  break;
	case T_BIG_RATIO:
	  mpfr_set_q(r->error, big_ratio(err), Mpfr_Rndn);
	  break;
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(err)))
	    out_of_range_error_nr(sc, sc->rationalize_symbol, Int_Two, err, It_Is_Nan_String);
	  if (mpfr_inf_p(big_real(err)))
	    return(Int_Zero);
	  mpfr_set(r->error, big_real(err), Mpfr_Rndn);
	  break;
	case T_COMPLEX:	case T_BIG_COMPLEX:
	  wrong_type_error_nr(sc, sc->rationalize_symbol, 2, err, sc->type_names[T_REAL]);
	default:
	  return(method_or_bust(sc, err, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2));
	}
      mpfr_abs(r->error, r->error, Mpfr_Rndn);
    }

  mpfr_set(r->x0, r->ux, Mpfr_Rndn);            /* x0 = ux - error */
  mpfr_sub(r->x0, r->x0, r->error, Mpfr_Rndn);
  mpfr_set(r->x1, r->ux, Mpfr_Rndn);            /* x1 = ux + error */
  mpfr_add(r->x1, r->x1, r->error, Mpfr_Rndn);
  mpfr_get_z(r->i, r->x0, MPFR_RNDU);           /* i = ceil(x0) */

  if (mpfr_cmp_ui(r->error, 1) >= 0)            /* if (error >= 1.0) */
    {
      if (mpfr_cmp_ui(r->x0, 0) < 0)            /* if (x0 < 0) */
	{
	  if (mpfr_cmp_ui(r->x1, 0) < 0)        /*   if (x1 < 0) */
	    mpfr_get_z(r->n, r->x1, MPFR_RNDD); /*     num = floor(x1) */
	  else mpz_set_ui(r->n, 0);             /*   else num = 0 */
	}
      else mpz_set(r->n, r->i);                 /* else num = i */
      return(mpz_to_integer(sc, r->n));
    }

  if (mpfr_cmp_z(r->x1, r->i) >= 0)             /* if (x1 >= i) */
    {
      if (mpz_cmp_ui(r->i, 0) >= 0)             /* if (i >= 0) */
	mpz_set(r->n, r->i);                    /*   num = i */
      else mpfr_get_z(r->n, r->x1, MPFR_RNDD);  /* else num = floor(x1) */
      return(mpz_to_integer(sc, r->n));
    }

  mpfr_get_z(r->i0, r->x0, MPFR_RNDD);          /* i0 = floor(x0) */
  mpfr_get_z(r->i1, r->x1, MPFR_RNDU);          /* i1 = ceil(x1) */

  mpz_set(r->p0, r->i0);                        /* p0 = i0 */
  mpz_set_ui(r->q0, 1);                         /* q0 = 1 */
  mpz_set(r->p1, r->i1);                        /* p1 = i1 */
  mpz_set_ui(r->q1, 1);                         /* q1 = 1 */
  mpfr_sub_z(r->e0, r->x0, r->i1, Mpfr_Rndn);   /* e0 = i1 - x0 */
  mpfr_neg(r->e0, r->e0, Mpfr_Rndn);
  mpfr_sub_z(r->e1, r->x0, r->i0, Mpfr_Rndn);   /* e1 = x0 - i0 */
  mpfr_sub_z(r->e0p, r->x1, r->i1, Mpfr_Rndn);  /* e0p = i1 - x1 */
  mpfr_neg(r->e0p, r->e0p, Mpfr_Rndn);
  mpfr_sub_z(r->e1p, r->x1, r->i0, Mpfr_Rndn);  /* e1p = x1 - i0 */

  while (true)
    {
      mpfr_set_z(r->val, r->p0, Mpfr_Rndn);
      mpfr_div_z(r->val, r->val, r->q0, Mpfr_Rndn);  /* val = p0/q0 */

      if (((mpfr_lessequal_p(r->x0, r->val)) &&      /* if ((x0 <= val) && (val <= x1)) */
	   (mpfr_lessequal_p(r->val, r->x1))) ||
	  (mpfr_cmp_ui(r->e1, 0) == 0) ||
	  (mpfr_cmp_ui(r->e1p, 0) == 0))
	/* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */
	{
	  mpq_set_num(r->q, r->p0);                  /* return(p0/q0) */
	  mpq_set_den(r->q, r->q0);
	  return(mpq_to_rational(sc, r->q));
	}
      mpfr_div(r->val, r->e0, r->e1, Mpfr_Rndn);
      mpfr_get_z(r->r, r->val, MPFR_RNDD);           /* r = floor(e0/e1) */
      mpfr_div(r->val, r->e0p, r->e1p, Mpfr_Rndn);
      mpfr_get_z(r->r1, r->val, MPFR_RNDU);          /* r1 = ceil(e0p/e1p) */
      if (mpz_cmp(r->r1, r->r) < 0)                  /* if (r1 < r) */
	mpz_set(r->r, r->r1);                        /*   r = r1 */
      mpz_set(r->old_p1, r->p1);                     /* old_p1 = p1 */
      mpz_set(r->p1, r->p0);                         /* p1 = p0 */
      mpz_set(r->old_q1, r->q1);                     /* old_q1 = q1 */
      mpz_set(r->q1, r->q0);                         /* q1 = q0 */
      mpfr_set(r->old_e0, r->e0, Mpfr_Rndn);         /* old_e0 = e0 */
      mpfr_set(r->e0, r->e1p, Mpfr_Rndn);            /* e0 = e1p */
      mpfr_set(r->old_e0p, r->e0p, Mpfr_Rndn);       /* old_e0p = e0p */
      mpfr_set(r->e0p, r->e1, Mpfr_Rndn);            /* e0p = e1 */
      mpfr_set(r->old_e1, r->e1, Mpfr_Rndn);         /* old_e1 = e1 */
      mpz_mul(r->p0, r->p0, r->r);                   /* p0 = old_p1 + r * p0 */
      mpz_add(r->p0, r->p0, r->old_p1);
      mpz_mul(r->q0, r->q0, r->r);                   /* q0 = old_q1 + r * q0 */
      mpz_add(r->q0, r->q0, r->old_q1);
      mpfr_mul_z(r->e1, r->e1p, r->r, Mpfr_Rndn);    /* e1 = old_e0p - r * e1p */
      mpfr_sub(r->e1, r->old_e0p, r->e1, Mpfr_Rndn);
      mpfr_mul_z(r->e1p, r->old_e1, r->r, Mpfr_Rndn);/* e1p = old_e0 - r * old_e1 */
      mpfr_sub(r->e1p, r->old_e0, r->e1p, Mpfr_Rndn);
    }
}
#endif

static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
{
  #define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x"
  #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
  /* I can't find a case where this returns a non-rational result */

  s7_double err;
  const s7_pointer x = car(args);

#if With_Gmp
  if (is_big_number(x))
    return(big_rationalize(sc, args));
#endif
  if (!is_real(x))
    return(method_or_bust(sc, x, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1));
  if (is_null(cdr(args)))
    err = sc->default_rationalize_error;
  else
    {
      const s7_pointer ex = cadr(args);
#if With_Gmp
      if (is_big_number(ex))
	return(big_rationalize(sc, args));
#endif
      if (!is_real(ex))
	return(method_or_bust(sc, ex, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2));
      err = real_to_double(sc, ex, "rationalize");
      if (is_NaN(err))
	out_of_range_error_nr(sc, sc->rationalize_symbol, Int_Two, ex, It_Is_Nan_String);
      if (err < 0.0) err = -err;
    }

  switch (type(x))
    {
    case T_INTEGER:
      {
	s7_int a, b, pa;
	if (err < 1.0) return(x);
	a = integer(x);
	pa = (a < 0) ? -a : a;
	if (err >= pa) return(Int_Zero);
	b = (s7_int)err;
	pa -= b;
	return(make_integer(sc, (a < 0) ? -pa : pa));
      }
    case T_RATIO:
      if (err == 0.0)
	return(x);
    case T_REAL:
      {
	const s7_double rat = s7_real(x); /* possible fall through from above */
	s7_int numer = 0, denom = 1;
	if ((is_NaN(rat)) || (is_inf(rat)))
	  out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, x, A_Normal_Real_String);
	if (err >= fabs(rat))
	  return(Int_Zero);
#if With_Gmp
	if (fabs(rat) > Rationalize_Limit)
	  return(big_rationalize(sc, set_plist_2(sc, x, wrap_real(sc, err))));
#else
	if (fabs(rat) > Rationalize_Limit)
	  out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, x, It_Is_Too_Large_String);
#endif
	if ((fabs(rat) + fabs(err)) < 1.0e-18)
	  err = 1.0e-18;
	/* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that,
	 * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe.
	 */
	if (fabs(rat) < fabs(err))
	  return(Int_Zero);
	return((c_rationalize(rat, err, &numer, &denom)) ? make_simpler_ratio_or_integer(sc, numer, denom) : sc->F);
      }}
  if (s7_Debugging) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__);
  return(sc->F); /* make compiler happy */
}

static s7_int rationalize_i_i(s7_int x) {return(x);}
static s7_pointer rationalize_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}
static s7_pointer rationalize_p_d(s7_scheme *sc, s7_double x)
{
  if ((is_NaN(x)) || (is_inf(x)))
    out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, wrap_real(sc, x), A_Normal_Real_String); /* was make_real, also below */
  if (fabs(x) > Rationalize_Limit)
#if With_Gmp
    return(big_rationalize(sc, set_plist_1(sc, wrap_real(sc, x))));
#else
    out_of_range_error_nr(sc, sc->rationalize_symbol, Int_One, wrap_real(sc, x), It_Is_Too_Large_String);
#endif
  return(s7_rationalize(sc, x, sc->default_rationalize_error));
}


/* -------------------------------- angle -------------------------------- */
static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
{
  #define H_angle "(angle z) returns the angle of z"
  #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)

  const s7_pointer x = car(args);  /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */
  switch (type(x))
    {
    case T_INTEGER: return((integer(x) < 0) ? Real_Pi : Int_Zero);
    case T_RATIO:   return((numerator(x) < 0) ? Real_Pi : Int_Zero);
    case T_COMPLEX: return(make_real(sc, atan2(imag_part(x), real_part(x))));

    case T_REAL:
      if (is_NaN(real(x))) return(x);
      return((real(x) < 0.0) ? Real_Pi : Real_Zero);
#if With_Gmp
    case T_BIG_INTEGER: return((mpz_cmp_ui(big_integer(x), 0) >= 0) ? Int_Zero : big_pi(sc));
    case T_BIG_RATIO:   return((mpq_cmp_ui(big_ratio(x), 0, 1) >= 0) ? Int_Zero : big_pi(sc));
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x))) return(x);
      return((mpfr_cmp_d(big_real(x), 0.0) >= 0) ? Real_Zero : big_pi(sc));
    case T_BIG_COMPLEX:
      {
	s7_pointer new_bgf;
	new_cell(sc, new_bgf, T_BIG_REAL);
	big_real_bgf(new_bgf) = alloc_bigflt(sc);
	add_big_real(sc, new_bgf);
	mpc_arg(big_real(new_bgf), big_complex(x), Mpfr_Rndn);
	return(new_bgf);
      }
#endif
    default:
      return(method_or_bust_p(sc, x, sc->angle_symbol, A_Number_String));
    }
}

static s7_double angle_d_d(s7_double x) {return((is_NaN(x)) ? x : ((x < 0.0) ? M_PI : 0.0));}


/* -------------------------------- complex -------------------------------- */

static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  if ((is_big_number(x)) || (is_big_number(y)))
    {
      s7_pointer new_num = NULL; /* placate the compiler */
      if (!is_real(x))
	return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1));
      if (!is_real(y))
	return(method_or_bust(sc, y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2));

      switch (type(y))
	{
	case T_INTEGER: case T_RATIO: case T_REAL:
	  {
	    const s7_double iz = s7_real(y);
	    if (iz == 0.0)                      /* imag-part is 0.0 */
	      return(x);
	    new_cell(sc, new_num, T_BIG_COMPLEX);
	    big_complex_bgc(new_num) = alloc_bigcmp(sc);
	    mpfr_set_d(mpc_imagref(big_complex(new_num)), iz, Mpfr_Rndn);
	  }
	  break;
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y))) return(x);
	  new_cell(sc, new_num, T_BIG_COMPLEX);
	  big_complex_bgc(new_num) = alloc_bigcmp(sc);
	  mpfr_set(mpc_imagref(big_complex(new_num)), big_real(y), Mpfr_Rndn);
	  break;
	case T_BIG_RATIO:
	  new_cell(sc, new_num, T_BIG_COMPLEX);
	  big_complex_bgc(new_num) = alloc_bigcmp(sc);
	  mpfr_set_q(mpc_imagref(big_complex(new_num)), big_ratio(y), Mpfr_Rndn);
	  break;
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0) return(x);
	  new_cell(sc, new_num, T_BIG_COMPLEX);
	  big_complex_bgc(new_num) = alloc_bigcmp(sc);
	  mpfr_set_z(mpc_imagref(big_complex(new_num)), big_integer(y), Mpfr_Rndn);
	  break;
	}
      switch (type(x))
	{
	case T_INTEGER: case T_RATIO: case T_REAL:
	  mpfr_set_d(mpc_realref(big_complex(new_num)), s7_real(x), Mpfr_Rndn);
	  break;
	case T_BIG_REAL:
	  mpfr_set(mpc_realref(big_complex(new_num)), big_real(x), Mpfr_Rndn);
	  break;
	case T_BIG_RATIO:
	  mpfr_set_q(mpc_realref(big_complex(new_num)), big_ratio(x), Mpfr_Rndn);
	  break;
	case T_BIG_INTEGER:
	  mpfr_set_z(mpc_realref(big_complex(new_num)), big_integer(x), Mpfr_Rndn);
	  break;
	}
      add_big_complex(sc, new_num);
      return(new_num);
    }
#endif
  if ((is_t_real(x)) && (is_t_real(y))) return((real(y) == 0.0) ? x : make_complex_not_0i(sc, real(x), real(y)));
  switch (type(y))
    {
    case T_INTEGER:
      switch (type(x))
	{
	case T_INTEGER: return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), (s7_double)integer(y)));
	  /* these int->dbl's are problematic:
	   *   (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i
	   * should we raise an error?
	   */
	case T_RATIO:  return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), (s7_double)integer(y)));
	case T_REAL:   return((integer(y) == 0) ? x : make_complex_not_0i(sc, real(x), (s7_double)integer(y)));
	default:       return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1));
	}
    case T_RATIO:
      switch (type(x))
	{
	case T_INTEGER: return(make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */
	case T_RATIO:   return(make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y)));
	case T_REAL:    return(make_complex(sc, real(x), (s7_double)fraction(y)));
	default:	return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1));
	}
    case T_REAL:
      switch (type(x))
	{
	case T_INTEGER: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), real(y)));
	case T_RATIO:	return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), real(y)));
	case T_REAL:    return((real(y) == 0.0) ? x : make_complex_not_0i(sc, real(x), real(y)));
	default:	return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1));
	}
    default:
      return(method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2));
    }
}

static s7_pointer complex_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (is_t_real(x))
    {
      if (is_t_real(y)) return(wrap_complex(sc, real(x), real(y)));
      if (is_t_integer(y)) return(wrap_complex(sc, real(x), (s7_double)integer(y)));
    }
  else
    if (is_t_integer(x))
      {
	if (is_t_integer(y)) return(wrap_complex(sc, (s7_double)integer(x), (s7_double)integer(y)));
	if (is_t_real(y)) return(wrap_complex(sc, (s7_double)integer(x), real(y)));
      }
  return(complex_p_pp(sc, x, y));
}

static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
{
  #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
  #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
  return(complex_p_pp(sc, car(args), cadr(args)));
}

static s7_pointer complex_wrapped(s7_scheme *sc, s7_pointer args) {return(complex_p_pp_wrapped(sc, car(args), cadr(args)));}
static s7_pointer complex_p_ii_wrapped(s7_scheme *sc, s7_int x, s7_int y) {return(wrap_complex(sc, (s7_double)x, (s7_double)y));} /* tcomplex p_ii_ok */
static s7_pointer complex_p_dd_wrapped(s7_scheme *sc, s7_double x, s7_double y) {return(wrap_complex(sc, x, y));}

static s7_pointer complex_p_ii(s7_scheme *sc, s7_int x, s7_int y)
{
  return((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc, (s7_double)x, (s7_double)y));
}

static s7_pointer complex_p_dd(s7_scheme *sc, s7_double x, s7_double y)
{
  return((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y));
}


/* -------------------------------- bignum -------------------------------- */
static s7_pointer g_bignum(s7_scheme *sc, s7_pointer args)
{
  #define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \
bignum returns that number as a bignum"
#if With_Gmp
  #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol)
#else
  #define Q_bignum s7_make_signature(sc, 3, \
                     s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \
                     s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), \
                     sc->is_integer_symbol)
#endif

  s7_pointer num = car(args);
  if (is_number(num))
    {
      if (!is_null(cdr(args)))
	error_nr(sc, make_symbol(sc, "bignum-error", 12),
		 set_elist_2(sc, wrap_string(sc, "bignum of a number takes only one argument: ~S", 46), args));
#if With_Gmp
      switch (type(num))
	{
	case T_INTEGER: return(s7_int_to_big_integer(sc, integer(num)));
	case T_RATIO:   return(s7_int_to_big_ratio(sc, numerator(num), denominator(num)));
	case T_REAL:    return(s7_double_to_big_real(sc, real(num)));
	case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(num), imag_part(num)));
	default:        return(num);
	}
#else
      return(num);
#endif
    }
  num = string_to_number_1(sc, args, sc->bignum_symbol);
  if (is_false(sc, num))                                    /* (bignum "1/3.0") */
    error_nr(sc, make_symbol(sc, "bignum-error", 12),
	     set_elist_2(sc, wrap_string(sc, "bignum string argument does not represent a number: ~S", 54), car(args))); /* car(args) to get original */
#if With_Gmp
  switch (type(num))
    {
    case T_INTEGER:   return(s7_int_to_big_integer(sc, integer(num)));
    case T_RATIO:     return(s7_int_to_big_ratio(sc, numerator(num), denominator(num)));
    case T_COMPLEX:   return(s7_number_to_big_complex(sc, num));
    case T_REAL:
      if (is_NaN(real(num))) return(num);
      return(s7_double_to_big_real(sc, real(num)));
      /* 9Sep21: this was return(string_to_big_real(sc, string_value(car(args)), (is_pair(cdr(args))) ? s7_integer_clamped_if_gmp(sc, cadr(args)) : 10)); */
    default:
      return(num);
    }
#else
  return(num);
#endif
}


/* -------------------------------- exp -------------------------------- */
#if !Have_Complex_Numbers
  static s7_pointer No_Complex_Numbers_String;
#endif

#define Exp_Limit 100.0

#if With_Gmp
static s7_pointer exp_1(s7_scheme *sc, s7_double x)
{
  mpfr_set_d(sc->mpfr_1, x, Mpfr_Rndn);
  mpfr_exp(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
  return(mpfr_to_big_real(sc, sc->mpfr_1));
}

static s7_pointer exp_2(s7_scheme *sc, s7_double x, s7_double y)
{
  mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN);
  mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
  return(mpc_to_number(sc, sc->mpc_1));
}
#endif

static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x)
{
  s7_double z;
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_One);                       /* (exp 0) -> 1 */
      z = (s7_double)integer(x);
#if With_Gmp
      if (fabs(z) > Exp_Limit)
	return(exp_1(sc, z));
#endif
      return(make_real(sc, exp(z)));

    case T_RATIO:
      z = (s7_double)fraction(x);
#if With_Gmp
      if (fabs(z) > Exp_Limit)
	return(exp_1(sc, z));
#endif
      return(make_real(sc, exp(z)));

    case T_REAL:
#if With_Gmp
      if (fabs(real(x)) > Exp_Limit)
	return(exp_1(sc, real(x)));
#endif
      return(make_real(sc, exp(real(x))));

    case T_COMPLEX:
#if Have_Complex_Numbers
#if With_Gmp
      if ((fabs(real_part(x)) > Exp_Limit) ||
	  (fabs(imag_part(x)) > Exp_Limit))
	return(exp_2(sc, real_part(x), imag_part(x)));
#endif
      return(c_complex_to_s7(sc, cexp(to_c_complex(x))));
      /* this is inaccurate for large arguments:
       *   (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i
       */
#else
      out_of_range_error_nr(sc, sc->exp_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_exp(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_exp(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_exp(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->exp_symbol, A_Number_String));
    }
}

static s7_pointer g_exp(s7_scheme *sc, s7_pointer args)
{
  #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
  #define Q_exp sc->pl_nn
  return(exp_p_p(sc, car(args)));
}

static s7_double exp_d_d(s7_double x) {return(exp(x));}
static s7_pointer exp_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, exp(x)));}


/* -------------------------------- log -------------------------------- */
#if __cplusplus
  #define Log_2 1.4426950408889634074
#else
  #define Log_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */
#endif

#if With_Gmp
static s7_pointer big_log(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args);
  s7_pointer base = NULL;

  if (!is_number(x))
    return(method_or_bust(sc, x, sc->log_symbol, args, A_Number_String, 1));

  if (is_pair(cdr(args)))
    {
      base = cadr(args);
      if (!is_number(base))
	return(method_or_bust(sc, base, sc->log_symbol, args, A_Number_String, 2));
    }

  if (is_real(x))
    {
      s7_pointer result = any_real_to_mpfr(sc, x, sc->mpfr_1);
      if (result == Real_NaN) return(result);
      if ((is_positive(sc, x)) &&
	  ((!base) ||
	   ((is_real(base)) && (is_positive(sc, base)))))
	{
	  if (result) return(result);
	  mpfr_log(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  if (base)
	    {
	      result = any_real_to_mpfr(sc, base, sc->mpfr_2);
	      if (result)
		return((result == Real_Infinity) ? Real_Zero : result);
	      if (mpfr_zero_p(sc->mpfr_2))
		out_of_range_error_nr(sc, sc->log_symbol, Int_Two, base, wrap_string(sc, "can't be zero", 13));
	      mpfr_log(sc->mpfr_2, sc->mpfr_2, Mpfr_Rndn);
	      mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	    }
	  if ((mpfr_integer_p(sc->mpfr_1)) && ((is_rational(x)) && ((!base) || (is_rational(base)))))
	    return(mpfr_to_integer(sc, sc->mpfr_1));
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}}
  if (base)
    {
      s7_pointer result = any_number_to_mpc(sc, base, sc->mpc_2);
      if (result)
	return((result == Real_Infinity) ? Real_Zero : Complex_NaN);
      if (mpc_zero_p(sc->mpc_2))
	out_of_range_error_nr(sc, sc->log_symbol, Int_Two, base, wrap_string(sc, "can't be zero", 13));
    }
  {
    const s7_pointer result = any_number_to_mpc(sc, x, sc->mpc_1);
    if (result)
      {
	if ((result == Real_Infinity) && (base) && ((is_negative(sc, x))))
	  return(make_complex_not_0i(sc, Infinity, -Nan));
	return((result == Real_NaN) ? Complex_NaN : result);
      }}
  mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
  if (base)
    {
      mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN);
      mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
    }
  if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
    return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
  return(mpc_to_number(sc, sc->mpc_1));
}
#endif

static s7_pointer g_int_log2(s7_scheme *sc, s7_pointer args)
{
  s7_int ix = integer(car(args));
  s7_double fx = log2((double)ix);
  return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx));
}

static s7_pointer g_log(s7_scheme *sc, s7_pointer args)
{
  #define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3"
  #define Q_log sc->pcl_n

  const s7_pointer x = car(args);

#if With_Gmp
  if (is_big_number(x)) return(big_log(sc, args));
#endif

  if (!is_number(x))
    return(method_or_bust(sc, x, sc->log_symbol, args, A_Number_String, 1));

  if (is_pair(cdr(args)))
    {
      const s7_pointer y = cadr(args);
      if (!is_number(y))
	return(method_or_bust(sc, y, sc->log_symbol, args, A_Number_String, 2));

#if With_Gmp
      if (is_big_number(y)) return(big_log(sc, args));
#endif
      if ((is_t_integer(y)) && (integer(y) == 2))
	{
	  /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */
	  if (is_t_integer(x))
	    {
	      const s7_int ix = integer(x);
	      if (ix > 0)
		{
		  s7_double fx;
#if (__ANDROID__) || (MS_Windows)
		  /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */
		  fx = log((double)ix) * Log_2;
#else
		  fx = log2((double)ix);
#endif
		  /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */
		  return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx));
		}}
	  if ((is_real(x)) &&
	      (is_positive(sc, x)))
	    return(make_real(sc, log(s7_real(x)) * Log_2));
	  return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * Log_2));
	}

      if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1))  /* (log 1 1) -> 0 (this is NaN in the bignum case) */
	return(Int_Zero);

      /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */
      if (is_zero(y))
	{
	  if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1))
	    return(y);
	  out_of_range_error_nr(sc, sc->log_symbol, Int_Two, y, wrap_string(sc, "can't be zero", 13));
	}

      if ((is_t_real(x)) && (is_NaN(real(x))))
	return(x);
      if (is_one(y))                                     /* this used to raise an error, but the bignum case is simpler if we return inf */
	return((is_one(x)) ? Real_Zero : Real_Infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */

      if ((is_real(x)) && (is_real(y)) &&
	  (is_positive(sc, x)) && (is_positive(sc, y)))
	{
	  if ((is_rational(x)) && (is_rational(y)))
	    {
	      const s7_double result = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y));
	      const s7_int ires = (s7_int)result;
	      if (result - ires == 0.0)
		return(make_integer(sc, ires));   /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */
	      if (fabs(result) < Rationalize_Limit)
		{
		  s7_int num, den;
		  if (c_rationalize(result, sc->default_rationalize_error, &num, &den))
		      /* && (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) *//* why this? */
		    return(make_simpler_ratio_or_integer(sc, num, den));
		}
	      return(make_real(sc, result));
	    }
	  return(make_real(sc, log(s7_real(x)) / log(s7_real(y))));
	}
      if ((is_t_real(x)) && (is_NaN(real(x))))
	return(x);
      if ((is_t_complex(y)) && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))))
	return(y);
      return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y))));
    }

  if (!is_real(x))
    return(c_complex_to_s7(sc, clog(s7_to_c_complex(x))));
  if (is_positive(sc, x))
    return(make_real(sc, log(s7_real(x))));
  return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI));
}

static s7_pointer log_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
#if !With_Gmp
  if (args == 2)
    {
      s7_pointer x = cadr(expr), y = caddr(expr);
      if ((is_t_integer(y)) && (integer(y) == 2) && (is_t_integer(x)) && (integer(x) > 0))
	return(sc->int_log2);
    }
#endif
  return(func);
}

/* -------------------------------- sin -------------------------------- */
#define Sin_Limit 1.0e16
#define Sinh_Limit 20.0
/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4
 * (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part
 */

static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x)
{
#if !With_Gmp
  if (is_t_real(x)) return(make_real(sc, sin(real(x)))); /* range check in gmp case */
#endif
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_Zero);           /* (sin 0) -> 0 */
#if With_Gmp
      if (integer(x) > Sin_Limit)
	{
	  mpz_set_si(sc->mpz_1, integer(x));
	  mpfr_set_z(sc->mpfr_1, sc->mpz_1, Mpfr_Rndn);
	  mpfr_sin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
#endif
      return(make_real(sc, sin((s7_double)(integer(x))))); /* bogus for very large integers, but so is the equivalent real (see Sin_Limit) */

    case T_RATIO:
      return(make_real(sc, sin((s7_double)(fraction(x)))));
    case T_REAL:
      {
	const s7_double y = real(x);
#if With_Gmp
	if (fabs(y) > Sin_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
	    mpfr_sin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	    return(mpfr_to_big_real(sc, sc->mpfr_1));
	  }
#endif
	return(make_real(sc, sin(y)));
      }
    case T_COMPLEX:
#if With_Gmp
      if ((fabs(real_part(x)) > Sin_Limit) || (fabs(imag_part(x)) > Sinh_Limit))
	{
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
#endif
#if Have_Complex_Numbers
      return(c_complex_to_s7(sc, csin(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->sin_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_sin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_sin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_sin(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->sin_symbol, A_Number_String));
    }
  /* sin is inaccurate over about 1e30.  There's a way to get true results, but it involves fancy "range reduction" techniques.
   * (sin 1e32): 0.5852334864823946, but it should be 0.3902035466193536
   *   (remainder 1e32 (* 2 pi)) -> range error, but in gmp-s7: 2.740746974945068359375E0
   * before comparing imag-part to 0, we need to look for NaN and inf, else:
   *    (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0
   */
}

static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
{
  #define H_sin "(sin z) returns sin(z)"
  #define Q_sin sc->pl_nn
  return(sin_p_p(sc, car(args)));
}

#if With_Gmp
static s7_pointer sin_p_d(s7_scheme *sc, s7_double x)
{
  if (fabs(x) <= Sin_Limit)
    return(make_real(sc, sin(x)));
  mpfr_set_d(sc->mpfr_1, x, Mpfr_Rndn);
  mpfr_sin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
  return(mpfr_to_big_real(sc, sc->mpfr_1));
}
#else
static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sin(x)));}
#endif

static s7_double sin_d_d(s7_double x) {return(sin(x));}


/* -------------------------------- cos -------------------------------- */
static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x)
{
#if !With_Gmp
  if (is_t_real(x)) return(make_real(sc, cos(real(x)))); /* range check in gmp case */
#endif
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_One);             /* (cos 0) -> 1 */
#if With_Gmp
      if (integer(x) > Sin_Limit)
	{
	  mpz_set_si(sc->mpz_1, integer(x));
	  mpfr_set_z(sc->mpfr_1, sc->mpz_1, Mpfr_Rndn);
	  mpfr_cos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
#endif
      return(make_real(sc, cos((s7_double)(integer(x)))));

    case T_RATIO:
      return(make_real(sc, cos((s7_double)(fraction(x)))));
    case T_REAL: /* if with_gmp */
      {
	const s7_double y = real(x);
#if With_Gmp
	if (fabs(y) > Sin_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
	    mpfr_cos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	    return(mpfr_to_big_real(sc, sc->mpfr_1));
	  }
#endif
	return(make_real(sc, cos(y)));
      }
    case T_COMPLEX:
#if With_Gmp
      if ((fabs(real_part(x)) > Sin_Limit) || (fabs(imag_part(x)) > Sinh_Limit))
	{
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
#endif
#if Have_Complex_Numbers
      return(c_complex_to_s7(sc, ccos(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->cos_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_cos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_cos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_cos(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->cos_symbol, A_Number_String));
    }
}

static s7_pointer g_cos(s7_scheme *sc, s7_pointer args)
{
  #define H_cos "(cos z) returns cos(z)"
  #define Q_cos sc->pl_nn
  return(cos_p_p(sc, car(args)));
}

#if With_Gmp
static s7_pointer cos_p_d(s7_scheme *sc, s7_double x)
{
  if (fabs(x) <= Sin_Limit)
    return(make_real(sc, cos(x)));
  mpfr_set_d(sc->mpfr_1, x, Mpfr_Rndn);
  mpfr_cos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
  return(mpfr_to_big_real(sc, sc->mpfr_1));
}
#else
static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cos(x)));}
/* the optimizer can replace (cos x) = cos_p_p(x) with cos_p_d(x) if x is real, but x might be 0 so (byte? (cos x)) will return different results */
#endif

static s7_double cos_d_d(s7_double x) {return(cos(x));}


#if !With_Pure_s7
static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y);

static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
{
  #define H_make_polar "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) (* magnitude (sin angle)))"
  #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
  const s7_pointer mag = car(args), ang = cadr(args);
  if (!s7_is_real(mag))
    return(method_or_bust_pp(sc, mag, sc->make_polar_symbol, mag, ang, sc->type_names[T_REAL], 1));
  if (!s7_is_real(ang))
    return(method_or_bust_pp(sc, ang, sc->make_polar_symbol, mag, ang, sc->type_names[T_REAL], 2));
  return(complex_p_pp(sc, multiply_p_pp(sc, mag, cos_p_p(sc, ang)), multiply_p_pp(sc, mag, sin_p_p(sc, ang))));
}
#endif


/* -------------------------------- tan -------------------------------- */
#define Tan_Limit 1.0e18

static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x)
{
#if !With_Gmp
  if (is_t_real(x)) return(make_real(sc, tan(real(x))));
#endif
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_Zero);                      /* (tan 0) -> 0 */
#if With_Gmp
      if (integer(x) > Tan_Limit)
	{
	  mpz_set_si(sc->mpz_1, integer(x));
	  mpfr_set_z(sc->mpfr_1, sc->mpz_1, Mpfr_Rndn);
	  mpfr_tan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
#endif
      return(make_real(sc, tan((s7_double)(integer(x)))));

    case T_RATIO:
      return(make_real(sc, tan((s7_double)(fraction(x)))));
#if With_Gmp
    case T_REAL:
      if (fabs(real(x)) > Tan_Limit)
	{
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_tan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
#endif
      return(make_real(sc, tan(real(x))));
    case T_COMPLEX:
#if Have_Complex_Numbers
      if (imag_part(x) > 350.0)
	return(make_complex_not_0i(sc, 0.0, 1.0));
      return((imag_part(x) < -350.0) ? make_complex_not_0i(sc, 0.0, -1.0) : c_complex_to_s7(sc, ctan(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->tan_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_tan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_tan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_tan(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0)
	return(make_complex_not_0i(sc, 0.0, 1.0));
      if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0)
	return(make_complex_not_0i(sc, 0.0, -1.0));
      mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->tan_symbol, A_Number_String));
    }
}

static s7_pointer g_tan(s7_scheme *sc, s7_pointer args)
{
  #define H_tan "(tan z) returns tan(z)"
  #define Q_tan sc->pl_nn
  return(tan_p_p(sc, car(args)));
}

static s7_double tan_d_d(s7_double x) {return(tan(x));}


/* -------------------------------- asin -------------------------------- */
static s7_pointer c_asin(s7_scheme *sc, s7_double x)
{
  const s7_double absx = fabs(x);
  s7_double recip;
  s7_complex result;

  if (absx <= 1.0) return(make_real(sc, asin(x)));

  /* otherwise use maxima code: */
  recip = 1.0 / absx;
  result = (M_PI / 2.0) - (s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))));
  return((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc, result));
}

static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(c_asin(sc, real(x)));
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_Zero);                    /* (asin 0) -> 0 */
      /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */
      return(c_asin(sc, (s7_double)integer(x)));
    case T_RATIO:
      return(c_asin(sc, (s7_double)fraction(x)));
    case T_COMPLEX:
#if Have_Complex_Numbers
      /* if either real or imag part is very large, use explicit formula, not casin */
      /*   this code taken from sbcl's src/code/irrat.lisp; break is around x+70000000i */
      if ((fabs(real_part(x)) > 1.0e7) ||
	  (fabs(imag_part(x)) > 1.0e7))
	{
	  s7_complex sq1mz, sq1pz, z = to_c_complex(x);
	  sq1mz = csqrt(1.0 - z);
	  sq1pz = csqrt(1.0 + z);
	  return(make_complex(sc, atan(real_part(x) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz)))));
	}
      return(c_complex_to_s7(sc, casin(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->asin_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      goto Asin_Big_Real;
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      goto Asin_Big_Real;
    case T_BIG_REAL:
      if (mpfr_inf_p(big_real(x)))
	{
	  if (mpfr_cmp_ui(big_real(x), 0) < 0)
	    return(make_complex_not_0i(sc, Nan, Infinity)); /* match non-bignum choice */
	  return(make_complex_not_0i(sc, Nan, -Infinity));
	}
      mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
    Asin_Big_Real:
      mpfr_set_ui(sc->mpfr_2, 1, Mpfr_Rndn);
      if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0)
	{
	  mpfr_asin(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
      mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN);
      mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_COMPLEX:
      mpc_asin(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->asin_symbol, A_Number_String));
    }
}

static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
{
  #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x"
  #define Q_asin sc->pl_nn
  return(asin_p_p(sc, car(args)));
}


/* -------------------------------- acos -------------------------------- */
static s7_pointer c_acos(s7_scheme *sc, s7_double x)
{
  const s7_double absx = fabs(x);
  s7_double recip;
  s7_complex result;
  if (absx <= 1.0)
    return(make_real(sc, acos(x)));
  /* else follow maxima again: */
  recip = 1.0 / absx;
  if (x > 0.0)
    result = s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
  else result = M_PI - s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
  return(c_complex_to_s7(sc, result));
}

static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(c_acos(sc, real(x)));
  switch (type(x))
    {
    case T_INTEGER:
      return((integer(x) == 1) ? Int_Zero : c_acos(sc, (s7_double)integer(x)));
    case T_RATIO:
      return(c_acos(sc, (s7_double)fraction(x)));
    case T_COMPLEX:
#if Have_Complex_Numbers
      /* if either real or imag part is very large, use explicit formula, not cacos */
      /*   this code taken from sbcl's src/code/irrat.lisp */

      if ((fabs(real_part(x)) > 1.0e7) ||
	  (fabs(imag_part(x)) > 1.0e7))
	{
	  s7_complex sq1mz, sq1pz, z = to_c_complex(x);
	  sq1mz = csqrt(1.0 - z);
	  sq1pz = csqrt(1.0 + z);	  /* creal(sq1pz) can be 0.0 */
	  if (creal(sq1pz) == 0.0)        /* so the atan arg will be inf, so the real part will be pi/2(?) */
	    return(make_complex(sc, M_PI / 2.0, asinh(cimag(sq1mz * conj(sq1pz)))));
	  return(make_complex(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), asinh(cimag(sq1mz * conj(sq1pz)))));
	}
      return(c_complex_to_s7(sc, cacos(s7_to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->acos_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      goto Acos_Big_Real;
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      goto Acos_Big_Real;
    case T_BIG_REAL:
      if (mpfr_inf_p(big_real(x)))
	{
	  if (mpfr_cmp_ui(big_real(x), 0) < 0)
	    return(make_complex_not_0i(sc, -Nan, -Infinity)); /* match non-bignum choice */
	  return(make_complex_not_0i(sc, -Nan, Infinity));
	}
      mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
    Acos_Big_Real:
      mpfr_set_ui(sc->mpfr_2, 1, Mpfr_Rndn);
      if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0)
	{
	  mpfr_acos(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
      mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN);
      mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_COMPLEX:
      mpc_acos(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->acos_symbol, A_Number_String));
    }
}

static s7_pointer g_acos(s7_scheme *sc, s7_pointer args)
{
  #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
  #define Q_acos sc->pl_nn
  return(acos_p_p(sc, car(args)));
}


/* -------------------------------- atan -------------------------------- */
static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
{
  #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
  #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
  /* actually if there are two args, both should be real, but how to express that in the signature? */

  const s7_pointer x = car(args);
  s7_pointer y;
  /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */

  if (!is_pair(cdr(args)))
    {
      switch (type(x))
	{
	case T_INTEGER:  return((integer(x) == 0) ? Int_Zero : make_real(sc, atan((double)integer(x))));
	case T_RATIO:    return(make_real(sc, atan((s7_double)fraction(x))));
	case T_REAL:     return(make_real(sc, atan(real(x))));
	case T_COMPLEX:
#if Have_Complex_Numbers
	  return(c_complex_to_s7(sc, catan(to_c_complex(x))));
#else
	  out_of_range_error_nr(sc, sc->atan_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
	case T_BIG_INTEGER:
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  mpfr_atan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  mpfr_atan(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_atan(sc->mpfr_1, big_real(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_p(sc, x, sc->atan_symbol, A_Number_String));
	}}

  y = cadr(args);
  /* this is one place where s7 notices -0.0 != 0.0 -- this is apparently built into atan2, so I guess I'll leave it, but:
   *   (atan 0.0 0.0): 0.0, (atan 0.0 -0.0): pi, (atan 0 -0.0): pi, (atan 0 -0) 0.0, (atan 0 -0.0): pi.
   *   so you can sneak up on 0.0 from the left, but you can't fool 0??
   */
  switch (type(x))
    {
    case T_INTEGER: case T_RATIO: case T_REAL:
      if (is_small_real(y))
	return(make_real(sc, atan2(s7_real(x), s7_real(y))));
      if (!is_real(y))
	return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2));
#if !With_Gmp
      return(make_real(sc, atan2(s7_real(x), real(y))));
#else
      mpfr_set_d(sc->mpfr_1, s7_real(x), Mpfr_Rndn);
      goto Atan2_Big_Real;
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      goto Atan2_Big_Real;
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      goto Atan2_Big_Real;
    case T_BIG_REAL:
      mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      goto Atan2_Big_Real;
#endif
    default:
      return(method_or_bust(sc, x, sc->atan_symbol, args, sc->type_names[T_REAL], 1));
    }
#if With_Gmp
 Atan2_Big_Real:
  if (is_small_real(y))
    mpfr_set_d(sc->mpfr_2, s7_real(y), Mpfr_Rndn);
  else
    if (is_t_big_real(y))
      mpfr_set(sc->mpfr_2, big_real(y), Mpfr_Rndn);
    else
      if (is_t_big_integer(y))
	mpfr_set_z(sc->mpfr_2, big_integer(y), Mpfr_Rndn);
      else
	if (is_t_big_ratio(y))
	  mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
	else return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2));
  mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
  return(mpfr_to_big_real(sc, sc->mpfr_1));
#endif
}

static s7_double atan_d_d(s7_double x) {return(atan(x));}
static s7_double atan_d_dd(s7_double x, s7_double y) {return(atan2(x, y));}


/* -------------------------------- sinh -------------------------------- */
static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_Zero);                    /* (sinh 0) -> 0 */
    case T_RATIO:
    case T_REAL:
      {
	s7_double y = s7_real(x);
#if With_Gmp
	if (fabs(y) > Sinh_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
	    mpfr_sinh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	    return(mpfr_to_big_real(sc, sc->mpfr_1));
	  }
#endif
	return(make_real(sc, sinh(y)));
      }
    case T_COMPLEX:
#if With_Gmp
      if ((fabs(real_part(x)) > Sinh_Limit) || (fabs(imag_part(x)) > Sinh_Limit))
	{
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
#endif
#if Have_Complex_Numbers
      return(c_complex_to_s7(sc, csinh(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->sinh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_sinh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_sinh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_sinh(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->sinh_symbol, A_Number_String));
    }
}

static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args)
{
  #define H_sinh "(sinh z) returns sinh(z)"
  #define Q_sinh sc->pl_nn
  return(sinh_p_p(sc, car(args)));
}

static s7_double sinh_d_d(s7_double x) {return(sinh(x));}
static s7_pointer sinh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sinh(x)));}
  /* so sinh in a do-loop with 0 arg may return 0.0 because sinh_p_d does not check if x=0 */


/* -------------------------------- cosh -------------------------------- */
static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_One);                   /* (cosh 0) -> 1 */
    case T_RATIO:
    case T_REAL:
      {
	s7_double y = s7_real(x);
#if With_Gmp
	if (fabs(y) > Sinh_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
	    mpfr_cosh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	    return(mpfr_to_big_real(sc, sc->mpfr_1));
	  }
#endif
	return(make_real(sc, cosh(y)));
      }
    case T_COMPLEX:
#if With_Gmp
      if ((fabs(real_part(x)) > Sinh_Limit) || (fabs(imag_part(x)) > Sinh_Limit))
	{
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
#endif
#if Have_Complex_Numbers
      return(c_complex_to_s7(sc, ccosh(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->cosh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_cosh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_cosh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_cosh(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->cosh_symbol, A_Number_String));
    }
}

static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args)
{
  #define H_cosh "(cosh z) returns cosh(z)"
  #define Q_cosh sc->pl_nn
  return(cosh_p_p(sc, car(args)));
}

static s7_double cosh_d_d(s7_double x) {return(cosh(x));}
static s7_pointer cosh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cosh(x)));}


/* -------------------------------- tanh -------------------------------- */
#define Tanh_Limit 350.0
static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER: return((integer(x) == 0) ? Int_Zero : make_real(sc, tanh((s7_double)integer(x))));
    case T_RATIO:   return(make_real(sc, tanh((s7_double)fraction(x))));
    case T_REAL:    return(make_real(sc, tanh(real(x))));
    case T_COMPLEX:
#if Have_Complex_Numbers
      if (real_part(x) > Tanh_Limit)
	return(Real_One);                         /* closer than 0.0 which is what ctanh is about to return! */
      if (real_part(x) < -Tanh_Limit)
	return(make_real(sc, -1.0));              /* closer than ctanh's -0.0 */
      return(c_complex_to_s7(sc, ctanh(to_c_complex(x))));
#else
      out_of_range_error_nr(sc, sc->tanh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      goto Big_Real_Tanh;
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      goto Big_Real_Tanh;
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x))) return(x);
      mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
    Big_Real_Tanh:
      if (mpfr_cmp_d(sc->mpfr_1, Tanh_Limit) > 0) return(Real_One);
      if (mpfr_cmp_d(sc->mpfr_1, -Tanh_Limit) < 0) return(make_real(sc, -1.0));
      mpfr_tanh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), Tanh_Limit, 1))) > 0)
	return(Real_One);
      if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -Tanh_Limit, 1))) < 0)
	return(make_real(sc, -1.0));
      if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) ||
	  (mpfr_inf_p(mpc_imagref(big_complex(x)))))
	{
	  if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0)
	    return(make_complex_not_0i(sc, 0.0, Nan)); /* match non-bignum choice */
	  return(Complex_NaN);
	}
      mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
	return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->tanh_symbol, A_Number_String));
    }
}

static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args)
{
  #define H_tanh "(tanh z) returns tanh(z)"
  #define Q_tanh sc->pl_nn
  return(tanh_p_p(sc, car(args)));
}

static s7_double tanh_d_d(s7_double x) {return(tanh(x));}


/* -------------------------------- asinh -------------------------------- */
static s7_pointer asinh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER: return((integer(x) == 0) ? Int_Zero : make_real(sc, asinh((s7_double)integer(x))));
    case T_RATIO:   return(make_real(sc, asinh((s7_double)fraction(x))));
    case T_REAL:    return(make_real(sc, asinh(real(x))));
    case T_COMPLEX:
#if Have_Complex_Numbers
  #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
      return(c_complex_to_s7(sc, casinh_1(to_c_complex(x))));
  #else
      return(c_complex_to_s7(sc, casinh(to_c_complex(x))));
  #endif
#else
      out_of_range_error_nr(sc, sc->asinh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      mpfr_asinh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      mpfr_asinh(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_asinh(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->asinh_symbol, A_Number_String));
    }
}

static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args)
{
  #define H_asinh "(asinh z) returns asinh(z)"
  #define Q_asinh sc->pl_nn
  return(asinh_p_p(sc, car(args)));
}


/* -------------------------------- acosh -------------------------------- */
static s7_pointer acosh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 1) return(Int_Zero);
    case T_REAL:
    case T_RATIO:
      {
	s7_double x1 = s7_real(x);
	if (x1 >= 1.0)
	  return(make_real(sc, acosh(x1)));
      }
    case T_COMPLEX:
#if Have_Complex_Numbers
  #ifdef __OpenBSD__
      return(c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x))));
  #else
      return(c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */
  #endif
#else
      /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
      out_of_range_error_nr(sc, sc->acosh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
      mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_RATIO:
      mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
      mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_REAL:
      mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN);
      mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_COMPLEX:
      mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->acosh_symbol, A_Number_String));
    }
}

static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args)
{
  #define H_acosh "(acosh z) returns acosh(z)"
  #define Q_acosh sc->pl_nn
  return(acosh_p_p(sc, car(args)));
}


/* -------------------------------- atanh -------------------------------- */
static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(Int_Zero);                    /* (atanh 0) -> 0 */
    case T_REAL:
    case T_RATIO:
      {
	s7_double x1 = s7_real(x);
	if (fabs(x1) < 1.0)
	  return(make_real(sc, atanh(x1)));
      }
      /* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0:
       *    (atanh 9223372036854775/9223372036854776) -> 18.714973875119
       *    (atanh 92233720368547758/92233720368547757) -> inf.0
       *    (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i
       *    but the imaginary part is unnecessary
       */
    case T_COMPLEX:
#if Have_Complex_Numbers
  #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
      return(c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x))));
  #else
      return(c_complex_to_s7(sc, catanh(s7_to_c_complex(x))));
  #endif
#else
      out_of_range_error_nr(sc, sc->atanh_symbol, Int_One, x, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_2, big_integer(x), Mpfr_Rndn);
      goto Atanh_Big_Real;
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_2, big_ratio(x), Mpfr_Rndn);
      goto Atanh_Big_Real;
    case T_BIG_REAL:
      mpfr_set(sc->mpfr_2, big_real(x), Mpfr_Rndn);
    Atanh_Big_Real:
      mpfr_set_ui(sc->mpfr_1, 1, Mpfr_Rndn);
      if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0)
	{
	  mpfr_atanh(sc->mpfr_2, sc->mpfr_2, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_2));
	}
      mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN);
      mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
    case T_BIG_COMPLEX:
      mpc_atanh(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->atanh_symbol, A_Number_String));
    }
}

static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args)
{
  #define H_atanh "(atanh z) returns atanh(z)"
  #define Q_atanh sc->pl_nn
  return(atanh_p_p(sc, car(args)));
}


/* -------------------------------- sqrt -------------------------------- */
static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer num)
{
  switch (type(num))
    {
    case T_INTEGER:
      {
	s7_double sqx;
	if (integer(num) >= 0)
	  {
	    s7_int ix;
#if With_Gmp
	    mpz_set_si(sc->mpz_1, integer(num));
	    mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1);
	    if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
	      return(make_integer(sc, mpz_get_si(sc->mpz_1)));
	    mpfr_set_si(sc->mpfr_1, integer(num), Mpfr_Rndn);
	    mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	    return(mpfr_to_big_real(sc, sc->mpfr_1));
#endif
	    sqx = sqrt((s7_double)integer(num));
	    ix = (s7_int)sqx;
	    return(((ix * ix) == integer(num)) ? make_integer(sc, ix) : make_real(sc, sqx));
	    /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t
	     * but (* 94906265 94906265) -> 9007199136250225 -- oops
	     * if we use bigfloats, we're ok:
	     *    (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15
	     * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265
	     */
	  }
#if Have_Complex_Numbers
#if With_Gmp
	mpc_set_si(sc->mpc_1, integer(num), MPC_RNDNN);
	mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	return(mpc_to_number(sc, sc->mpc_1));
#endif
	sqx = (s7_double)integer(num); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */
	return(make_complex_not_0i(sc, 0.0, sqrt((s7_double)(-sqx))));
#else
	out_of_range_error_nr(sc, sc->sqrt_symbol, Int_One, num, No_Complex_Numbers_String);
#endif
      }

    case T_RATIO:
      if (numerator(num) > 0) /* else it's complex, so it can't be a ratio */
	{
	  const s7_int nm = (s7_int)sqrt(numerator(num));
	  if (nm * nm == numerator(num))
	    {
	      const s7_int dn = (s7_int)sqrt(denominator(num));
	      if (dn * dn == denominator(num))
		return(make_ratio(sc, nm, dn));
	    }
	  return(make_real(sc, sqrt((s7_double)fraction(num))));
	}
#if Have_Complex_Numbers
      return(make_complex(sc, 0.0, sqrt((s7_double)(-fraction(num)))));
#else
      out_of_range_error_nr(sc, sc->sqrt_symbol, Int_One, num, No_Complex_Numbers_String);
#endif

    case T_REAL:
      if (is_NaN(real(num))) return(num);     /* needed because otherwise (sqrt +nan.0) -> 0.0-nan.0i ?? */
      if (real(num) >= 0.0)
	return(make_real(sc, sqrt(real(num))));
      return(make_complex_not_0i(sc, 0.0, sqrt(-real(num))));

    case T_COMPLEX:    /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */
#if Have_Complex_Numbers
      return(c_complex_to_s7(sc, csqrt(to_c_complex(num)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */
#else
      out_of_range_error_nr(sc, sc->sqrt_symbol, Int_One, num, No_Complex_Numbers_String);
#endif

#if With_Gmp
    case T_BIG_INTEGER:
      if (mpz_cmp_ui(big_integer(num), 0) >= 0)
	{
	  mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(num));
	  if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
	    return(mpz_to_integer(sc, sc->mpz_1));
	  mpfr_set_z(sc->mpfr_1, big_integer(num), Mpfr_Rndn);
	  mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
      mpc_set_z(sc->mpc_1, big_integer(num), MPC_RNDNN);
      mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));

    case T_BIG_RATIO:
      /* if big ratio, check both num and den for squares */
      if (mpq_cmp_ui(big_ratio(num), 0, 1) < 0)
	{
	  mpc_set_q(sc->mpc_1, big_ratio(num), MPC_RNDNN);
	  mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
      mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(num)));
      if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
	{
	  mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(num)));
	  if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
	    {
	      mpq_set_num(sc->mpq_1, sc->mpz_1);
	      mpq_set_den(sc->mpq_1, sc->mpz_3);
	      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	    }}
      mpfr_set_q(sc->mpfr_1, big_ratio(num), Mpfr_Rndn);
      mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));

    case T_BIG_REAL:
      if (mpfr_cmp_ui(big_real(num), 0) < 0)
	{
	  mpc_set_fr(sc->mpc_1, big_real(num), MPC_RNDNN);
	  mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	}
      mpfr_sqrt(sc->mpfr_1, big_real(num), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));

    case T_BIG_COMPLEX:
      mpc_sqrt(sc->mpc_1, big_complex(num), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, num, sc->sqrt_symbol, A_Number_String));
    }
}

static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args)
{
  #define H_sqrt "(sqrt z) returns the square root of z"
  #define Q_sqrt sc->pl_nn
  return(sqrt_p_p(sc, car(args)));
}


/* -------------------------------- expt -------------------------------- */
static s7_int int_to_int(s7_int x, s7_int n)
{
  /* from GSL */
  s7_int value = 1;
  do {
    if (n & 1) value *= x;
    n >>= 1;
#if Have_Overflow_Checks
    if (multiply_overflow(x, x, &x))
      break;
#else
    x *= x;
#endif
  } while (n);
  return(value);
}

static const s7_int nth_roots[63] = {
  s7_Int64_Max, s7_Int64_Max, 3037000499LL, 2097151, 55108, 6208, 1448, 511, 234, 127, 78, 52, 38, 28, 22,
  18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
  2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2};

static bool int_pow_ok(s7_int x, s7_int y) {return((y < s7_Int_Bits) && (nth_roots[y] >= s7_int_abs(x)));}

#if With_Gmp
static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer x);
static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2);

static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args), y = cadr(args);
  s7_pointer result;
  if (!is_number(x))
    return(method_or_bust(sc, x, sc->expt_symbol, args, A_Number_String, 1));
  if (!is_number(y))
    return(method_or_bust(sc, y, sc->expt_symbol, args, A_Number_String, 2));

  if (is_zero(x))
    {
      if ((s7_is_integer(x)) && (s7_is_integer(y)) && (is_zero(y)))
	return(Int_One);

      if (is_real(y))
	{
	  if (is_negative(sc, y))
	    division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y);
	}
      else
	if (s7_real_part(y) < 0.0)
	  division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y);

      if ((is_rational(x)) && (is_rational(y)))
	return(Int_Zero);
      return(Real_Zero);
    }

  if (s7_is_integer(y))
    {
      s7_int yval = s7_integer_clamped_if_gmp(sc, y);
      if (yval == 0)
	return((is_rational(x)) ? Int_One : Real_One);

      if (yval == 1)
	return(x);

      if ((!is_big_number(x)) &&
	  ((is_one(x)) || (is_zero(x))))
	return(x);

      if ((yval < s7_Int32_Max) &&
	  (yval > s7_Int32_Min))
	{
	  /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */
	  if (s7_is_integer(x))
	    {
	      if (is_t_big_integer(x))
		mpz_set(sc->mpz_2, big_integer(x));
	      else mpz_set_si(sc->mpz_2, integer(x));
	      if (yval >= 0)
		{
		  mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval);
		  return(mpz_to_integer(sc, sc->mpz_2));
		}
	      mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)(-yval));
	      mpq_set_z(sc->mpq_1, sc->mpz_2);
	      mpq_inv(sc->mpq_1, sc->mpq_1);
	      if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
		return(mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
	      return(mpq_to_big_ratio(sc, sc->mpq_1));
	    }

	  if (s7_is_ratio(x)) /* here y is an integer */
	    {
	      if (is_t_big_ratio(x))
		{
		  mpz_set(sc->mpz_1, mpq_numref(big_ratio(x)));
		  mpz_set(sc->mpz_2, mpq_denref(big_ratio(x)));
		}
	      else
		{
		  mpz_set_si(sc->mpz_1, numerator(x));
		  mpz_set_si(sc->mpz_2, denominator(x));
		}
	      if (yval >= 0)
		{
		  mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval);
		  mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval);
		  mpq_set_num(sc->mpq_1, sc->mpz_1);
		  mpq_set_den(sc->mpq_1, sc->mpz_2);
		}
	      else
		{
		  yval = -yval;
		  mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval);
		  mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval);
		  mpq_set_num(sc->mpq_1, sc->mpz_2);
		  mpq_set_den(sc->mpq_1, sc->mpz_1);
		  mpq_canonicalize(sc->mpq_1);
		}
	      if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
		return(mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
	      return(mpq_to_big_ratio(sc, sc->mpq_1));
	    }

	  if (is_real(x))
	    {
	      if (is_t_big_real(x))
		mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
	      else mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	      mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }}}

  if ((is_t_ratio(y)) &&              /* not s7_is_ratio which accepts bignums */
      (numerator(y) == 1))
    {
      if (denominator(y) == 2)
	return(sqrt_p_p(sc, x));

      if ((is_real(x)) &&
	  (denominator(y) == 3))
	{
	  any_real_to_mpfr(sc, x, sc->mpfr_1);
	  mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}}

  result = any_number_to_mpc(sc, y, sc->mpc_2);
  if (result == Real_Infinity)
    {
      if (is_one(x)) return(Int_One);
      if (!is_real(x)) return((is_negative(sc, y)) ? Real_Zero : Complex_NaN);
      if (is_zero(x))
	{
	  if (is_negative(sc, y)) division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y);
	  return(Real_Zero);
	}
      if (lt_b_pi(sc, x, 0))
	{
	  if (lt_b_pi(sc, x, -1))
	    return((is_positive(sc, y)) ? Real_Infinity : Real_Zero);
	  return((is_positive(sc, y)) ? Real_Zero : Real_Infinity);
	}
      if (lt_b_pi(sc, x, 1))
	return((is_positive(sc, y)) ? Real_Zero : Real_Infinity);
      return((is_positive(sc, y)) ? Real_Infinity : Real_Zero);
    }
  if (result) return(Complex_NaN);

  if ((is_real(x)) &&
      (is_real(y)) &&
      (is_positive(sc, x)))
    {
      result = any_real_to_mpfr(sc, x, sc->mpfr_1);
      if (result)
	{
	  if (result == Real_Infinity)
	    {
	      if (is_negative(sc, y)) return(Real_Zero);
	      return((is_zero(y)) ? Real_One : Real_Infinity);
	    }
	  return(Complex_NaN);
	}
      mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    }

  result = any_number_to_mpc(sc, x, sc->mpc_1);
  if (result)
    {
      if ((result == Real_Infinity) && (is_real(y)))
	{
	  if (is_negative(sc, y)) return(Real_Zero);
	  return((is_zero(y)) ? Real_One : Real_Infinity);
	}
      return(Complex_NaN);
    }
  if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0)
    return(Int_Zero);
  if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0)
    return(Int_One);

  mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);

  if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */
    {
      if ((is_rational(car(args))) &&
	  (is_rational(cadr(args))) &&
	  (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0))
	{
	  /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */
	  /*   so first make sure we're within (say) 31 bits */
	  mpfr_set_ui(sc->mpfr_1, s7_Int32_Max, Mpfr_Rndn);
	  if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0)
	    {
	      mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), Mpfr_Rndn);
	      return(mpz_to_integer(sc, sc->mpz_1));
	    }}
      mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    }
  return(mpc_to_number(sc, sc->mpc_1));
}
#endif

static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw)
{
  if (!is_number(n))
    return(method_or_bust_pp(sc, n, sc->expt_symbol, n, pw, A_Number_String, 1));
  if (!is_number(pw))
    return(method_or_bust_pp(sc, pw, sc->expt_symbol, n, pw, A_Number_String, 2));

  if (is_zero(n))
    {
      if (is_zero(pw))
	{
	  if ((s7_is_integer(n)) && (s7_is_integer(pw)))       /* (expt 0 0) -> 1 */
	    return(Int_One);
	  return(Real_Zero);                                   /* (expt 0.0 0) -> 0.0 */
	}
      if (is_real(pw))
	{
	  if (is_negative(sc, pw))                              /* (expt 0 -1) */
	    division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw);
	  /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */

	  if (is_NaN(s7_real(pw)))                             /* (expt 0 +nan.0) */
	    return(pw);
	}
      else
	{                                                      /* (expt 0 a+bi) */
	  if (real_part(pw) < 0.0)                             /* (expt 0 -1+i) */
	    division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw);
	  if ((is_NaN(real_part(pw))) ||                       /* (expt 0 0+1/0i) */
	      (is_NaN(imag_part(pw))))
	    return(pw);
	}
      if ((s7_is_integer(n)) && (s7_is_integer(pw)))           /* pw != 0, (expt 0 2312) */
	return(Int_Zero);
      return(Real_Zero);                                       /* (expt 0.0 123123) */
    }

  if (is_one(pw))
    {
      if (s7_is_integer(pw))                                   /* (expt x 1) */
	return(n);
      if (is_rational(n))                                      /* (expt ratio 1.0) */
	return(make_real(sc, rational_to_double(sc, n)));
      return(n);
    }
  if (is_t_integer(pw))
    {
      const s7_int y = integer(pw);
      if (y == 0)
	{
	  if (is_rational(n))                                 /* (expt 3 0) */
	    return(Int_One);
	  if ((is_NaN(s7_real_part(n))) ||                    /* (expt 1/0 0) -> NaN */
	      (is_NaN(s7_imag_part(n))))                      /* (expt (complex 0 1/0) 0) -> NaN */
	    return(n);
	  return(Real_One);                                   /* (expt 3.0 0) */
	}
      switch (type(n))
	{
	case T_INTEGER:
	  {
	    const s7_int x = integer(n);
	    if (x == 1)                                       /* (expt 1 y) */
	      return(n);

	    if (x == -1)
	      {
		if (y == s7_Int64_Min)                        /* (expt -1 most-negative-fixnum) */
		  return(Int_One);
		if (y & 1)                                    /* (expt -1 odd-int) */
		  return(n);                                  /*    n == -1 */
		return(Int_One);                              /* (expt -1 even-int) */
	      }

	    if (y == s7_Int64_Min)                            /* (expt x most-negative-fixnum) */
	      return(Int_Zero);
	    if (x == s7_Int64_Min)                            /* (expt most-negative-fixnum y) */
	      return(make_real(sc, pow((double)x, (double)y)));

	    if (int_pow_ok(x, s7_int_abs(y)))
	      {
		if (y > 0)
		  return(make_integer(sc, int_to_int(x, y)));
		return(make_ratio(sc, 1, int_to_int(x, -y)));
	      }}
	  break;

	case T_RATIO:
	  {
	    const s7_int nm = numerator(n), dn = denominator(n);
	    if (y == s7_Int64_Min)
	      {
		if (s7_int_abs(nm) > dn)
		  return(Int_Zero);                  /* (expt 4/3 most-negative-fixnum) -> 0? */
		return(Real_Infinity);               /* (expt 3/4 most-negative-fixnum) -> inf? */
	      }
	    if ((int_pow_ok(nm, s7_int_abs(y))) &&
		(int_pow_ok(dn, s7_int_abs(y))))
	      {
		if (y > 0)
		  return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y)));
		return(make_ratio_with_div_check(sc, sc->expt_symbol, int_to_int(dn, -y), int_to_int(nm, -y)));
	      }}
	  break;
	  /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking
	   *  one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc
	   */

	case T_REAL:
	  /* (expt -1.0 most-positive-fixnum) should be -1.0
	   * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0
	   * (expt -1.0 (- 1 (expt 2 54))) -> -1.0
	   */
	  if (real(n) == -1.0)
	    {
	      if (y == s7_Int64_Min)
		return(Real_One);
	      return((s7_int_abs(y) & 1) ? n : Real_One);
	    }
	  break;

	case T_COMPLEX:
#if Have_Complex_Numbers
	  if ((s7_real_part(n) == 0.0) &&
	      ((s7_imag_part(n) == 1.0) ||
	       (s7_imag_part(n) == -1.0)))
	    {
	      bool yp = (y > 0), np = (s7_imag_part(n) > 0.0);
	      switch (s7_int_abs(y) % 4)
		{
		case 0: return(Real_One);
		case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0));
		case 2: return(make_real(sc, -1.0));
		case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0));
		}}
#else
	  out_of_range_error_nr(sc, sc->expt_symbol, Int_Two, n, No_Complex_Numbers_String);
#endif
	  break;
	}}

  if ((is_real(n)) &&
      (is_real(pw)))
    {
      s7_double x, y;
      if ((is_t_ratio(pw)) && (numerator(pw) == 1))
	{
	  if (denominator(pw) == 2)
	    return(sqrt_p_p(sc, n));
	  if (denominator(pw) == 3)
	    return(make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */
	  /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */
	}

      x = s7_real(n);
      y = s7_real(pw);
      if (is_NaN(x)) return(n);
      if (is_NaN(y)) return(pw);
      if (y == 0.0) return(Real_One);
      /* I think pow(rl, inf) is ok */
      if (x > 0.0)
	return(make_real(sc, pow(x, y)));      /* tricky cases abound here: (expt -1 1/9223372036854775807) */
    }

  /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ?
   * (expt 0+i 1+1/0i) = 0.0 ??
   */
  return(c_complex_to_s7(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw))));
}

static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
{
  #define H_expt "(expt z1 z2) returns z1^z2"
  #define Q_expt sc->pcl_n
#if With_Gmp
  return(big_expt(sc, args));
  /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */
#endif
  return(expt_p_pp(sc, car(args), cadr(args)));
}


/* -------------------------------- lcm -------------------------------- */
#if With_Gmp
static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args)
{
  mpz_set_si(sc->mpz_3, num);
  mpz_set_si(sc->mpz_4, den);

  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
      const s7_pointer rat = car(p);
      switch (type(rat))
	{
	case T_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(rat));
	  mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1);
	  mpz_set_si(sc->mpz_4, 1);
	  break;
	case T_RATIO:
	  mpz_set_si(sc->mpz_1, numerator(rat));
	  mpz_set_si(sc->mpz_2, denominator(rat));
	  mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1);
	  mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2);
	  break;
	case T_BIG_INTEGER:
	  mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat));
	  mpz_set_si(sc->mpz_4, 1);
	  break;
	case T_BIG_RATIO:
	  mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat)));
	  mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat)));
	  break;
	case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX:
	  wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), rat, A_Rational_String);
	default:
	  return(method_or_bust(sc, rat, sc->lcm_symbol,
				set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), p),
				A_Rational_String, position_of(p, args)));
	}}
  return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
}
#endif

static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
{
  /* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */
  #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
  #define Q_lcm sc->pcl_f

  s7_int n = 1, d = 0;
  if (!is_pair(args))
    return(Int_One);

  if (!is_pair(cdr(args)))
    {
      if (!is_rational(car(args)))
	return(method_or_bust(sc, car(args), sc->lcm_symbol, args, A_Rational_String, 1));
      return(g_abs(sc, args));
    }

  for (s7_pointer nums = args; is_pair(nums); nums = cdr(nums))
    {
      const s7_pointer x = car(nums);
      s7_int b;
#if Have_Overflow_Checks
      s7_int n1;
#endif
      switch (type(x))
	{
	case T_INTEGER:
	  d = 1;
	  if (integer(x) == 0) /* return 0 unless there's a wrong-type-arg (geez what a mess) */
	    {
	      for (nums = cdr(nums); is_pair(nums); nums = cdr(nums))
		{
		  const s7_pointer x1 = car(nums);
		  if (is_number(x1))
		    {
		      if (!is_rational(x1))
			wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x1, A_Rational_String);
		    }
		  else
		    if (has_active_methods(sc, x1))
		      {
			s7_pointer func = find_method_with_let(sc, x1, sc->is_rational_symbol);
			if ((func == sc->undefined) ||
			    (is_false(sc, s7_apply_function(sc, func, set_plist_1(sc, x1)))))
			  wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x1, A_Rational_String);
		      }
		    else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x1, A_Rational_String);
		}
	      return(Int_Zero);
	    }
	  b = integer(x);
	  if (b < 0)
	    {
	      if (b == s7_Int64_Min)
#if With_Gmp
		return(big_lcm(sc, n, d, nums));
#else
		sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, It_Is_Too_Large_String);
#endif
	      b = -b;
	    }
#if Have_Overflow_Checks
	  if (multiply_overflow(n / c_gcd(n, b), b, &n1))
#if With_Gmp
	    return(big_lcm(sc, n, d, nums));
#else
	    sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, Result_Is_Too_Large_String);
#endif
	  n = n1;
#else
	  n = (n / c_gcd(n, b)) * b;
#endif
	  break;

	case T_RATIO:
	  b = numerator(x);
	  if (b < 0)
	    {
	      if (b == s7_Int64_Min)
#if With_Gmp
		return(big_lcm(sc, n, d, nums));
#else
		sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, It_Is_Too_Large_String);
#endif
	      b = -b;
	    }
#if Have_Overflow_Checks
	  if (multiply_overflow(n / c_gcd(n, b), b, &n1))  /* (lcm 92233720368547758/3 3005/2) */
#if With_Gmp
	    return(big_lcm(sc, n, d, nums));
#else
	    sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, Intermediate_Too_Large_String);
#endif
          n = n1;
#else
	  n = (n / c_gcd(n, b)) * b;
#endif
	  if (d == 0)
	    d = (nums == args) ? denominator(x) : 1;
	  else d = c_gcd(d, denominator(x));
	  break;

#if With_Gmp
	case T_BIG_INTEGER:
	  d = 1;
	case T_BIG_RATIO:
	  return(big_lcm(sc, n, d, nums));
#endif
	case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX:
	  wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x, A_Rational_String);

	default:
	  return(method_or_bust(sc, x, sc->lcm_symbol,
				(nums == args) ? set_ulist_1(sc, x, cdr(nums)) :
				                 set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio(sc, n, d), nums),
				A_Rational_String, position_of(nums, args)));
	}}
  return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d));
}


/* -------------------------------- gcd -------------------------------- */
#if With_Gmp
static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args)
{
  mpz_set_si(sc->mpz_3, num);
  mpz_set_si(sc->mpz_4, den);

  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
      const s7_pointer rat = car(p);
      switch (type(rat))
	{
	case T_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(rat));
	  mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1);
	  break;
	case T_RATIO:
	  mpz_set_si(sc->mpz_1, numerator(rat));
	  mpz_set_si(sc->mpz_2, denominator(rat));
	  mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1);
	  mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2);
	  break;
	case T_BIG_INTEGER:
	  mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat));
	  break;
	case T_BIG_RATIO:
	  mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat)));
	  mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat)));
	  break;
	case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX:
	  wrong_type_error_nr(sc, sc->gcd_symbol, position_of(p, args), rat, A_Rational_String);
	default:
	  return(method_or_bust(sc, rat, sc->gcd_symbol,
				set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), p),
				A_Rational_String, position_of(p, args)));
	}}
  return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
}
#endif

static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
{
  #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
  #define Q_gcd sc->pcl_f

  s7_int n = 0, d = 1;
  s7_pointer n_args;
  if (!is_pair(args))       /* (gcd) */
    return(Int_Zero);

  if (!is_pair(cdr(args)))  /* (gcd 3/4) */
    {
      if (!is_rational(car(args)))
	return(method_or_bust(sc, car(args), sc->gcd_symbol, args, A_Rational_String, 1));
      return(abs_p_p(sc, car(args)));
    }

  if (is_t_integer(car(args)))
    {
      n = integer(car(args));
      n_args = cdr(args);
    }
  else n_args = args;

  for (s7_pointer nums = n_args; is_pair(nums); nums = cdr(nums))
    {
      const s7_pointer x = car(nums);
      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == s7_Int64_Min)
#if With_Gmp
	    return(big_gcd(sc, n, d, nums));
#else
	  {
	    if ((n == s7_Int64_Min) && (is_null(cdr(nums)))) /* gcd is supposed to return a positive integer, but we can't take abs(s7_Int64_Min) */
	      sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, It_Is_Too_Large_String);
	  }
#endif
	  n = c_gcd(n, integer(x));
	  break;

	case T_RATIO:
	  {
#if Have_Overflow_Checks
	    s7_int dn;
#endif
	    n = c_gcd(n, numerator(x));
	    if (d == 1)
	      d = denominator(x);
	    else
	      {
		const s7_int b = denominator(x);
#if Have_Overflow_Checks
		if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */
#if With_Gmp
		  return(big_gcd(sc, n, d, x));
#else
		  sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, Intermediate_Too_Large_String);
#endif
		d = dn;
#else
		d = (d / c_gcd(d, b)) * b;
#endif
	      }}
	  break;

#if With_Gmp
	case T_BIG_INTEGER: case T_BIG_RATIO:
	  return(big_gcd(sc, n, d, nums));
#endif

	case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX:
	  wrong_type_error_nr(sc, sc->gcd_symbol, position_of(nums, args), x, A_Rational_String);

	default:
	  return(method_or_bust(sc, x, sc->gcd_symbol,
				(nums == args) ? set_ulist_1(sc, x, cdr(nums)) :
				                 set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio(sc, n, d), nums),
				A_Rational_String, position_of(nums, args)));
	}}
  return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d));
}

static s7_pointer g_gcd_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)) && (integer(arg1) != s7_Int64_Min) && (integer(arg2) != s7_Int64_Min))
    return(make_integer(sc, c_gcd(integer(arg1), integer(arg2))));
  return(g_gcd(sc, args));
}

static s7_pointer gcd_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 2) return(sc->gcd_2);
  return(func);
}


/* -------------------------------- floor -------------------------------- */
static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      return(x);
    case T_RATIO:
      {
	s7_int val = numerator(x) / denominator(x);
	/* C "/" truncates? -- C spec says "truncation toward 0" */
	/* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers
	 *   but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results:
	 *   (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1
	 *   (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2
	 */
	return(make_integer(sc, (numerator(x) < 0) ? (val - 1) : val)); /* not "val" because it might be truncated to 0 */
      }
    case T_REAL:
      {
	const s7_double z = real(x);
	if (is_NaN(z))
	  sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, It_Is_Nan_String);
	if (is_inf(z))
	  sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, It_Is_Infinite_String);
#if With_Gmp
	if (fabs(z) > Double_To_Int64_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, z, Mpfr_Rndn);
	    mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD);
	    return(mpz_to_integer(sc, sc->mpz_1));
	  }
#else
	if (fabs(z) > Double_To_Int64_Limit)
	  sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, It_Is_Too_Large_String);
#endif
	return(make_integer(sc, (s7_int)floor(z)));
	/* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */
      }
#if With_Gmp
    case T_BIG_INTEGER:
      return(x);
    case T_BIG_RATIO:
      mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x)));
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, It_Is_Nan_String);
      if (mpfr_inf_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, It_Is_Infinite_String);
      mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_COMPLEX:
#endif
    case T_COMPLEX:
      sole_arg_wrong_type_error_nr(sc, sc->floor_symbol, x, sc->type_names[T_REAL]);
    default:
      return(method_or_bust_p(sc, x, sc->floor_symbol, sc->type_names[T_REAL]));
    }
}

static s7_pointer g_floor(s7_scheme *sc, s7_pointer args)
{
  #define H_floor "(floor x) returns the integer closest to x toward -inf"
  #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
  return(floor_p_p(sc, car(args)));
}

static s7_int floor_i_i(s7_int i) {return(i);}
static s7_pointer floor_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}

#if !With_Gmp
static s7_int floor_i_7d(s7_scheme *sc, s7_double x)
{
  if (is_NaN(x))
    sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, Real_NaN, It_Is_Nan_String);
  if (fabs(x) > Double_To_Int64_Limit)
    sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, wrap_real(sc, x), It_Is_Too_Large_String);
  return((s7_int)floor(x));
}

static s7_int floor_i_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(floor_i_7d(sc, real(x)));
  if (is_t_integer(x)) return(integer(x));
  if (is_t_ratio(x)) /* for consistency with floor_p_p, don't use floor(fraction(x)) */
    {
      s7_int val = numerator(x) / denominator(x);
      return((numerator(x) < 0) ? val - 1 : val);
    }
  return(s7_integer(method_or_bust_p(sc, x, sc->floor_symbol, sc->type_names[T_REAL])));
}

static s7_pointer floor_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, floor_i_7d(sc, x)));}
#endif


/* -------------------------------- ceiling -------------------------------- */
static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      return(x);
    case T_RATIO:
      {
	s7_int val = numerator(x) / denominator(x);
	return(make_integer(sc, (numerator(x) < 0) ? val : (val + 1)));
      }
    case T_REAL:
      {
	const s7_double z = real(x);
	if (is_NaN(z))
	  sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, It_Is_Nan_String);
	if (is_inf(z))
	  sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, It_Is_Infinite_String);
#if With_Gmp
	if (fabs(z) > Double_To_Int64_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, z, Mpfr_Rndn);
	    mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU);
	    return(mpz_to_integer(sc, sc->mpz_1));
	  }
#else
	if (fabs(z) > Double_To_Int64_Limit)
	  sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, It_Is_Too_Large_String);
#endif
	return(make_integer(sc, (s7_int)ceil(real(x))));
      }
#if With_Gmp
    case T_BIG_INTEGER:
      return(x);
    case T_BIG_RATIO:
      mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x)));
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, It_Is_Nan_String);
      if (mpfr_inf_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, It_Is_Infinite_String);
      mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_COMPLEX:
#endif
    case T_COMPLEX:
      sole_arg_wrong_type_error_nr(sc, sc->ceiling_symbol, x, sc->type_names[T_REAL]);
    default:
      return(method_or_bust_p(sc, x, sc->ceiling_symbol, sc->type_names[T_REAL]));
    }
}

static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
{
  #define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
  #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
  return(ceiling_p_p(sc, car(args)));
}

static s7_int ceiling_i_i(s7_int i) {return(i);}
static s7_pointer ceiling_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}

#if !With_Gmp
static s7_int ceiling_i_7d(s7_scheme *sc, s7_double x)
{
  if (is_NaN(x))
    sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, Real_NaN, It_Is_Nan_String);
  if ((is_inf(x)) ||
      (x > Double_To_Int64_Limit) || (x < -Double_To_Int64_Limit))
    sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, wrap_real(sc, x), It_Is_Too_Large_String);
  return((s7_int)ceil(x));
}

static s7_int ceiling_i_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(ceiling_i_7d(sc, real(x)));
  if (is_t_integer(x)) return(integer(x));
  if (is_t_ratio(x)) return((s7_int)(ceil((s7_double)fraction(x))));
  return(s7_integer(method_or_bust_p(sc, x, sc->ceiling_symbol, sc->type_names[T_REAL])));
}

static s7_pointer ceiling_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, ceiling_i_7d(sc, x)));}
#endif


/* -------------------------------- truncate -------------------------------- */
static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      return(x);
    case T_RATIO:
      return(make_integer(sc, (s7_int)(numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */
    case T_REAL:
      {
	const s7_double z = real(x);
	if (is_NaN(z))
	  sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, It_Is_Nan_String);
	if (is_inf(z))
	  sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, It_Is_Infinite_String);
#if With_Gmp
	if (fabs(z) > Double_To_Int64_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	    mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ);
	    return(mpz_to_integer(sc, sc->mpz_1));
	  }
#else
	if (fabs(z) > Double_To_Int64_Limit)
	  sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, It_Is_Too_Large_String);
#endif
	return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z)));
      }
#if With_Gmp
    case T_BIG_INTEGER:
      return(x);
    case T_BIG_RATIO:
      mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x)));
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, It_Is_Nan_String);
      if (mpfr_inf_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, It_Is_Infinite_String);
      mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_COMPLEX:
#endif
    case T_COMPLEX:
      sole_arg_wrong_type_error_nr(sc, sc->truncate_symbol, x, sc->type_names[T_REAL]);
    default:
      return(method_or_bust_p(sc, x, sc->truncate_symbol, sc->type_names[T_REAL]));
    }
}

static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args)
{
  #define H_truncate "(truncate x) returns the integer closest to x toward 0"
  #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
  return(truncate_p_p(sc, car(args)));
}

static s7_int truncate_i_i(s7_int i) {return(i);}
static s7_pointer truncate_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}

#if !With_Gmp
static s7_int truncate_i_7d(s7_scheme *sc, s7_double x)
{
  if (is_NaN(x))
    sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, Real_NaN, It_Is_Nan_String);
  if (is_inf(x))
    sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), It_Is_Infinite_String);
  if (fabs(x) > Double_To_Int64_Limit)
    sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), It_Is_Too_Large_String);
  return((x > 0.0) ? (s7_int)floor(x) : (s7_int)ceil(x));
}

static s7_pointer truncate_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, truncate_i_7d(sc, x)));}
#endif


/* -------------------------------- round -------------------------------- */
static s7_double r5rs_round(s7_double x)
{
  s7_double fl = floor(x), ce = ceil(x);
  s7_double dfl = x - fl;
  s7_double dce = ce - x;
  if (dfl > dce) return(ce);
  if (dfl < dce) return(fl);
  return((fmod(fl, 2.0) == 0.0) ? fl : ce);
}

static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      return(x);
    case T_RATIO:
      {
	const s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x);
	const long_double frac = s7_fabsl((long_double)remains / (long_double)denominator(x));
	if ((frac > 0.5) ||
	    ((frac == 0.5) &&
	     (truncated % 2 != 0)))
	  return(make_integer(sc, (numerator(x) < 0) ? (truncated - 1) : (truncated + 1)));
	return(make_integer(sc, truncated));
      }
    case T_REAL:
      {
	const s7_double z = real(x);
	if (is_NaN(z))
	  sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, It_Is_Nan_String);
	if (is_inf(z))
	  sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, It_Is_Infinite_String);
#if With_Gmp
	if (fabs(z) > Double_To_Int64_Limit)
	  {
	    mpfr_set_d(sc->mpfr_1, z, Mpfr_Rndn);
	    mpfr_rint(sc->mpfr_2, sc->mpfr_1, Mpfr_Rndn); /* mpfr_roundeven in mpfr 4.0.0 */
	    mpfr_get_z(sc->mpz_3, sc->mpfr_2, Mpfr_Rndn);
	    return(mpz_to_integer(sc, sc->mpz_3));
	  }
#else
	if (fabs(z) > Double_To_Int64_Limit)
	  sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, It_Is_Too_Large_String);
#endif
	return(make_integer(sc, (s7_int)r5rs_round(z)));
      }
#if With_Gmp
      case T_BIG_INTEGER:
	return(x);
    case T_BIG_RATIO:
      {
	int32_t rnd;
	mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x)));
	mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2);
	rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x)));
	mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x)));
	if (rnd > 0)
	  mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	else
	  if ((rnd == 0) &&
	      (mpz_odd_p(sc->mpz_1)))
	    mpz_add_ui(sc->mpz_1, sc->mpz_1, 1);
	return(mpz_to_integer(sc, sc->mpz_1));
      }
    case T_BIG_REAL:
      if (mpfr_nan_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, It_Is_Nan_String);
      if (mpfr_inf_p(big_real(x)))
	sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, It_Is_Infinite_String);
      mpfr_set(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      mpfr_rint(sc->mpfr_2, sc->mpfr_1, Mpfr_Rndn);
      mpfr_get_z(sc->mpz_3, sc->mpfr_2, Mpfr_Rndn);
      return(mpz_to_integer(sc, sc->mpz_3));
    case T_BIG_COMPLEX:
#endif
    case T_COMPLEX:
      sole_arg_wrong_type_error_nr(sc, sc->round_symbol, x, sc->type_names[T_REAL]);
    default:
      return(method_or_bust_p(sc, x, sc->round_symbol, sc->type_names[T_REAL]));
    }
}

static s7_pointer g_round(s7_scheme *sc, s7_pointer args)
{
  #define H_round "(round x) returns the integer closest to x"
  #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
  return(round_p_p(sc, car(args)));
}
/* (round (/ ...)) -> real_divide etc (wrapped) -- round_p_p is called in tbit via fx_c_op_opssqq_s_direct */

static s7_int round_i_i(s7_int i) {return(i);}
static s7_pointer round_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}

#if !With_Gmp
static s7_int round_i_7d(s7_scheme *sc, s7_double z)
{
  if (is_NaN(z))
    sole_arg_out_of_range_error_nr(sc, sc->round_symbol, Real_NaN, It_Is_Nan_String);
  if ((is_inf(z)) ||
      (z > Double_To_Int64_Limit) || (z < -Double_To_Int64_Limit))
    sole_arg_out_of_range_error_nr(sc, sc->round_symbol, wrap_real(sc, z), It_Is_Too_Large_String);
  return((s7_int)r5rs_round(z));
}

static s7_pointer round_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,round_i_7d(sc, x)));}
#endif


/* ---------------------------------------- add ---------------------------------------- */
static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
{
#if Have_Overflow_Checks
  s7_int val;
  if (add_overflow(x, y, &val))
#if With_Gmp
    {
      mpz_set_si(sc->mpz_1, x);
      mpz_set_si(sc->mpz_2, y);
      mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
      return(mpz_to_big_integer(sc, sc->mpz_1));
    }
#else
    {
      if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y);
      return(make_real(sc, (long_double)x + (long_double)y));
    }
#endif
  return(make_integer(sc, val));
#else
  return(make_integer(sc, x + y));
#endif
}

static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *sc, s7_pointer x, s7_pointer y) /* x: int, y:ratio */
{
#if Have_Overflow_Checks
  s7_int z;
  if ((multiply_overflow(integer(x), denominator(y), &z)) ||
      (add_overflow(z, numerator(y), &z)))
#if With_Gmp
    {
      mpz_set_si(sc->mpz_1, integer(x));
      mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y));
      mpz_set_si(sc->mpz_2, numerator(y));
      mpz_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1);
      mpz_set_si(mpq_denref(sc->mpq_1), denominator(y));
      return(mpq_to_rational(sc, sc->mpq_1));
    }
#else
    {
      if (With_Warnings)
	s7_warn(sc, s7_Warn_Bufsize, "integer + ratio overflow: (+ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y));
      return(make_real(sc, (long_double)integer(x) + fraction(y)));
    }
#endif
    return(make_ratio(sc, z, denominator(y)));
#else
  return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y)));
#endif
}

#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0)
/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */

static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  /* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */
  if (is_t_integer(x))
    {
      if (is_t_integer(y))
	return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y)));
#if !With_Gmp
      if (is_t_real(y))
	return(make_real(sc, (long_double)integer(x) + real(y)));
#endif
    }
  else
    if (is_t_real(x))
      {
	if (is_t_real(y))
	  return(make_real(sc, real(x) + real(y)));
      }
    else
      if ((is_t_complex(x)) && (is_t_complex(y)))
	return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y)));
	case T_RATIO:
	  return(integer_ratio_add_if_overflow_to_real_or_rational(sc, x, y));
	case T_REAL:
#if With_Gmp
	  if (s7_int_abs(integer(x)) >= Int64_To_Double_Limit) /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */
	    {
	      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
	      mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (long_double)integer(x) + real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(x));
	  mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, integer(x), 1);
	  mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(integer_ratio_add_if_overflow_to_real_or_rational(sc, y, x));
	case T_RATIO:
	  {
	    s7_int d1, d2, n1, n2;
	    parcel_out_fractions(x, y);
	    if (d1 == d2)
	      {
#if Have_Overflow_Checks
		s7_int q;
		if (add_overflow(n1, n2, &q))
#if With_Gmp
		  {
		    mpq_set_si(sc->mpq_1, n1, d1);
		    mpq_set_si(sc->mpq_2, n2, d2);
		    mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		    return(mpq_to_rational(sc, sc->mpq_1));
		  }
#else
		  {
 		    if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1);
		    return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1));
		  }
#endif
	        return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1));
#else
		return(make_ratio_with_div_check(sc, sc->add_symbol, n1 + n2, d1));
#endif
	      }

#if Have_Overflow_Checks
	    {
	      s7_int n1d2, n2d1, d1d2, q;
	      if ((multiply_overflow(d1, d2, &d1d2)) ||
		  (multiply_overflow(n1, d2, &n1d2)) ||
		  (multiply_overflow(n2, d1, &n2d1)) ||
		  (add_overflow(n1d2, n2d1, &q)))
#if With_Gmp
		{
		  mpq_set_si(sc->mpq_1, n1, d1);
		  mpq_set_si(sc->mpq_2, n2, d2);
		  mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		  return(mpq_to_rational(sc, sc->mpq_1));
		}
#else
	        {
 		  if (With_Warnings)
		    s7_warn(sc, s7_Warn_Bufsize, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2);
	          return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2)));
		}
#endif
	      return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2));
	    }
#else
	    return(make_ratio_with_div_check(sc, sc->add_symbol, n1 * d2 + n2 * d1, d1 * d2));
#endif
	  }
	case T_REAL:
	  return(make_real(sc, fraction(x) + real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, (s7_double)fraction(x) + real_part(y), imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_set_z(sc->mpq_2, big_integer(y));
	  mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}

    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
#if With_Gmp
	  if (s7_int_abs(integer(y)) >= Int64_To_Double_Limit) /* (+ .1 9223372036854775807) */
	    {
	      mpfr_set_si(sc->mpfr_1, integer(y), Mpfr_Rndn);
	      mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, real(x) + (long_double)integer(y)));
	case T_RATIO:
	  return(make_real(sc, real(x) + (s7_double)fraction(y)));
	case T_REAL:
	  return(make_real(sc, real(x) + real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_add_d(sc->mpfr_1, big_real(y), real(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x)));
	case T_RATIO:
	  return(make_complex_not_0i(sc, real_part(x) + (s7_double)fraction(y), imag_part(x)));
	case T_REAL:
	  return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x)));
	case T_COMPLEX:
	  return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(y));
	  mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_RATIO:
	  mpq_set_z(sc->mpq_2, big_integer(x));
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpz_add(sc->mpz_1, big_integer(x), big_integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  mpq_set_si(sc->mpq_1, integer(y), 1);
	  mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpq_set_z(sc->mpq_1, big_integer(y));
	  mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_add_d(sc->mpfr_1, big_real(x), real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_add(sc->mpfr_1, big_real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_REAL:
	  /* if (is_NaN(real(y))) return(y); */
	  mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
	  mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, A_Number_String, 2));
	}
#endif
      default:
	return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, A_Number_String, 1));
    }
}

#if !With_Gmp
static inline s7_pointer add_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y)
{
#if Have_Overflow_Checks
  s7_int val;
  if (add_overflow(x, y, &val))
    {
      if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y);
      return(wrap_real(sc, (long_double)x + (long_double)y));
    }
  return(wrap_integer(sc, val));
#else
  return(wrap_integer(sc, x + y));
#endif
}

static s7_pointer add_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (is_t_integer(x))
    {
      if (is_t_integer(y))
	return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y)));
#if !With_Gmp
      if (is_t_real(y))
	return(wrap_real(sc, (long_double)integer(x) + real(y)));
#endif
    }
  else
    if (is_t_real(x))
      {
	if (is_t_real(y))
	  return(wrap_real(sc, real(x) + real(y)));
      }
    else
      if ((is_t_complex(x)) && (is_t_complex(y)))
	return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y)));
	case T_REAL:
	  return(wrap_real(sc, (long_double)integer(x) + real(y)));
	case T_COMPLEX:
	  return(wrap_complex(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y)));
	}

    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(wrap_real(sc, real(x) + (long_double)integer(y)));
	case T_REAL:
	  return(make_real(sc, real(x) + real(y)));
	case T_COMPLEX:
	  return(wrap_complex(sc, real(x) + real_part(y), imag_part(y)));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  return(wrap_complex(sc, real_part(x) + integer(y), imag_part(x)));
	case T_REAL:
	  return(wrap_complex(sc, real_part(x) + real(y), imag_part(x)));
	case T_COMPLEX:
	  return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
	}}
  return(add_p_pp(sc, x, y));
}
#else
#define add_p_pp_wrapped add_p_pp
#endif

static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z)
{
  if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z)))
    {
#if Have_Overflow_Checks
      s7_int val;
      if ((!add_overflow(integer(x), integer(y), &val)) &&
	  (!add_overflow(val, integer(z), &val)))
	return(make_integer(sc, val));
#if With_Gmp
      mpz_set_si(sc->mpz_1, integer(x));
      mpz_set_si(sc->mpz_2, integer(y));
      mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
      mpz_set_si(sc->mpz_2, integer(z));
      mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
      return(mpz_to_integer(sc, sc->mpz_1));
#else
      if (With_Warnings)
	s7_warn(sc, s7_Warn_Bufsize, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(x), integer(y), integer(z));
      return(make_real(sc, (long_double)integer(x) + (long_double)integer(y) + (long_double)integer(z)));
#endif
#else
      return(make_integer(sc, integer(x) + integer(y) + integer(z)));
#endif
    }
  if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z)))
    return(make_real(sc, real(x) + real(y) + real(z)));
  {
    s7_pointer num = add_p_pp_wrapped(sc, x, y);
    sc->error_argnum = 1;
    num = add_p_pp(sc, num, z);
    sc->error_argnum = 0;
    return(num);
  }
}

static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
{
  #define H_add "(+ ...) adds its arguments"
  #define Q_add sc->pcl_n

  s7_pointer x, p;
  if (is_null(args))
    return(Int_Zero);
  x = car(args);
  p = cdr(args);
  if (is_null(p))
    {
      if (!is_number(x))
	return(method_or_bust_p(sc, x, sc->add_symbol, A_Number_String));
      return(x);
    }
  if (is_null(cdr(p)))
    return(add_p_pp(sc, x, car(p)));
  for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++)
    x = add_p_pp_wrapped(sc, x, car(p));
  x = add_p_pp(sc, x, car(p));
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_add_ii(s7_scheme *sc, s7_pointer args) /* this doesn't matter much, to my disappointment */
{
  return(add_if_overflow_to_real_or_big_integer(sc, integer(car(args)), integer(cadr(args))));
}

static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_ppp(sc, car(args), cadr(args), caddr(args)));}

static s7_pointer g_add_4(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = add_p_pp_wrapped(sc, car(args), cadr(args));
  s7_pointer p = cddr(args);
  sc->error_argnum = 2;
  p = add_p_pp(sc, x, add_p_pp_wrapped(sc, car(p), cadr(p)));
  sc->error_argnum = 0;
  return(p);
}

static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos)
{
  if (is_t_integer(x))
    return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1));

  switch (type(x))
    {
    case T_RATIO:   return(integer_ratio_add_if_overflow_to_real_or_rational(sc, Int_One, x)); /* return(add_p_pp(sc, x, Int_One)) */
    case T_REAL:    return(make_real(sc, real(x) + 1.0));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER:
      mpz_set_si(sc->mpz_1, 1);
      mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(add_p_pp(sc, x, Int_One));
#endif
    default:
      return(method_or_bust(sc, x, sc->add_symbol,
			    (pos == 1) ? set_plist_2(sc, x, Int_One) : set_plist_2(sc, Int_One, x),
			    A_Number_String, pos));
    }
  return(x);
}

#if With_Gmp
static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, car(args), 1));}
#else
static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args);
  if (is_t_integer(x)) return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); /* return(make_integer(sc, integer(x) + 1)); */
  if (is_t_real(x)) return(make_real(sc, real(x) + 1.0));
  if (is_t_complex(x)) return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
  return(add_p_pp(sc, x, Int_One));
}
#endif
static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));}

static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y, int32_t loc)
{
  if (is_t_integer(x))
    return(add_if_overflow_to_real_or_big_integer(sc, integer(x), y));

  switch (type(x))
    {
    case T_RATIO:   return(add_p_pp(sc, x, wrap_integer(sc, y)));
    case T_REAL:    return(make_real(sc, real(x) + y));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER:
      mpz_set_si(sc->mpz_1, y);
      mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(add_p_pp(sc, x, wrap_integer(sc, y)));
#endif
    default: return(method_or_bust_pp(sc, x, sc->add_symbol, x, make_integer(sc, y), A_Number_String, loc));
    }
  return(x);
}

static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t loc)
{
  if (is_t_real(x)) return(make_real(sc, real(x) + y));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) + y));
    case T_RATIO:   return(make_real(sc, (s7_double)fraction(x) + y));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(add_p_pp(sc, x, wrap_real(sc, y)));
#endif
    default: return(method_or_bust_pp(sc, x, sc->add_symbol, x, make_real(sc, y), A_Number_String, loc));
    }
  return(x);
}

static s7_pointer add_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_add_xi(sc, p1, i1, 1));}
static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} /* very few calls */
static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));}    /* no calls */
static s7_double add_d_d(s7_double x) {return(x);}
static s7_double add_d_dd(s7_double x1, s7_double x2) {return(x1 + x2);}
static s7_double add_d_id(s7_int x1, s7_double x2) {return(x1 + x2);}
static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 + x2 + x3);}
static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 + x2 + x3 + x4);}
static s7_int add_i_ii(s7_int i1, s7_int i2) {return(i1 + i2);}
static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 + i2 + i3);}

static bool is_int_arg(s7_scheme *sc, s7_pointer arg)
{
  if (is_t_integer(arg)) return(true);
  if (is_pair(arg))
    {
      s7_pointer sig = NULL;
      if (is_c_function(car(arg)))
	sig = c_function_signature(car(arg));
      else
	if ((is_symbol(car(arg))) && (is_defined_global(car(arg))) && (is_c_function(global_value(car(arg)))))
	  sig = c_function_signature(global_value(car(arg)));
      if ((sig) && (is_pair(sig)) && (car(sig) == sc->is_integer_symbol))
	return(true);
    }
  return(false);
}

static bool has_two_int_args(s7_scheme *sc, s7_pointer expr)
{
  /* maybe support (apply int-func...), also the global business is wrong if it is currently shadowed */
  return((is_int_arg(sc, cadr(expr))) &&
	 (is_int_arg(sc, caddr(expr))));
}

static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args);
/* C should let forward declarations be local to the procedure they occur in */

static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args);
static s7_pointer g_multiply_2_wrapped(s7_scheme *sc, s7_pointer args);

static s7_pointer 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 (has_two_int_args(sc, expr)) return(sc->add_2_ints);
      if (arg2 == Int_One) return(sc->add_x1);   /* (+ ... 1) */
      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);   /* (+ 1 ...) */
      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)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped);
      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) /* "negate" confuses C++ */
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == s7_Int64_Min)
#if With_Gmp
	{
	  mpz_set_si(sc->mpz_1, s7_Int64_Min);
	  mpz_neg(sc->mpz_1, sc->mpz_1);
	  return(mpz_to_big_integer(sc, sc->mpz_1));
	}
#else
	sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37));
#endif
      return(make_integer(sc, -integer(x)));

    case T_RATIO:   return(make_simpler_ratio(sc, -numerator(x), denominator(x)));
    case T_REAL:    return(make_real(sc, -real(x)));
    case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(x), -imag_part(x)));

#if With_Gmp
    case T_BIG_INTEGER:
      mpz_neg(sc->mpz_1, big_integer(x));
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO:
      mpq_neg(sc->mpq_1, big_ratio(x));
      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
    case T_BIG_REAL:
      mpfr_neg(sc->mpfr_1, big_real(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_neg(sc->mpc_1, big_complex(x), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_p(sc, x, sc->subtract_symbol, A_Number_String));
    }
}

static inline s7_pointer subtract_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
{
#if Have_Overflow_Checks
  s7_int val;
  if (subtract_overflow(x, y, &val))
#if With_Gmp
    {
      mpz_set_si(sc->mpz_1, x);
      mpz_set_si(sc->mpz_2, y);
      mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2);
      return(mpz_to_big_integer(sc, sc->mpz_1));
    }
#else
    {
      if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y);
      return(make_real(sc, (long_double)x - (long_double)y));
    }
#endif
  return(make_integer(sc, val));
#else
  return(make_integer(sc, x - y));
#endif
}

static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0)
	return(negate_p_p(sc, y));
      switch (type(y))
	{
	case T_INTEGER:
	  return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y)));

	case T_RATIO:
	  {
#if Have_Overflow_Checks
	    s7_int z;
	    if ((multiply_overflow(integer(x), denominator(y), &z)) ||
		(subtract_overflow(z, numerator(y), &z)))
#if With_Gmp
	      {
		mpz_set_si(sc->mpz_1, integer(x));
		mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y));
		mpz_set_si(sc->mpz_2, numerator(y));
		mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2);
		mpz_set_si(mpq_denref(sc->mpq_1), denominator(y));
		return(mpq_to_rational(sc, sc->mpq_1));
	      }
#else
	      {
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y));
		return(make_real(sc, (long_double)integer(x) - fraction(y)));
	      }
#endif
	      return(make_ratio(sc, z, denominator(y)));
#else
	    return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y)));
#endif
	  }
	case T_REAL:
#if With_Gmp
	  if (s7_int_abs(integer(x)) >= Int64_To_Double_Limit) /* (- 9223372036854775807 .1) */
	    {
	      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
	      mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (long_double)integer(x) - real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(x));
	  mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, integer(x), 1);
	  mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  {
#if Have_Overflow_Checks
	    s7_int z;
	    if ((multiply_overflow(integer(y), denominator(x), &z)) ||
		(subtract_overflow(numerator(x), z, &z)))
#if With_Gmp
	      {
		mpz_set_si(sc->mpz_1, integer(y));
		mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x));
		mpz_set_si(sc->mpz_2, numerator(x));
		mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1);
		mpz_set_si(mpq_denref(sc->mpq_1), denominator(x));
		return(mpq_to_rational(sc, sc->mpq_1));
	      }
#else
	      {
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y));
		return(make_real(sc, fraction(x) - (long_double)integer(y)));
	      }
#endif
	    return(make_ratio(sc, z, denominator(x)));
#else
	    return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x)));
#endif
	  }
	case T_RATIO:
	  {
	    s7_int d1, d2, n1, n2;
	    parcel_out_fractions(x, y);
	    if (d1 == d2)
	      {
#if Have_Overflow_Checks
		s7_int q;
		if (subtract_overflow(n1, n2, &q))
#if With_Gmp
		  {
		    mpq_set_si(sc->mpq_1, n1, d1);
		    mpq_set_si(sc->mpq_2, n2, d2);
		    mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		    return(mpq_to_rational(sc, sc->mpq_1));
		  }
#else
		  {
		    if (With_Warnings)
		      s7_warn(sc, s7_Warn_Bufsize, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2);
		    return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1));
		  }
#endif
	        return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1));
#else
		return(make_ratio(sc, numerator(x) - numerator(y), denominator(x)));
#endif
	      }

#if Have_Overflow_Checks
	    {
	      s7_int n1d2, n2d1, d1d2, q;
	      if ((multiply_overflow(d1, d2, &d1d2)) ||
		  (multiply_overflow(n1, d2, &n1d2)) ||
		  (multiply_overflow(n2, d1, &n2d1)) ||
		  (subtract_overflow(n1d2, n2d1, &q)))
#if With_Gmp
		{
		  mpq_set_si(sc->mpq_1, n1, d1);
		  mpq_set_si(sc->mpq_2, n2, d2);
		  mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		  return(mpq_to_rational(sc, sc->mpq_1));
		}
#else
	        {
		  if (With_Warnings)
		    s7_warn(sc, s7_Warn_Bufsize, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2);
		  return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2)));
		}
#endif
	      return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2));
	    }
#else
	    return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2));
#endif
	  }
	case T_REAL:
	  return(make_real(sc, (s7_double)fraction(x) - real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, (s7_double)fraction(x) - real_part(y), -imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_set_z(sc->mpq_2, big_integer(y));
	  mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpfr_set_q(sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
	  mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}

    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
#if With_Gmp
	  if (s7_int_abs(integer(y)) >= Int64_To_Double_Limit) /* (- .1 92233720368547758071) */
	    {
	      mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	      mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */
	case T_RATIO:
	  return(make_real(sc, real(x) - (s7_double)fraction(y)));
	case T_REAL:
	  return(make_real(sc, real(x) - real(y)));
	case T_COMPLEX:
	  return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x)));
	case T_RATIO:
	  return(make_complex_not_0i(sc, real_part(x) - (s7_double)fraction(y), imag_part(x)));
	case T_REAL:
	  return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x)));
	case T_COMPLEX:
	  return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  mpz_set_si(sc->mpz_1, integer(y));
	  mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1);
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_RATIO:
	  mpq_set_z(sc->mpq_2, big_integer(x));
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpz_sub(sc->mpz_1, big_integer(x), big_integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}

    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  mpq_set_si(sc->mpq_1, integer(y), 1);
	  mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpq_set_z(sc->mpq_1, big_integer(y));
	  mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_REAL:
	  /* if (is_NaN(real(y))) return(y); */
	  mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
	  mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, A_Number_String, 2));
	}
#endif
      default:
	return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, A_Number_String, 1));
    }
}

#if !With_Gmp
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));
}

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, s7_Warn_Bufsize, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y);
      return(wrap_real(sc, (long_double)x - (long_double)y));
    }
  return(wrap_integer(sc, val));
#else
  return(wrap_integer(sc, x - y));
#endif
}

static s7_pointer subtract_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(negate_p_p_wrapped(sc, y));
      switch (type(y))
	{
	case T_INTEGER:	  return(subtract_if_overflow_to_real_wrapped(sc, integer(x), integer(y)));
	case T_REAL:	  return(wrap_real(sc, (long_double)integer(x) - real(y)));
	case T_COMPLEX:	  return(wrap_complex(sc, (long_double)integer(x) - real_part(y), -imag_part(y)));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:	  return(wrap_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */
	case T_REAL:	  return(wrap_real(sc, real(x) - real(y)));
	case T_COMPLEX:	  return(wrap_complex(sc, real(x) - real_part(y), -imag_part(y)));
	}
    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:	  return(wrap_complex(sc, real_part(x) - integer(y), imag_part(x)));
	case T_REAL:	  return(wrap_complex(sc, real_part(x) - real(y), imag_part(x)));
	case T_COMPLEX:	  return(wrap_real_or_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
	}}
  return(subtract_p_pp(sc, x, y));
}
#else
#define subtract_p_pp_wrapped subtract_p_pp
#endif

static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
{
  #define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given"
  #define Q_subtract sc->pcl_n

  s7_pointer x = car(args), p = cdr(args);
  if (is_null(p))
    return(negate_p_p(sc, x));
  for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++)
    x = subtract_p_pp_wrapped(sc, x, car(p));
  x = subtract_p_pp(sc, x, car(p));
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args) {return(negate_p_p(sc, car(args)));}
static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) /* wrapped version gets no hits */
{
  s7_pointer x = car(args);
  x = subtract_p_pp_wrapped(sc, x, cadr(args));
  sc->error_argnum = 1;
  x = subtract_p_pp(sc, x, caddr(args));
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER: return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), 1));
    case T_RATIO:   return(subtract_p_pp(sc, x, Int_One));
    case T_REAL:    return(make_real(sc, real(x) - 1.0));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(subtract_p_pp(sc, x, Int_One));
#endif
    default:
      return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, Int_One, A_Number_String, 1));
    }
  return(x);
}

static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer num = car(args);
#if With_Gmp
  return(subtract_p_pp(sc, num, Int_One));
#endif
  /* return((is_t_integer(num)) ? make_integer(sc, integer(num) - 1) : minus_c1(sc, num)); */
  return((is_t_integer(num)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1) : minus_c1(sc, num));
}

static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */
{
  const s7_pointer x = car(args);
  const s7_double n = real(cadr(args)); /* checked below is_t_real */
  if (is_t_real(x)) return(make_real(sc, real(x) - n));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) - n));
    case T_RATIO:   return(make_real(sc, (s7_double)fraction(x) - n));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(subtract_p_pp(sc, x, cadr(args)));
#endif
    default:
      return(method_or_bust(sc, x, sc->subtract_symbol, args, A_Number_String, 1));
    }
  return(x);
}

static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */
{
  const s7_pointer x = cadr(args);
  const s7_double n = real(car(args)); /* checked below is_t_real */

  if (is_t_real(x)) return(make_real(sc, n - real(x)));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, n - integer(x)));
    case T_RATIO:   return(make_real(sc, n - (s7_double)fraction(x)));
    case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(subtract_p_pp(sc, car(args), x));
#endif
    default:
      return(method_or_bust(sc, x, sc->subtract_symbol, args, A_Number_String, 1));
    }
  return(x);
}

static s7_int subtract_i_ii(s7_int i1, s7_int i2) {return(i1 - i2);}
static s7_int subtract_i_i(s7_int x) {return(-x);}
static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 - i2 - i3);}
static s7_double subtract_d_d(s7_double x) {return(-x);}
static s7_double subtract_d_dd(s7_double x1, s7_double x2) {return(x1 - x2);}
static s7_double subtract_d_id(s7_int x1, s7_double x2) {return(x1 - x2);}
static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 - x2 - x3);}
static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 - x2 - x3 - x4);}
static s7_pointer subtract_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));}
static s7_pointer subtract_p_ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(make_integer(sc, i1 - i2));}

static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y)
{
  if (is_t_integer(x))
    return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), y));

  switch (type(x))
    {
    case T_RATIO:   return(make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) - y));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - y, imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER:
      mpz_set_si(sc->mpz_1, y);
      mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(subtract_p_pp(sc, x, wrap_integer(sc, y)));
#endif
    default: return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, make_integer(sc, y), A_Number_String, 1));
    }
  return(x);
}

static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 1) return(sc->subtract_1);
  if (args == 2)
    {
      const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
      /* 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);
      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)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped);
      return(sc->subtract_2);
    }
  return((args == 3) ? sc->subtract_3 : func);
}


/* ---------------------------------------- multiply ---------------------------------------- */
#define Quotient_Float_Limit 1e13
#define Quotient_Int_Limit 10000000000000
/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */

static inline s7_pointer multiply_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
{
#if Have_Overflow_Checks
  s7_int val;
  if (multiply_overflow(x, y, &val))
#if With_Gmp
    {
      mpz_set_si(sc->mpz_1, x);
      mpz_mul_si(sc->mpz_1, sc->mpz_1, y);
      return(mpz_to_big_integer(sc, sc->mpz_1));
    }
#else
    {
      if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y);
      return(make_real(sc, (s7_double)x * (s7_double)y));
    }
#endif
    return(make_integer(sc, val));
#else
  return(make_integer(sc, x * y));
#endif
}

static s7_pointer integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme *sc, s7_int x, s7_pointer y)
{
#if Have_Overflow_Checks
  s7_int z;
  if (multiply_overflow(x, numerator(y), &z))
#if With_Gmp
    {
      mpz_set_si(sc->mpz_1, x);
      mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y));
      mpq_set_si(sc->mpq_1, 1, denominator(y));
      mpq_set_num(sc->mpq_1, sc->mpz_1);
      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
    }
#else
    {
      if (With_Warnings)
	s7_warn(sc, s7_Warn_Bufsize, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y));
      return(make_real(sc, (s7_double)x * (s7_double)fraction(y)));
    }
#endif
    return(make_ratio(sc, z, denominator(y)));
#else
  return(make_ratio(sc, x * numerator(y), denominator(y)));
#endif
}

static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y)));
	case T_RATIO:
	  return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(x), y));
	case T_REAL:
#if With_Gmp
	  if (s7_int_abs(integer(x)) > Quotient_Int_Limit)
	    {
	      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
	      mpfr_set_d(sc->mpfr_2, real(y), Mpfr_Rndn);
	      mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (long_double)integer(x) * real(y)));
	case T_COMPLEX:
	  return(make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpz_mul_si(sc->mpz_1, big_integer(y), integer(x));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, integer(x), 1);
	  mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(y), x));
	case T_RATIO:
	  {
	    s7_int d1, d2, n1, n2;
	    parcel_out_fractions(x, y);
#if Have_Overflow_Checks
	    {
	      s7_int n1n2, d1d2;
	      if ((multiply_overflow(d1, d2, &d1d2)) ||
		  (multiply_overflow(n1, n2, &n1n2)))
#if With_Gmp
		{
		  mpq_set_si(sc->mpq_1, n1, d1);
		  mpq_set_si(sc->mpq_2, n2, d2);
		  mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
		}
#else
	        {
		  if (With_Warnings)
		    s7_warn(sc, s7_Warn_Bufsize, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2);
		  return(make_real(sc, (s7_double)fraction(x) * (s7_double)fraction(y)));
		}
#endif
	      return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2));
	    }
#else
	    return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2));
#endif
	  }
	case T_REAL:
#if With_Gmp
	  if (numerator(x) > Quotient_Int_Limit)
	    {
	      mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	      mpfr_set_q(sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
	      mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (s7_double)fraction(x) * real(y)));
	case T_COMPLEX:
	  return(make_complex(sc, (s7_double)fraction(x) * real_part(y), (s7_double)fraction(x) * imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_set_z(sc->mpq_2, big_integer(y));
	  mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
#if With_Gmp
	  if (s7_int_abs(integer(y)) > Quotient_Int_Limit)
	    {
	      mpfr_set_si(sc->mpfr_1, integer(y), Mpfr_Rndn);
	      mpfr_set_d(sc->mpfr_2, real(x), Mpfr_Rndn);
	      mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, real(x) * (long_double)integer(y)));
	case T_RATIO:
#if With_Gmp
	  if (numerator(y) > Quotient_Int_Limit)
	    {
	      mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	      mpfr_set_q(sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
	      mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (s7_double)fraction(y) * real(x)));
	case T_REAL:
	  return(make_real(sc, real(x) * real(y)));
	case T_COMPLEX:
	  return(make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y)));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y)));
	case T_RATIO:
	  return(make_complex(sc, real_part(x) * (s7_double)fraction(y), imag_part(x) * (s7_double)fraction(y)));
	case T_REAL:
	  return(make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y)));
	case T_COMPLEX:
	  {
	    s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y);
	    return(make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
	  }
#if With_Gmp
	case T_BIG_INTEGER:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  mpz_mul_si(sc->mpz_1, big_integer(x), integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_RATIO:
	  mpq_set_z(sc->mpq_2, big_integer(x));
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpz_mul(sc->mpz_1, big_integer(x), big_integer(y));
	  return(mpz_to_integer(sc, sc->mpz_1));
	case T_BIG_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  mpq_set_si(sc->mpq_1, integer(y), 1);
	  mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpq_set_z(sc->mpq_1, big_integer(y));
	  mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_REAL:
	  /* if (is_NaN(real(y))) return(y); */
	  mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
	  mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_COMPLEX:
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
	  mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, A_Number_String, 2));
	}
#endif
      default:
	return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, A_Number_String, 1));
    }
}

#if !With_Gmp
static inline s7_pointer multiply_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y)
{
#if Have_Overflow_Checks
  s7_int val;
  if (multiply_overflow(x, y, &val))
    {
      if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y);
      return(wrap_real(sc, (s7_double)x * (s7_double)y));
    }
    return(wrap_integer(sc, val));
#else
  return(wrap_integer(sc, x * y));
#endif
}

static s7_pointer multiply_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:	  return(multiply_if_overflow_to_real_wrapped(sc, integer(x), integer(y)));
	case T_REAL:	  return(wrap_real(sc, (long_double)integer(x) * real(y)));
	case T_COMPLEX:	  return(wrap_real_or_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y)));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:	  return(wrap_real(sc, real(x) * (long_double)integer(y)));
	case T_REAL:	  return(wrap_real(sc, real(x) * real(y)));
	case T_COMPLEX:	  return(wrap_real_or_complex(sc, real(x) * real_part(y), real(x) * imag_part(y)));
	}
    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:	  return(wrap_real_or_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y)));
	case T_REAL:	  return(wrap_real_or_complex(sc, real_part(x) * real(y), imag_part(x) * real(y)));
	case T_COMPLEX:
	  {
	    s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y);
	    return(wrap_real_or_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
	  }}}
  return(multiply_p_pp(sc, x, y));
}
#else
#define multiply_p_pp_wrapped multiply_p_pp
#endif

static s7_pointer multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z)
{
  /* no hits for reals in tnum */
  /* if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) return(make_real(sc, real(x) * real(y) * real(z))); */
  x = multiply_p_pp_wrapped(sc, x, y);
  sc->error_argnum = 1;
  x = multiply_p_pp(sc, x, z);
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer multiply_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer args, s7_pointer typ, int32_t num)
{
  if (has_active_methods(sc, obj))
    return(find_and_apply_method(sc, obj, sc->multiply_symbol, args));
  if (num == 0)
    sole_arg_wrong_type_error_nr(sc, sc->multiply_symbol, obj, typ);
  wrong_type_error_nr(sc, sc->multiply_symbol, num, obj, typ);
  return(NULL);
}

static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
{
  #define H_multiply "(* ...) multiplies its arguments"
  #define Q_multiply sc->pcl_n

  s7_pointer x, p;
  if (is_null(args))
    return(Int_One);
  x = car(args);
  p = cdr(args);
  if (is_null(p))
    {
      if (!is_number(x))
	return(multiply_method_or_bust(sc, x, args, A_Number_String, 0));
      return(x);
    }
  for (sc->error_argnum = 0; is_pair(cdr(p)); p = cdr(p), sc->error_argnum++)
    x = multiply_p_pp_wrapped(sc, x, car(p));
  x = multiply_p_pp(sc, x, car(p));
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));}
static s7_pointer g_multiply_2_wrapped(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp_wrapped(sc, car(args), cadr(args)));}
static s7_pointer g_multiply_3(s7_scheme *sc, s7_pointer args) {return(multiply_p_ppp(sc, car(args), cadr(args), caddr(args)));}

static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, int32_t loc)
{
  switch (type(x))
    {
    case T_INTEGER: return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), n));
    case T_RATIO:   return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, n, x));
    case T_REAL:    return(make_real(sc, real(x) * n));
    case T_COMPLEX: return(make_complex(sc, real_part(x) * n, imag_part(x) * n));
#if With_Gmp
    case T_BIG_INTEGER:
      mpz_mul_si(sc->mpz_1, big_integer(x), n);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(multiply_p_pp(sc, x, wrap_integer(sc, n)));
#endif
    default:
      /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */
      return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, make_integer(sc, n), A_Number_String, loc));
    }
  return(x);
}

static s7_pointer multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));}

static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t num)
{
  /* it's possible to return different argument NaNs depending on the expression or how it is wrapped:
   *   (* (bignum +nan.0) +nan.123) -> nan.123
   *   (let () (define (func) (* (bignum +nan.0) +nan.123)) (func) (func)) -> nan.0
   * latter call is fx_c_aaa->fx_c_ac->g_mul_xf (if +nan.122 instead of +nan.0, we get +nan.122 so we always get one of the NaNs)
   */
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) * y));
    case T_RATIO:   return(make_real(sc, numerator(x) * y / denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * y));
    case T_COMPLEX: return(make_complex(sc, real_part(x) * y, imag_part(x) * y));
#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_RATIO:
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_REAL:
      mpfr_mul_d(sc->mpfr_1, big_real(x), y, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, make_real(sc, y), A_Number_String, num));
    }
  return(x);
}

static s7_int multiply_i_ii(s7_int i1, s7_int i2)
{
#if Have_Overflow_Checks
  s7_int val;
  if (multiply_overflow(i1, i2, &val))
    {
#if With_Warnings
      fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 ")\n", __func__, __LINE__, i1, i2);
#endif
      return(s7_Int64_Max); /* this is inconsistent with other unopt cases where an overflow -> double result */
    }
  /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */
  return(val);
#else
  return(i1 * i2);
#endif
}

static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
#if Have_Overflow_Checks
  s7_int val1, val2;
  if ((multiply_overflow(i1, i2, &val1)) ||
      (multiply_overflow(val1, i3, &val2)))
    {
#if With_Warnings
      fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", __func__, __LINE__, i1, i2, i3);
#endif
      return(s7_Int64_Max);
    }
  return(val2);
#else
  return(i1 * i2 * i3);
#endif
}

static s7_double multiply_d_d(s7_double x) {return(x);}
static s7_double multiply_d_dd(s7_double x1, s7_double x2) {return(x1 * x2);}
static s7_double multiply_d_id(s7_int x1, s7_double x2) {return(x1 * x2);}
static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 * x2 * x3);}
static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 * x2 * x3 * x4);}
static s7_pointer mul_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 * x2));}

static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  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)
{
#if With_Gmp
  s7_pointer x;
#endif
  switch (type(num))
    {
    case T_INTEGER:
#if With_Gmp && (!Pointer_32)
      if (integer(num) == s7_Int64_Min) /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */
	{
	  new_cell(sc, x, T_BIG_RATIO);
	  big_ratio_bgr(x) = alloc_bigrat(sc);
	  add_big_ratio(sc, x);
	  mpz_set_si(sc->mpz_1, s7_Int64_Max);
	  mpz_set_si(sc->mpz_2, 1);
	  mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	  mpq_set_si(big_ratio(x), -1, 1);
	  mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */
	  return(x);
	}
#endif
      if (integer(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));

#if With_Gmp
    case T_BIG_INTEGER:
      if (mpz_cmp_ui(big_integer(num), 0) == 0)
	division_by_zero_error_1_nr(sc, sc->divide_symbol, num);
      if ((mpz_cmp_ui(big_integer(num), 1) == 0) || (mpz_cmp_si(big_integer(num), -1) == 0))
	return(num);
      new_cell(sc, x, T_BIG_RATIO);
      big_ratio_bgr(x) = alloc_bigrat(sc);
      add_big_ratio(sc, x);
      mpq_set_si(big_ratio(x), 1, 1);
      mpq_set_den(big_ratio(x), big_integer(num));
      mpq_canonicalize(big_ratio(x));
      return(x);
    case T_BIG_RATIO:
      if (mpz_cmp_ui(mpq_numref(big_ratio(num)), 1) == 0)
	return(mpz_to_integer(sc, mpq_denref(big_ratio(num))));
      if (mpz_cmp_si(mpq_numref(big_ratio(num)), -1) == 0)
	{
	  mpz_neg(sc->mpz_1, mpq_denref(big_ratio(num)));
	  return(mpz_to_integer(sc, sc->mpz_1));
	}
      new_cell(sc, x, T_BIG_RATIO);
      big_ratio_bgr(x) = alloc_bigrat(sc);
      add_big_ratio(sc, x);
      mpq_inv(big_ratio(x), big_ratio(num));
      mpq_canonicalize(big_ratio(x));
      return(x);
    case T_BIG_REAL:
      if (mpfr_zero_p(big_real(num)))
	division_by_zero_error_1_nr(sc, sc->divide_symbol, num);
      x = mpfr_to_big_real(sc, big_real(num));
      mpfr_ui_div(big_real(x), 1, big_real(x), Mpfr_Rndn);
      return(x);
    case T_BIG_COMPLEX:
      if ((!mpfr_number_p(mpc_realref(big_complex(num)))) || (!mpfr_number_p(mpc_imagref(big_complex(num)))))
	return(Complex_NaN);
      mpc_ui_div(sc->mpc_1, 1, big_complex(num), MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */
#endif
    default:
      if_method_exists_return_value(sc, num, sc->divide_symbol, set_plist_1(sc, num));
      wrong_type_error_nr(sc, sc->divide_symbol, 1, num, A_Number_String);
    }
  return(NULL);
}

static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  /* splitting out real/real here saves very little */
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	  /* -------- integer x -------- */
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  if (integer(x) == 1)  /* mainly to handle (/ 1 -9223372036854775808) correctly! */
	    return(invert_p_p(sc, y));
	  return(make_ratio(sc, integer(x), integer(y))); /* make_ratio calls gcd */
	case T_RATIO:
#if Have_Overflow_Checks
	  {
	    s7_int dn;
	    if (multiply_overflow(integer(x), denominator(y), &dn))
#if With_Gmp
	      {
		mpq_set_si(sc->mpq_1, integer(x), 1);
		mpq_set_si(sc->mpq_2, numerator(y), denominator(y));
		mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	      }
#else
              {
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y));
  	        return(make_real(sc, integer(x) * inverted_fraction(y)));
	      }
#endif
	    return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y)));
	  }
#else
	  return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y)));
#endif
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  if (is_inf(real(y))) return(Real_Zero);
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
#if With_Gmp
	  if ((s7_int_abs(integer(x))) > Quotient_Int_Limit)
	    {
	      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
	      mpfr_set_d(sc->mpfr_2, real(y), Mpfr_Rndn);
	      mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	      return(mpfr_to_big_real(sc, sc->mpfr_1));
	    }
#endif
	  return(make_real(sc, (s7_double)(integer(x)) / real(y)));
	case T_COMPLEX:
	  {
	    s7_double r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y);
	    s7_double den = 1.0 / (r2 * r2 + i2 * i2);
	    /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */
	    return(make_complex(sc, r1 * r2 * den, -(r1 * i2 * den)));
	  }

#if With_Gmp
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_si(sc->mpq_1, integer(x), 1);
	  mpq_set_den(sc->mpq_1, big_integer(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, integer(x), 1);
	  mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}
      break;

      /* -------- ratio x -------- */
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
#if Have_Overflow_Checks
	  {
	    s7_int dn;
	    if (multiply_overflow(denominator(x), integer(y), &dn))
#if With_Gmp
	      {
		mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
		mpq_set_si(sc->mpq_2, integer(y), 1);
		mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		return(mpq_to_rational(sc, sc->mpq_1));
	      }
#else
              {
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y));
	        return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y))));
	      }
#endif
	    return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn));
	  }
#else
	  return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y)));
#endif
	case T_RATIO:
	  {
	    s7_int d1, d2, n1, n2;
	    parcel_out_fractions(x, y);
	    if (d1 == d2)
	      return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2));
#if Have_Overflow_Checks
	    if ((multiply_overflow(n1, d2, &n1)) ||
		(multiply_overflow(n2, d1, &d1)))
	      {
#if With_Gmp
		mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */
		mpq_set_si(sc->mpq_2, n2, d2);
		mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		return(mpq_to_rational(sc, sc->mpq_1));
#else
		s7_double r1, r2;
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y));
		r1 = fraction(x);
		r2 = inverted_fraction(y);
		return(make_real(sc, r1 * r2));
#endif
	      }
	    return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1));
#else
	    return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1));
#endif
	  }
	case T_REAL:
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  return(make_real(sc, (s7_double)fraction(x) / real(y)));
	case T_COMPLEX:
	  {
	    s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y);
	    s7_double den = 1.0 / (r2 * r2 + i2 * i2);
	    return(make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */
	  }

#if With_Gmp
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_z(sc->mpq_1, big_integer(y));
	  mpq_set_si(sc->mpq_2, numerator(x), denominator(x));
	  mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpfr_set_q(sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
	  mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}

      /* -------- real x -------- */
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  if (is_NaN(real(x))) return(x); /* what is (/ +nan.0 0)? */
	  if (is_inf(real(x)))
	    return((real(x) > 0.0) ? ((integer(y) > 0) ? Real_Infinity : Real_Minus_Infinity) : ((integer(y) > 0) ? Real_Minus_Infinity : Real_Infinity));
	  return(make_real(sc, (long_double)real(x) / (long_double)integer(y)));
	case T_RATIO:
	  if (is_NaN(real(x))) return(x);
	  if (is_inf(real(x)))
	    return((real(x) > 0) ? ((numerator(y) > 0) ? Real_Infinity : Real_Minus_Infinity) : ((numerator(y) > 0) ? Real_Minus_Infinity : Real_Infinity));
	  return(make_real(sc, real(x) * inverted_fraction(y)));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  if (is_NaN(real(x))) return(x);
	  if (is_inf(real(y)))
	    return((is_inf(real(x))) ? Real_NaN : Real_Zero);
	  return(make_real(sc, real(x) / real(y)));
	case T_COMPLEX:
	  {
	    s7_double den, r2, i2;
	    if (is_NaN(real(x))) return(Complex_NaN);
	    r2 = real_part(y);
	    i2 = imag_part(y);
	    if ((is_NaN(r2)) || (is_inf(r2))) return(Complex_NaN);
	    if ((is_NaN(i2)) || (is_inf(i2))) return(Complex_NaN);
	    den = 1.0 / (r2 * r2 + i2 * i2);
	    return(make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den));
	  }

#if With_Gmp
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_set_z(sc->mpfr_1, big_integer(y), Mpfr_Rndn);
	  mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_d_div(sc->mpfr_1, real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((is_NaN(real(x))) || (!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}

      /* -------- complex x -------- */
    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  {
	    s7_double r1;
	    if (integer(y) == 0)
	      division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	    r1 = (long_double)1.0 / (long_double)integer(y);
	    return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1));
	  }
	case T_RATIO:
	  {
	    s7_double frac = inverted_fraction(y);
	    return(make_complex(sc, real_part(x) * frac, imag_part(x) * frac));
	  }
	case T_REAL:
	  {
	    s7_double r1;
	    if (real(y) == 0.0)
	      division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	    r1 = 1.0 / real(y);
	    return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */
	  }
	case T_COMPLEX:
	  {
	    const s7_double r1 = real_part(x);
	    s7_double r2, i1, i2, den;
	    if (is_NaN(r1)) return(x);
	    i1 = imag_part(x);
	    if (is_NaN(i1)) return(x);
	    r2 = real_part(y);
	    if (is_NaN(r2)) return(y);
	    if (is_inf(r2)) return(Complex_NaN);
	    i2 = imag_part(y);
	    if (is_NaN(i2)) return(y);
	    den = 1.0 / (r2 * r2 + i2 * i2);
	    return(make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den));
	  }

#if With_Gmp
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
#endif
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpz_set_si(sc->mpz_1, integer(y));
	  mpq_set_num(sc->mpq_1, big_integer(x));
	  mpq_set_den(sc->mpq_1, sc->mpz_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_RATIO:
	  mpq_set_z(sc->mpq_2, big_integer(x));
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */
	  mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(y);
	  if ((is_inf(real_part(y))) || (is_inf(imag_part(y)))) return(Complex_NaN);
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_num(sc->mpq_1, big_integer(x));
	  mpq_set_den(sc->mpq_1, big_integer(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, 0, 1);
	  mpq_set_num(sc->mpq_1, big_integer(x));
	  mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_si(sc->mpq_1, integer(y), 1);
	  mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_rational(sc, sc->mpq_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(y);
	  if ((is_inf(real_part(y))) || (is_inf(imag_part(y)))) return(Complex_NaN);
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpq_set_z(sc->mpq_1, big_integer(y));
	  mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_RATIO:
	  mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y));
	  return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
	  mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_div_d(sc->mpfr_1, big_real(x), real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_COMPLEX:
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(y);
	  if ((is_inf(real_part(y))) || (is_inf(imag_part(y)))) return(Complex_NaN);
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_RATIO:
	  mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpfr_div(sc->mpfr_1, big_real(x), big_real(y), Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}
    case T_BIG_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_REAL:
	  /* if (is_NaN(real(y))) return(y); */
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_COMPLEX:
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(y);
	  if ((is_inf(real_part(y))) || (is_inf(imag_part(y)))) return(Complex_NaN);
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_INTEGER:
	  if (mpz_cmp_ui(big_integer(y), 0) == 0)
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_RATIO:
	  mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
	  mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_REAL:
	  if (mpfr_zero_p(big_real(y)))
	    division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y);
	  mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	case T_BIG_COMPLEX:
	  if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y)))))
	    return(Complex_NaN);
	  mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
	  return(mpc_to_number(sc, sc->mpc_1));
	default:
	  return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, A_Number_String, 2));
	}
#endif

    default: /* x is not a built-in number */
      return(method_or_bust_pp(sc, x, sc->divide_symbol, x, y, A_Number_String, 1)); /* not args here! y = apply * to cdr(args) */
    }
  return(NULL); /* make the compiler happy */
}

static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
  #define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument"
  #define Q_divide sc->pcl_n

  s7_pointer x = car(args), p = cdr(args);
  if (is_null(p))            /* (/ x) */
    {
      if (!is_number(x))
	return(method_or_bust_p(sc, x, sc->divide_symbol, A_Number_String));
      return(invert_p_p(sc, x));
    }
  for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++)
    x = divide_p_pp(sc, x, car(p));
  sc->error_argnum = 0;
  return(x);
}

static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args) {return(invert_p_p(sc, car(args)));}
static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) {return(divide_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer num = car(args);
  if (is_t_integer(num))
    {
      s7_int i = integer(num);
      if (i & 1)
	{
	  s7_pointer x;
	  new_cell(sc, x, T_RATIO);
	  set_numerator(x, i);
	  set_denominator(x, 2);
	  return(x);
	}
      return(make_integer(sc, i >> 1));
    }
  switch (type(num))
    {
    case T_RATIO:
#if Have_Overflow_Checks
      {
	s7_int dn;
	if (multiply_overflow(denominator(num), 2, &dn))
	  {
	    if ((numerator(num) & 1) == 1)
#if With_Gmp
	      {
		mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
		mpq_set_si(sc->mpq_2, 1, 2);
		mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
		return(mpq_to_rational(sc, sc->mpq_1));
	      }
#else
	      {
		if (With_Warnings)
		  s7_warn(sc, s7_Warn_Bufsize, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num));
	        return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num)));
	      }
#endif
	    return(make_ratio(sc, numerator(num) / 2, denominator(num)));
	  }
	return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn));
      }
#else
      return(make_ratio(sc, numerator(num), denominator(num) * 2));
#endif
    case T_REAL:    return(make_real(sc, real(num) * 0.5));
    case T_COMPLEX: return(make_complex_not_0i(sc, real_part(num) * 0.5, imag_part(num) * 0.5));

#if With_Gmp
    case T_BIG_INTEGER:
      mpq_set_z(sc->mpq_1, big_integer(num));
      mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2);
      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
    case T_BIG_RATIO:
      mpq_set_si(sc->mpq_1, 2, 1);
      mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1);
      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
    case T_BIG_REAL:
      mpfr_div_si(sc->mpfr_1, big_real(num), 2, Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_BIG_COMPLEX:
      mpc_set_si(sc->mpc_1, 2, MPC_RNDNN);
      mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust_pp(sc, num, sc->divide_symbol, num, Int_Two, A_Number_String, 1));
    }
}

static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args)
{
  /* (/ 1.0 x) */
  const s7_pointer x = cadr(args);
  if (is_t_real(x))
    {
      const s7_double rl = real(x);
      if (rl == 0.0)
	division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x);
      return((is_NaN(rl)) ? x : make_real(sc, 1.0 / rl));
    }
  return(divide_p_pp(sc, car(args), x));
}

static s7_double divide_d_7d(s7_scheme *sc, s7_double x)
{
  if (x == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, Real_Zero);
  return(1.0 / x);
}

static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2)
{
  if (x2 == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, Real_Zero);
  return(x1 / x2);
}

static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));}
static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));}

static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 1) return(sc->invert_1);
  if (args == 2)
    {
      const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
      if ((is_t_real(arg1)) && (real(arg1) == 1.0)) return(sc->invert_x);
      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) /* inline = 4 in tmap, 3 in tari */
{
  if ((y > 0) || (y < -1)) return(x / y);
  if (y == 0)
    division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_integer(sc, x), Int_Zero);
  if (x == s7_Int64_Min)   /* (quotient most-negative-fixnum -1) */
    sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, set_elist_2(sc, LeastFix, Minus_One), It_Is_Too_Large_String);
  return(-x); /* (quotient x -1) */
}

#if !With_Gmp
static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf)   /* can't use "truncate" -- it's in unistd.h */
{
  if (fabs(xf) > Quotient_Float_Limit)
    sole_arg_out_of_range_error_nr(sc, caller, wrap_real(sc, xf), It_Is_Too_Large_String);
  return(make_integer(sc, (xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf)));
}

static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y)
{
  s7_double xf;
  if (y == 0.0)
    division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_real(sc, x), Real_Zero);
  if ((is_inf(y)) || (is_NaN(y))) /* here we can't return Nan so I guess we should signal an error */
    wrong_type_error_nr(sc, sc->quotient_symbol, 2, wrap_real(sc, y), A_Normal_Real_String);
  xf = x / y;
  if (fabs(xf) > Quotient_Float_Limit)
    sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, wrap_real(sc, xf), It_Is_Too_Large_String);
  return((xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf));
}
#endif

static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */

static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  if ((is_real(x)) && (is_real(y)))
    {
      if (is_zero(y))
	division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y);
      if ((s7_is_integer(x)) && (s7_is_integer(y)))
	{
	  if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x));
	  if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y));
	  mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	}
      else
	if ((!is_rational(x)) || (!is_rational(y)))
	  {
	    if (any_real_to_mpfr(sc, x, sc->mpfr_1)) return(make_nan_with_payload(sc, __LINE__));
	    if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(make_nan_with_payload(sc, __LINE__));
	    mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	    mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ);
	  }
	else
	  {
	    any_rational_to_mpq(sc, x, sc->mpq_1);
	    any_rational_to_mpq(sc, y, sc->mpq_2);
	    mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2);
	    mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3));
	  }
      return(mpz_to_integer(sc, sc->mpz_1));
    }
  return(method_or_bust_pp(sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1));
#else

  s7_int d1, d2, n1, n2;
  if ((is_t_integer(x)) && (is_t_integer(y)))
    return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y))));

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y))));
	case T_RATIO:
	  n1 = integer(x);
	  d1 = 1;
	  n2 = numerator(y);
	  d2 = denominator(y);
	  /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */
	  goto Ratio_Quo_Ratio;
	case T_REAL:
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y);
	  if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__));
	  if (is_NaN(real(y))) return(y);
	  return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */
	default:
	  return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2));
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y);
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = integer(y);
	  d2 = 1;
	  goto Ratio_Quo_Ratio;
	  /* this can lose:
	   *   (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1
	   *   (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0
	   */
	case T_RATIO:
	  parcel_out_fractions(x, y);
	Ratio_Quo_Ratio:
	  if (d1 == d2)
	    return(make_integer(sc, n1 / n2));              /* (quotient 3/9223372036854775807 1/9223372036854775807) */
	  if (n1 == n2)
	    return(make_integer(sc, d2 / d1));              /* (quotient 9223372036854775807/2 9223372036854775807/8) */
#if Have_Overflow_Checks
	  {
	    s7_int n1d2, n2d1;
	    if ((multiply_overflow(n1, d2, &n1d2)) ||
		(multiply_overflow(n2, d1, &n2d1)))
	      return(s7_truncate(sc, sc->quotient_symbol, ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1)));
	    return(make_integer(sc, n1d2 / n2d1));
	  }
#else
	  return(make_integer(sc, (n1 * d2) / (n2 * d1)));
#endif
	case T_REAL:
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y);
	  if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__));
	  if (is_NaN(real(y))) return(y);
	  return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y)));
	default:
	  return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    case T_REAL:
      if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y)))
	return(make_nan_with_payload(sc, __LINE__));
      /* if infs allowed we need to return infs/nans, else:
       *    (quotient inf.0 1e-309) -> -9223372036854775808
       *    (quotient inf.0 inf.0) -> -9223372036854775808
       */
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y);
	  return(s7_truncate(sc, sc->quotient_symbol, (long_double)real(x) / (long_double)integer(y)));

	case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y)));
	case T_REAL:  return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */
	default:      return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    default:
      return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2));
    }
#endif
}

static s7_pointer quotient_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
{
  if ((is_t_integer(x)) && ((y > 0) || (y < -1))) return(make_integer(sc, integer(x) / y));
  return(quotient_p_pp(sc, x, wrap_integer(sc, y)));
}

static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
{
  #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1"
  #define Q_quotient sc->pcl_r
  /* sig was '(integer? ...) but quotient can return NaN */
  /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */
  return(quotient_p_pp(sc, car(args), cadr(args)));
}


/* -------------------------------- remainder -------------------------------- */
#if With_Gmp
#define Use_Floor true
#define Dont_Use_Floor false

static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool use_floor)
{
  if ((is_real(x)) && (is_real(y)))
    {
      if ((s7_is_integer(x)) && (s7_is_integer(y)))
	{
	  if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x));
	  if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y));
	  if (use_floor)
	    mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2);
	  else mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2);
	  mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2);
	  mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3);
	  return(mpz_to_integer(sc, sc->mpz_1));
	}
      if ((!is_rational(x)) || (!is_rational(y)))
	{
	  any_real_to_mpfr(sc, x, sc->mpfr_1);
	  any_real_to_mpfr(sc, y, sc->mpfr_2);
	  mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	  if (use_floor)
	    mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD);
	  else mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ);
	  mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, Mpfr_Rndn);
	  mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, Mpfr_Rndn);
	  return(mpfr_to_big_real(sc, sc->mpfr_1));
	}
      any_rational_to_mpq(sc, x, sc->mpq_1);
      any_rational_to_mpq(sc, y, sc->mpq_2);
      mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2);
      if (use_floor)
	mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3));
      else mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3));
      mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2));
      mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
      return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
    }
  return(method_or_bust_pp(sc, (is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1));
}
#endif

#define Remainder_Float_Limit 1e13

static inline s7_int remainder_i_7ii(s7_scheme *sc, s7_int x, s7_int y)
{
  if ((y > 1) || (y < -1)) return(x % y); /* avoid floating exception if (remainder -9223372036854775808 -1)! */
  if (y == 0)
    division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_integer(sc, x), Int_Zero);
  return(0);
}

static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y)
{
  s7_int quo;
  s7_double pre_quo;
  if (is_NaN(y)) return(y);
  if (is_inf(y)) return(Nan);
  pre_quo = x / y;
  if (fabs(pre_quo) > Remainder_Float_Limit)
    sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, wrap_real(sc, x), wrap_real(sc, y)), It_Is_Too_Large_String);
  quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
  return(x - (y * quo));
}

static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 % i2);} /* i2 > 1 */
static s7_double remainder_d_7dd(s7_scheme *sc, s7_double 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));
}

static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  if (is_zero(y))
    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
  return(big_mod_or_rem(sc, x, y, Dont_Use_Floor));
#else
  s7_int quo, d1, d2, n1, n2;
  s7_double pre_quo;

  if ((is_t_integer(x)) && (is_t_integer(y)))
    return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y))));

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y))));
	case T_RATIO:
	  n1 = integer(x);
	  d1 = 1;
	  n2 = numerator(y);
	  d2 = denominator(y);
	  goto Ratio_Rem_Ratio;
	case T_REAL:
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	  if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__));
	  if (is_NaN(real(y))) return(y);
	  pre_quo = (long_double)integer(x) / (long_double)real(y);
	  if (fabs(pre_quo) > Remainder_Float_Limit)
	    sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), It_Is_Too_Large_String);
	  quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
	  return(make_real(sc, integer(x) - real(y) * quo));
	default:
	  return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  n2 = integer(y);
 	  if (n2 == 0)
 	    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	  n1 = numerator(x);
	  d1 = denominator(x);
	  d2 = 1;
	  goto Ratio_Rem_Ratio;
	case T_RATIO:
	  parcel_out_fractions(x, y);
	Ratio_Rem_Ratio:
	  if (d1 == d2)
	    quo = (s7_int)(n1 / n2);
	  else
	    {
	      if (n1 == n2)
		quo = (s7_int)(d2 / d1);
	      else
		{
#if Have_Overflow_Checks
		  s7_int n1d2, n2d1;
		  if ((multiply_overflow(n1, d2, &n1d2)) ||
		      (multiply_overflow(n2, d1, &n2d1)))
		    {
		      pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1);
		      if (fabs(pre_quo) > Remainder_Float_Limit)
			sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), It_Is_Too_Large_String);
		      quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
		    }
		  else quo = n1d2 / n2d1;
#else
		  quo = (n1 * d2) / (n2 * d1);
#endif
		}}
	  if (quo == 0)
	    return(x);
#if Have_Overflow_Checks
	  {
	    s7_int dn, nq;
	    if (!multiply_overflow(n2, quo, &nq))
	      {
		if ((d1 == d2) &&
		    (!subtract_overflow(n1, nq, &dn)))
		  return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1));

		if ((!multiply_overflow(n1, d2, &dn)) &&
		    (!multiply_overflow(nq, d1, &nq)) &&
		    (!subtract_overflow(dn, nq, &nq)) &&
		    (!multiply_overflow(d1, d2, &d1)))
		  return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1));
	      }}
#else
	  if (d1 == d2)
	    return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1));

	  return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2));
#endif
	  sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), Intermediate_Too_Large_String);
	case T_REAL:
	  {
	    s7_double frac;
	    if (real(y) == 0.0)
	      division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	    if (is_inf(real(y))) return(make_nan_with_payload(sc, __LINE__));
	    if (is_NaN(real(y))) return(y);
	    if (s7_int_abs(numerator(x)) > Quotient_Int_Limit)
	      return(subtract_p_pp(sc, x, multiply_p_pp_wrapped(sc, y, quotient_p_pp(sc, x, y))));
	    frac = (s7_double)fraction(x);
	    pre_quo = frac / real(y);
	    if (fabs(pre_quo) > Remainder_Float_Limit)
	      sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), It_Is_Too_Large_String);
	    quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
	    return(make_real(sc, frac - real(y) * quo));
	  }
	default:
	  return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    case T_REAL:
      if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y)))
	{
	  if (is_zero(y))
	    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	  return(make_nan_with_payload(sc, __LINE__));
	}
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	  /* actually here (and elsewhere) if y > Int64_To_Double_Limit, the result is probably wrong */
	  pre_quo = (long_double)real(x) / (long_double)integer(y);
	  if (fabs(pre_quo) > Remainder_Float_Limit)
	    sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), It_Is_Too_Large_String);
	  quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
	  return(make_real(sc, real(x) - integer(y) * quo));
	  /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */
	case T_RATIO:
	  if (s7_int_abs(numerator(y)) > Quotient_Int_Limit)
	    return(subtract_p_pp(sc, x, multiply_p_pp_wrapped(sc, y, quotient_p_pp(sc, x, y))));
	  {
	    const s7_double frac = (s7_double)fraction(y);
	    pre_quo = real(x) / frac;
	    if (fabs(pre_quo) > Remainder_Float_Limit)
	      sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), It_Is_Too_Large_String);
	    quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
	    return(make_real(sc, real(x) - frac * quo));
	  }
	case T_REAL:
	  if (real(y) == 0.0)
	    division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
	  return(make_real(sc, c_rem_dbl(sc, real(x), real(y))));
	  /* see under sin -- this calculation is completely bogus if "a" is large
	   * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688,
	   * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument!
	   * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range).
	   */
	default:
	  return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    default:
      return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1));
    }
#endif
}

static s7_pointer remainder_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
{
  if ((is_t_integer(x)) && ((y > 1) || (y < -1))) return(make_integer(sc, integer(x) % y)); /* the normal case (_i_7ii etc) */
  return(remainder_p_pp(sc, x, wrap_integer(sc, y)));
}

static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
  #define H_remainder "(remainder x y) returns the remainder of x/y; (remainder 10 3) = 1"
  #define Q_remainder sc->pcl_r
  /* (define (rem x y) (- x (* y (quo x y)))) ; slib, if y is an integer (- x (truncate x y)), fractional part: (remainder x 1) */

  const s7_pointer x = car(args), y = cadr(args);
  if ((is_t_integer(x)) && (is_t_integer(y)))
    return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y))));
  return(remainder_p_pp(sc, x, y));
}


/* -------------------------------- modulo -------------------------------- */
static s7_int modulo_i_ii(s7_int x, s7_int y)
{
  s7_int z;
  if (y > 1)
    {
      z = x % y;
      return((z >= 0) ? z : z + y);
    }
  if (y < -1)
    {
      z = x % y;
      return((z > 0) ? z + y : z);
    }
  if (y == 0) return(x);     /* else arithmetic exception */
  return(0);
}

static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) /* here we know i2 > 1 */
{
  s7_int z = i1 % i2;
  return((z < 0) ? (z + i2) : z);
}

static s7_double modulo_d_7dd(s7_scheme *sc, s7_double 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));
}

static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  /* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code
   *   originally   subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y))))
   *   quotient is                                            truncate_p_p(sc, divide_p_pp(sc, x, y))
   *   remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))
   */
  if (!is_zero(y)) return(big_mod_or_rem(sc, x, y, Use_Floor));
  if (is_real(x)) return(x);
  return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1));
#else
  s7_double a, b;
  s7_int n1, n2, d1, d2;
  if ((is_t_integer(x)) && (is_t_integer(y))) /* this is nearly always the case */
    return(make_integer(sc, modulo_i_ii(integer(x), integer(y))));

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_integer(sc, modulo_i_ii(integer(x), integer(y))));
	case T_RATIO:
	  n1 = integer(x);
	  d1 = 1;
	  n2 = numerator(y);
	  d2 = denominator(y);
	  if ((n1 == n2) && (d1 > d2)) return(x); /* signs match so this should be ok */
	  goto Ratio_Mod_Ratio;
	case T_REAL:
	  if ((integer(x) == s7_Int64_Min) || (s7_int_abs(integer(x)) > Quotient_Int_Limit))
	    out_of_range_error_nr(sc, sc->modulo_symbol, Int_One, x, It_Is_Too_Large_String);
	  b = real(y);
	  if (b == 0.0) return(x);
	  if (is_NaN(b)) return(y);
	  if (is_inf(b)) return(make_nan_with_payload(sc, __LINE__));
	  a = (s7_double)integer(x);
	  goto Real_Mod;
	default:
	  return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2));
	}
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) return(x);
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = integer(y);
	  if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x);
	  if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x);
	  if (n2 == s7_Int64_Min)
	    sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, set_elist_3(sc, sc->divide_symbol, x, y), Intermediate_Too_Large_String);
	  /* the problem here is that (modulo 3/2 most-negative-fixnum)
	   * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it.
	   */
	  if ((n1 == n2) && (d1 > 1)) return(x);
	  d2 = 1;
	  goto Ratio_Mod_Ratio;
	case T_RATIO:
	  parcel_out_fractions(x, y);
	  if (d1 == d2)
	    return(make_ratio_with_div_check(sc, sc->modulo_symbol, modulo_i_ii(n1, n2), d1));
	  if ((n1 == n2) && (d1 > d2)) return(x);
	Ratio_Mod_Ratio:
#if Have_Overflow_Checks
	  {
	    s7_int n2d1, n1d2, d1d2, fl;
	    if (!multiply_overflow(n2, d1, &n2d1))
	      {
		if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */
		  return(Int_Zero);
		if (!multiply_overflow(n1, d2, &n1d2))
		  {
		    fl = (s7_int)(n1d2 / n2d1);
		    if (((n1 < 0) && (n2 > 0)) ||
			((n1 > 0) && (n2 < 0)))
		      fl -= 1;
		    if (fl == 0)
		      return(x);
		    if ((!multiply_overflow(d1, d2, &d1d2)) &&
			(!multiply_overflow(fl, n2d1, &fl)) &&
			(!subtract_overflow(n1d2, fl, &fl)))
		      return(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2));
		  }}}
#else
	  {
	    s7_int fl;
	    const s7_int n1d2 = n1 * d2;
	    const 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:
	  {
	    const 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));
    }
#endif
}

static s7_pointer modulo_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
{
  if (is_t_integer(x)) return(make_integer(sc, modulo_i_ii(integer(x), y)));
  return(modulo_p_pp(sc, x, wrap_integer(sc, y)));
}

static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
{
  #define H_modulo "(modulo x y) returns x mod y; (modulo 4 3) = 1.  The arguments can be real numbers."
  #define Q_modulo sc->pcl_r
  /* (define (mod x y) (- x (* y (floor (/ x y))))) from slib
   * (mod x 0) = x according to "Concrete Mathematics"
   */
  return(modulo_p_pp(sc, car(args), cadr(args)));
}


/* ---------------------------------------- max ---------------------------------------- */
static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p)
{
  const s7_pointer func = find_method_with_let(sc, p, sc->is_real_symbol);
  if (func != sc->undefined)
    return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p))));
  return(false);
}

#define is_real_via_method(Sc, P) ((is_real(P)) || ((has_active_methods(Sc, P)) && (is_real_via_method_1(Sc, P))))

#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, Sc->type_names[T_REAL], 1)
#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, Sc->type_names[T_REAL], 2)

static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  /* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return
   *    different results, so it seems simpler to repeat the other code.
   */
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return((integer(x) < integer(y)) ? y : x);
      if (is_t_real(x))
	/* return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); */
	return(((real(x) >= real(y)) || (is_NaN(real(x)))) ? x : y);
      if (is_t_ratio(x))
	return((fraction(x) < fraction(y)) ? y : x);
#if With_Gmp
      if (is_t_big_integer(x))
	return((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x);
      if (is_t_big_ratio(x))
	return((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x);
      if (is_t_big_real(x))
	return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:
	  return((integer(x) < fraction(y)) ? y : x);
	case T_REAL:
	  return(((integer(x) < real(y)) || (is_NaN(real(y)))) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER:
	  return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y);
	case T_BIG_RATIO:
	  return((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y);
#endif
	default:
	  return(max_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return((fraction(x) < integer(y)) ? y : x);
	case T_REAL:
	  return(((fraction(x) < real(y)) || (is_NaN(real(y)))) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x);
	case T_BIG_RATIO:
	  return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y);
#endif
	default:
	  return(max_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(((real(x) >= integer(y)) || (is_NaN(real(x)))) ? x : y);
	case T_RATIO:
	  return((real(x) < fraction(y)) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(x);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x);
	case T_BIG_RATIO:
	  if (is_NaN(real(x))) return(x);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x);
	case T_BIG_REAL:
	  if (is_NaN(real(x))) return(x);
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y);
#endif
	default:
	  return(max_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y);
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x);
	case T_BIG_RATIO:
	  return((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y);
	default:
	  return(max_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x);
	case T_RATIO:
	  return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0) ? y : x);
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x);
	case T_BIG_INTEGER:
	  return((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y);
	default:
	  return(max_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x);
	case T_RATIO:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x);
	case T_REAL:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  if (is_NaN(real(y))) return(y);
	  return((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x);
	case T_BIG_INTEGER:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x);
	case T_BIG_RATIO:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x);
	default:
	  return(max_out_y(sc, x, y));
	}
#endif
    default:
      return(max_out_x(sc, x, y));
    }
  return(x);
}

static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
  #define H_max "(max ...) returns the maximum of its arguments"
  #define Q_max sc->pcl_r

  s7_pointer x = car(args);
  if (is_null(cdr(args)))
    {
      if (is_real(x)) return(x);
      return(method_or_bust_p(sc, x, sc->max_symbol, sc->type_names[T_REAL]));
    }
  for (s7_pointer nums = cdr(args); is_pair(nums); nums = cdr(nums))
    x = max_p_pp(sc, x, car(nums));
  return(x);
}

static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));}
static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));}

static s7_pointer max_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : func));
}

static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);}
static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));}
static s7_double max_d_dd(s7_double x1, s7_double x2) {return(((x1 > x2) || (is_NaN(x1))) ? x1 : x2);}
static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(max_d_dd(x1, max_d_dd(x2, x3)));}
static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(max_d_dd(x1, max_d_ddd(x2, x3, x4)));}


/* ---------------------------------------- min ---------------------------------------- */
#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, Sc->type_names[T_REAL], 1)
#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, Sc->type_names[T_REAL], 2)

static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return((integer(x) > integer(y)) ? y : x);
      if (is_t_real(x))
	return(((real(x) <= real(y)) || (is_NaN(real(x)))) ? x : y);
      if (is_t_ratio(x))
	return((fraction(x) > fraction(y)) ? y : x);
#if With_Gmp
      if (is_t_big_integer(x))
	return((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x);
      if (is_t_big_ratio(x))
	return((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x);
      if (is_t_big_real(x))
	return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:       return((integer(x) > fraction(y)) ? y : x);
	case T_REAL:
	  return(((integer(x) > real(y)) || (is_NaN(real(y)))) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y);
	case T_BIG_RATIO:   return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y);
#endif
	default:
	  return(min_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return((fraction(x) > integer(y)) ? y : x);
	case T_REAL:
	  return(((fraction(x) > real(y)) || (is_NaN(real(y)))) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x);
	case T_BIG_RATIO:
	  return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y);
#endif
	default:
	  return(min_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(((real(x) <= integer(y)) || (is_NaN(real(x)))) ? x : y);
	case T_RATIO:
	  return((real(x) > fraction(y)) ? y : x);
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(x);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x);
	case T_BIG_RATIO:
	  if (is_NaN(real(x))) return(x);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x);
	case T_BIG_REAL:
	  if (is_NaN(real(x))) return(x);
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y);
#endif
	default:
	  return(min_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x);
	case T_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  return((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0) ? y : x);
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x);
	case T_BIG_RATIO:
	  return((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y);
	default:
	  return(min_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x);
	case T_RATIO:
	  return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0) ? y : x);
	case T_REAL:
	  if (is_NaN(real(y))) return(y);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x);
	case T_BIG_INTEGER:
	  return((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(y);
	  return((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y);
	default:
	  return(min_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x);
	case T_RATIO:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x);
	case T_REAL:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  if (is_NaN(real(y))) return(y);
	  return((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x);
	case T_BIG_INTEGER:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x);
	case T_BIG_RATIO:
	  if (mpfr_nan_p(big_real(x))) return(x);
	  return((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x);
	default:
	  return(min_out_y(sc, x, y));
	}
#endif
    default:
      return(min_out_x(sc, x, y));
    }
  return(x);
}

static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
  #define H_min "(min ...) returns the minimum of its arguments"
  #define Q_min sc->pcl_r

  s7_pointer x = car(args);
  if (is_null(cdr(args)))
    {
      if (is_real(x)) return(x);
      return(method_or_bust_p(sc, x, sc->min_symbol, sc->type_names[T_REAL]));
    }
  for (s7_pointer nums = cdr(args); is_pair(nums); nums = cdr(nums))
    x = min_p_pp(sc, x, car(nums));
  return(x);
}

static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));}
static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));}

static s7_pointer min_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : func));
}

static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);}
static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));}
static s7_double min_d_dd(s7_double x1, s7_double x2) {return(((x1 < x2) || (is_NaN(x1))) ? x1 : x2);}
static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(min_d_dd(x1, min_d_dd(x2, x3)));}
static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(min_d_dd(x1, min_d_ddd(x2, x3, x4)));}


/* ---------------------------------------- = ---------------------------------------- */
static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (has_active_methods(sc, x))
    return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F);
  wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, A_Number_String);
  return(false);
}

static bool eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (has_active_methods(sc, y))
    return(find_and_apply_method(sc, y, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F);
  wrong_type_error_nr(sc, sc->num_eq_symbol, 2, y, A_Number_String);
  return(false);
}

static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  /* (= float int) here can be confusing if the float is the result of (say) (* 4478554083/3166815962 4478554083/3166815962) -- sometimes
   *   the extra low order bits are lost somewhere, so it looks like (= 2.0 2) returning #t.  Maybe the caller should have used eqv?
   */
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return(integer(x) == integer(y));
      if (is_t_real(x))
	return(real(x) == real(y));
      if (is_t_complex(x))
	return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y)));
      if (is_t_ratio(x))
	return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y)));
#if With_Gmp
      if (is_t_big_integer(x))
	return(mpz_cmp(big_integer(x), big_integer(y)) == 0);
      if (is_t_big_ratio(x))
	return(mpq_equal(big_ratio(x), big_ratio(y)));
      if (is_t_big_real(x))
	return(mpfr_equal_p(big_real(x), big_real(y)));
      if (is_t_big_complex(x)) /* mpc_cmp can't handle NaN */
	{
	  if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))) ||
	      (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y)))))
	    return(false);
	  return(mpc_cmp(big_complex(x), big_complex(y)) == 0);
	}
#endif
    }

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:
	  return(false);
	case T_REAL:
#if With_Gmp
	  if (s7_int_abs(integer(x)) >= Int64_To_Double_Limit)
	    {
	      if (is_NaN(real(y))) return(false);
	      mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	      return(mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0);
	    }
#endif
	  return(integer(x) == real(y));
	case T_COMPLEX:
	  return(false);
#if With_Gmp
	case T_BIG_INTEGER:
	  return((mpz_fits_slong_p(big_integer(y))) && (integer(x) == mpz_get_si(big_integer(y))));
	case T_BIG_RATIO:
	  return(false);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) == 0));
	case T_BIG_COMPLEX:
	  return(false);
#endif
	default: return(eq_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER: return(false);
	case T_REAL:    return(fraction(x) == real(y));
	case T_COMPLEX: return(false);
#if With_Gmp
	case T_BIG_INTEGER:
	  return(false);
	case T_BIG_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpq_equal(sc->mpq_1, big_ratio(y)));
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(false);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpfr_cmp_q(big_real(y), sc->mpq_1) == 0);
	case T_BIG_COMPLEX:
	  return(false);
#endif
	default: return(eq_out_y(sc, x, y));
	}
      break;
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(real(x) == integer(y));
	case T_RATIO:
	  return(real(x) == fraction(y));
	case T_COMPLEX:
	  return(false);
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0);
	case T_BIG_RATIO:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0);
	case T_BIG_REAL:
	  if (is_NaN(real(x))) return(false);
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0));
	case T_BIG_COMPLEX:
	  return(false);
#endif
	default: return(eq_out_y(sc, x, y));
	}
      break;
    case T_COMPLEX:
      if (is_real(y)) return(false);
#if With_Gmp
      if (is_t_big_complex(y))
	{
	  if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) ||
	      (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y)))))
	    return(false);
	  mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
	  return(mpc_cmp(big_complex(y), sc->mpc_1) == 0);
	}
#endif
      return(eq_out_y(sc, x, y));

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return((mpz_fits_slong_p(big_integer(x))) && (integer(y) == mpz_get_si(big_integer(x))));
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0);
	case T_RATIO: case T_COMPLEX: case T_BIG_RATIO: case T_BIG_COMPLEX:
	  return(false);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0));
	default: return(eq_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpq_equal(sc->mpq_1, big_ratio(x)));
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(y), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0);
	case T_INTEGER: case T_BIG_INTEGER: case T_COMPLEX: case T_BIG_COMPLEX:
	  return(false);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0));
	default: return(eq_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      if ((is_number(y)) && (mpfr_nan_p(big_real(x)))) return(false);
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpfr_cmp_si(big_real(x), integer(y)) == 0);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpfr_cmp_q(big_real(x), sc->mpq_1) == 0);
	case T_REAL:
	  return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0));
	case T_BIG_INTEGER:
	  return(mpfr_cmp_z(big_real(x), big_integer(y)) == 0);
	case T_BIG_RATIO:
	  return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0);
	case T_COMPLEX: case T_BIG_COMPLEX:
	  return(false);
	default: return(eq_out_y(sc, x, y));
	}
    case T_BIG_COMPLEX:
      switch (type(y))
	{
	case T_RATIO: case T_REAL: case T_INTEGER: case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
	  return(false);
	case T_COMPLEX:
	  if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
	      (mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))))
	    return(false);
	  mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
	  return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */
	default: return(eq_out_y(sc, x, y));
	}
#endif
    default: return(eq_out_x(sc, x, y));
    }
  return(false);
}

static bool is_number_via_method(s7_scheme *sc, s7_pointer p)
{
  if (is_number(p))
    return(true);
  if (has_active_methods(sc, p))
    {
      s7_pointer func = find_method_with_let(sc, p, sc->is_number_symbol);
      if (func != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p))));
    }
  return(false);
}

static s7_pointer g_num_eq(s7_scheme *sc, s7_pointer args)
{
  #define H_num_eq "(= z1 ...) returns #t if all its arguments are equal"
  #define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)

  const s7_pointer x = car(args);
  s7_pointer nums = cdr(args);
  if (is_null(cdr(nums)))
    return(make_boolean(sc, num_eq_b_7pp(sc, x, car(nums))));

  for (; is_pair(nums); nums = cdr(nums))
    if (!num_eq_b_7pp(sc, x, car(nums)))
      {
	for (nums = cdr(nums); is_pair(nums); nums = cdr(nums))
	  if (!is_number_via_method(sc, car(nums)))
	    wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(nums, args), car(nums), A_Number_String);
	return(sc->F);
      }
  return(sc->T);
}

static bool num_eq_b_ii(s7_int i1, s7_int i2) {return(i1 == i2);}
static bool num_eq_b_dd(s7_double i1, s7_double i2) {return(i1 == i2);}
static s7_pointer num_eq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 == x2));}
static s7_pointer num_eq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2)       {return(make_boolean(sc, x1 == x2));}
static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));}

static s7_pointer num_eq_p_pi(s7_scheme *sc, s7_pointer 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 With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, (mpz_fits_slong_p(big_integer(x))) && (y == mpz_get_si(big_integer(x)))));
  if (is_t_big_real(x))
    return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) == 0));
#endif
  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 bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y)
{
  if (is_t_integer(x))
    return(integer(x) == y);
  if (is_t_real(x))
    return(real(x) == y);
#if With_Gmp
  if (is_t_big_integer(x))
    return((mpz_fits_slong_p(big_integer(x))) && (y == mpz_get_si(big_integer(x))));
  if (is_t_big_real(x))
    return(mpfr_cmp_si(big_real(x), y) == 0);
#endif
  if (!is_number(x)) /* complex/ratio can't == int */
    wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, A_Number_String);
  return(false);
}

static s7_pointer g_num_eq_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x = car(args), y = cadr(args);
  if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */
    return(make_boolean(sc, integer(x) == integer(y)));
  return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));
}

static inline s7_pointer num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) == integer(y)));
  if (is_t_real(x))
    return(make_boolean(sc, real(x) == integer(y)));
  if (!is_number(x))
    return(make_boolean(sc, eq_out_x(sc, x, y)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), integer(y)) == 0));
  if (is_t_big_real(x))
    {
      if (mpfr_nan_p(big_real(x))) return(sc->F);
      return(make_boolean(sc, mpfr_cmp_si(big_real(x), integer(y)) == 0));
    }
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0));
#endif
  return(sc->F);
}

static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, car(args), cadr(args)));}
static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, cadr(args), car(args)));}

static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  s7_pointer arg1, arg2;
  if (args != 2) return(func);
  arg1 = cadr(expr);
  arg2 = caddr(expr);
  /* if ((is_pair(arg1)) && (has_fn(arg1)) && (fn_proc(arg1) == g_add_3)) set_fn_direct(arg1, g_add_3_wrapped); */
  if (is_t_integer(arg2)) return(sc->num_eq_xi);
  return((is_t_integer(arg1)) ? sc->num_eq_ix : sc->num_eq_2);
}


/* ---------------------------------------- < ---------------------------------------- */
static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (has_active_methods(sc, x))
    return(find_and_apply_method(sc, x, sc->lt_symbol, set_mlist_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, set_mlist_2(sc, x, y)) != sc->F);
  wrong_type_error_nr(sc, sc->lt_symbol, 2, y, sc->type_names[T_REAL]);
  return(false);
}

static bool lt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return(integer(x) < integer(y));
      if (is_t_real(x))
	return(real(x) < real(y));
      if (is_t_ratio(x))
	return(fraction(x) < fraction(y));
#if With_Gmp
      if (is_t_big_integer(x))
	return(mpz_cmp(big_integer(x), big_integer(y)) < 0);
      if (is_t_big_ratio(x))
	return(mpq_cmp(big_ratio(x), big_ratio(y)) < 0);
      if (is_t_big_real(x))
	return(mpfr_less_p(big_real(x), big_real(y)));
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:	return(integer(x) < fraction(y)); /* ?? */
	case T_REAL:    return(integer(x) < real(y));
#if With_Gmp
	case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) > 0);
	case T_BIG_RATIO:   return(mpq_cmp_si(big_ratio(y), integer(x), 1) > 0);
	case T_BIG_REAL:    return(mpfr_cmp_si(big_real(y), integer(x)) > 0);
#endif
	default: return(lt_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER: return(fraction(x) < integer(y));
	case T_REAL:    return(fraction(x) < real(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0);
	case T_BIG_REAL:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpfr_cmp_q(big_real(y), sc->mpq_1) > 0);
#endif
	default: return(lt_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(real(x) < integer(y));
	case T_RATIO:	return(real(x) < fraction(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0);
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_d(big_real(y), real(x)) > 0);
#endif
	default: return(lt_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpz_cmp_si(big_integer(x), integer(y)) < 0);
	case T_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_z(big_ratio(y), big_integer(x)) > 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_z(big_real(y), big_integer(x)) > 0);
	default: return(lt_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpq_cmp_si(big_ratio(x), integer(y), 1) < 0);
	case T_RATIO:
	  return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0);
	case T_BIG_INTEGER:
	  return(mpq_cmp_z(big_ratio(x), big_integer(y)) < 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_q(big_real(y), big_ratio(x)) > 0);
	default: return(lt_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpfr_cmp_si(big_real(x), integer(y)) < 0);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpfr_cmp_q(big_real(x), sc->mpq_1) < 0);
	case T_REAL:
	  return(mpfr_cmp_d(big_real(x), real(y)) < 0);
	case T_BIG_INTEGER:
	  return(mpfr_cmp_z(big_real(x), big_integer(y)) < 0);
	case T_BIG_RATIO:
	  return(mpfr_cmp_q(big_real(x), big_ratio(y)) < 0);
	default: return(lt_out_y(sc, x, y));
	}
#endif
    default: return(lt_out_x(sc, x, y));
    }
  return(true);
}

static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
{
  #define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
  #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  s7_pointer x = car(args), p = cdr(args);
  if (is_null(cdr(p)))
    return(make_boolean(sc, lt_b_7pp(sc, x, car(p))));

  for (; is_pair(p); p = cdr(p))
    {
      if (!lt_b_7pp(sc, x, car(p)))
	{
	  for (p = cdr(p); is_pair(p); p = cdr(p))
	    if (!is_real_via_method(sc, car(p)))
	      wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]);
	  return(sc->F);
	}
      x = car(p);
    }
  return(sc->T);
}

static bool ratio_lt_pi(s7_pointer x, s7_int y)
{
  if ((y >= 0) && (numerator(x) < 0))
    return(true);
  if ((y <= 0) && (numerator(x) > 0))
    return(false);
  if (denominator(x) < s7_Int32_Max)
    return(numerator(x) < (y * denominator(x)));
  return(fraction(x) < y);
}

static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args);
  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) < 0));
  if (is_small_real(x))
    return(make_boolean(sc, is_negative(sc, x)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0));
  if (is_t_big_real(x))
    return(make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0));
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0));
#endif
  return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
}

static s7_pointer g_less_xi(s7_scheme *sc, s7_pointer args)
{
  const s7_int y = integer(cadr(args));
  const s7_pointer x = car(args);

  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) < y));
  if (is_t_real(x))
    return(make_boolean(sc, real(x) < y));
  if (is_t_ratio(x))
    return(make_boolean(sc, ratio_lt_pi(x, y)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0));
  if (is_t_big_real(x))
    return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0));
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0));
#endif
  return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
}

static s7_pointer g_less_xf(s7_scheme *sc, s7_pointer args)
{
  const s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */
  const s7_pointer x = car(args);

  if (is_t_real(x))
    return(make_boolean(sc, real(x) < y));
  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) < y));
  if (is_t_ratio(x))
    return(make_boolean(sc, fraction(x) < y));
#if With_Gmp
  if (is_t_big_real(x))
    return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0));
  if (is_t_big_integer(x))
    {
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0));
    }
  if (is_t_big_ratio(x))
    {
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0));
    }
#endif
  return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
}

static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, lt_b_7pp(sc, x, y)));}
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));
#if With_Gmp
  if (is_t_big_integer(x))
    return(mpz_cmp_si(big_integer(x), y) < 0);
  if (is_t_big_real(x))
    return(mpfr_cmp_si(big_real(x), y) < 0);
  if (is_t_big_ratio(x))
    return(mpq_cmp_si(big_ratio(x), y, 1) < 0);
#endif
  return(lt_out_x(sc, x, make_integer(sc, y)));
}

static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));}
static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer 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 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, set_mlist_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, set_mlist_2(sc, x, y)) != sc->F);
  wrong_type_error_nr(sc, sc->leq_symbol, 2, y, sc->type_names[T_REAL]);
  return(false);
}

static bool leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return(integer(x) <= integer(y));
      if (is_t_real(x))
	return(real(x) <= real(y));
      if (is_t_ratio(x))
	return(fraction(x) <= fraction(y));
#if With_Gmp
      if (is_t_big_integer(x))
	return(mpz_cmp(big_integer(x), big_integer(y)) <= 0);
      if (is_t_big_ratio(x))
	return(mpq_cmp(big_ratio(x), big_ratio(y)) <= 0);
      if (is_t_big_real(x))
	return(mpfr_lessequal_p(big_real(x), big_real(y)));
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:	return(integer(x) <= fraction(y)); /* ?? */
	case T_REAL:	return(integer(x) <= real(y));
#if With_Gmp
	case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) >= 0);
	case T_BIG_RATIO:   return(mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) >= 0));
#endif
	default: return(leq_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER: return(fraction(x) <= integer(y));
	case T_REAL:    return(fraction(x) <= real(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) >= 0);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(false);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0);
#endif
	default: return(leq_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(real(x) <= integer(y));
	case T_RATIO:	return(real(x) <= fraction(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0);
	case T_BIG_RATIO:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0);
	case T_BIG_REAL:
	  if (is_NaN(real(x))) return(false);
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) >= 0));
#endif
	default: return(leq_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpz_cmp_si(big_integer(x), integer(y)) <= 0);
	case T_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0));
	default: return(leq_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0);
	case T_RATIO:
	  return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) <= 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0);
	case T_BIG_INTEGER:
	  return(mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0));
	default: return(leq_out_y(sc, x, y));
	}

    case T_BIG_REAL:
      if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false);
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpfr_cmp_si(big_real(x), integer(y)) <= 0);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0);
	case T_REAL:
	  return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) <= 0));
	case T_BIG_INTEGER:
	  return(mpfr_cmp_z(big_real(x), big_integer(y)) <= 0);
	case T_BIG_RATIO:
	  return(mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0);
	default: return(leq_out_y(sc, x, y));
	}
#endif
    default: return(leq_out_x(sc, x, y));
    }
  return(true);
}

static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order"
  #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  s7_pointer x = car(args), p = cdr(args);

  if (is_null(cdr(p)))
    return(make_boolean(sc, leq_b_7pp(sc, x, car(p))));
  for (; is_pair(p); x = car(p), p = cdr(p))
    if (!leq_b_7pp(sc, x, car(p)))
      {
	for (p = cdr(p); is_pair(p); p = cdr(p))
	  if (!is_real_via_method(sc, car(p)))
	    wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]);
	return(sc->F);
      }
  return(sc->T);
}

static inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer 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)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0));
  if (is_t_big_real(x))
    {
      if (mpfr_nan_p(big_real(x))) return(sc->F);
      return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0));
    }
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0));
#endif
  return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1));
}

static bool leq_b_pi(s7_scheme *sc, s7_pointer 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 With_Gmp
  if (is_t_big_integer(x))
    return(mpz_cmp_si(big_integer(x), y) <= 0);
  if (is_t_big_real(x))
    return(mpfr_cmp_si(big_real(x), y) <= 0);
  if (is_t_big_ratio(x))
    return(mpq_cmp_si(big_ratio(x), y, 1) <= 0);
#endif
  if (has_active_methods(sc, x))
    return(find_and_apply_method(sc, x, sc->leq_symbol, set_mlist_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 s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, leq_b_pi(sc, x, y)));}
static s7_pointer g_leq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args))));}
static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer nums = cdr(args);
  if (is_t_integer(car(nums)))
    {
      if (integer(car(args)) > integer(car(nums)))
	{
	  if (!is_real_via_method(sc, cadr(nums)))
	    wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(nums), sc->type_names[T_REAL]);
	  return(sc->F);
	}
      if (is_t_integer(cadr(nums)))
	return((integer(car(nums)) > integer(cadr(nums))) ? sc->F : sc->T);
    }
  return(g_less_or_equal(sc, args));
}

static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2)
    {
      const s7_pointer arg2 = caddr(expr);
      if ((is_t_integer(arg2)) && (integer(arg2) < s7_Int32_Max) && (integer(arg2) > s7_Int32_Min))
	return(sc->leq_xi);
      return(sc->leq_2);
    }
  if ((args == 3) && (is_t_integer(cadr(expr))))
    return(sc->leq_ixx);
  return(func);
}


/* ---------------------------------------- > ---------------------------------------- */
static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (has_active_methods(sc, x))
    return(find_and_apply_method(sc, x, sc->gt_symbol, set_mlist_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, set_mlist_2(sc, x, y)) != sc->F);
  wrong_type_error_nr(sc, sc->gt_symbol, 2, y, sc->type_names[T_REAL]);
  return(false);
}

static bool gt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return(integer(x) > integer(y));
      if (is_t_real(x))
	return(real(x) > real(y));
      if (is_t_ratio(x))
	return(fraction(x) > fraction(y));
#if With_Gmp
      if (is_t_big_integer(x))
	return(mpz_cmp(big_integer(x), big_integer(y)) > 0);
      if (is_t_big_ratio(x))
	return(mpq_cmp(big_ratio(x), big_ratio(y)) > 0);
      if (is_t_big_real(x))
	return(mpfr_greater_p(big_real(x), big_real(y)));
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:	return(integer(x) > fraction(y)); /* ?? */
	case T_REAL:	return(integer(x) > real(y));
#if With_Gmp
	case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) < 0);
	case T_BIG_RATIO:   return(mpq_cmp_si(big_ratio(y), integer(x), 1) < 0);
	case T_BIG_REAL:    return(mpfr_cmp_si(big_real(y), integer(x)) < 0);
#endif
	default: return(gt_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER: return(fraction(x) > integer(y));
	case T_REAL:    return(fraction(x) > real(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0);
	case T_BIG_REAL:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpfr_cmp_q(big_real(y), sc->mpq_1) < 0);
#endif
	default: return(gt_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(real(x) > integer(y));
	case T_RATIO:	return(real(x) > fraction(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0);
	case T_BIG_RATIO:
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_d(big_real(y), real(x)) < 0);
#endif
	default: return(gt_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpz_cmp_si(big_integer(x), integer(y)) > 0);
	case T_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_z(big_ratio(y), big_integer(x)) < 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_z(big_real(y), big_integer(x)) < 0);
	default: return(gt_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpq_cmp_si(big_ratio(x), integer(y), 1) > 0);
	case T_RATIO:
	  return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0);
	case T_BIG_INTEGER:
	  return(mpq_cmp_z(big_ratio(x), big_integer(y)) > 0);
	case T_BIG_REAL:
	  return(mpfr_cmp_q(big_real(y), big_ratio(x)) < 0);
	default: return(gt_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpfr_cmp_si(big_real(x), integer(y)) > 0);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpfr_cmp_q(big_real(x), sc->mpq_1) > 0);
	case T_REAL:
	  return(mpfr_cmp_d(big_real(x), real(y)) > 0);
	case T_BIG_INTEGER:
	  return(mpfr_cmp_z(big_real(x), big_integer(y)) > 0);
	case T_BIG_RATIO:
	  return(mpfr_cmp_q(big_real(x), big_ratio(y)) > 0);
	default: return(gt_out_y(sc, x, y));
	}
#endif
    default: return(gt_out_x(sc, x, y));
    }
  return(true);
}

static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
  #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  s7_pointer x = car(args), p = cdr(args);

  if (is_null(cdr(p)))
    return(make_boolean(sc, gt_b_7pp(sc, x, car(p))));

  for (; is_pair(p); x = car(p), p = cdr(p))
    if (!gt_b_7pp(sc, x, car(p)))
      {
	for (p = cdr(p); is_pair(p); p = cdr(p))
	  if (!is_real_via_method(sc, car(p)))
	    wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]);
	return(sc->F);
      }
  return(sc->T);
}

static s7_pointer g_greater_xi(s7_scheme *sc, s7_pointer args)
{
  const s7_int y = integer(cadr(args));
  const s7_pointer x = car(args);

  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) > y));
  if (is_t_real(x))
    return(make_boolean(sc, real(x) > y));
  if (is_t_ratio(x))
    return(make_boolean(sc, !ratio_leq_pi(x, y)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0));
  if (is_t_big_real(x))
    return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0));
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0));
#endif
  return(method_or_bust(sc, x, sc->gt_symbol, args, A_Number_String, 1));
}

static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args)
{
  const s7_double y = real(cadr(args));
  const s7_pointer x = car(args);

  if (is_t_real(x))
    return(make_boolean(sc, real(x) > y));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) > y));
    case T_RATIO:
      /* (> 9223372036854775807/9223372036854775806 1.0) */
      if (denominator(x) < s7_Int32_Max) /* y range check was handled in greater_chooser */
	return(make_boolean(sc, (numerator(x) > (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) > y));

#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0));
    case T_BIG_RATIO:
      mpfr_set_d(sc->mpfr_1, y, Mpfr_Rndn);
      return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0));
    case T_BIG_REAL:
      return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0));
#endif
    default:
      return(method_or_bust(sc, x, sc->gt_symbol, args, A_Number_String, 1));
    }
  return(sc->T);
}

static inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer 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 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));
#if With_Gmp
  if (is_t_big_integer(x))
    return(mpz_cmp_si(big_integer(x), y) > 0);
  if (is_t_big_real(x))
    return(mpfr_cmp_si(big_real(x), y) > 0);
  if (is_t_big_ratio(x))
    return(mpq_cmp_si(big_ratio(x), y, 1) > 0);
#endif
  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)));}

static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args)
{
  /* ridiculous repetition, but overheads are killing this poor thing */
  const s7_pointer x = car(args), y = cadr(args);
  if (type(x) == type(y))
    {
      if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(y)));
      if (is_t_real(x))    return(make_boolean(sc, real(x) > real(y)));
      if (is_t_ratio(x))   return(make_boolean(sc, fraction(x) > fraction(y)));
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:
	  return(gt_p_pp(sc, x, y));
	case T_REAL:
	  return(make_boolean(sc, integer(x) > real(y)));
#if With_Gmp
	case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
	  return(gt_p_pp(sc, x, y));
#endif
	default:        return(make_boolean(sc, gt_out_y(sc, x, y)));
	}
      break;
    case T_RATIO:
      return(gt_p_pp(sc, x, y));
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(make_boolean(sc, real(x) > integer(y)));
	case T_RATIO:   return(make_boolean(sc, real(x) > fraction(y)));
#if With_Gmp
	case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
	  return(gt_p_pp(sc, x, y));
#endif
	default:        return(make_boolean(sc, gt_out_y(sc, x, y)));
	}
      break;
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
      return(gt_p_pp(sc, x, y));
#endif

    default:            return(make_boolean(sc, gt_out_x(sc, x, y)));
    }
  return(sc->T);
}

static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  s7_pointer arg2;
  if (args != 2) return(func);
  arg2 = caddr(expr);
  if ((is_t_integer(arg2)) && (integer(arg2) < s7_Int32_Max) && (integer(arg2) > s7_Int32_Min))
    return(sc->greater_xi);
  if ((is_t_real(arg2)) && (real(arg2) < s7_Int32_Max) && (real(arg2) > s7_Int32_Min))
    return(sc->greater_xf);
  return(sc->greater_2);
}


/* ---------------------------------------- >= ---------------------------------------- */
static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!has_active_methods(sc, x))
    wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]);
  return(find_and_apply_method(sc, x, sc->geq_symbol, set_mlist_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, set_mlist_2(sc, x, y)) != sc->F);   /* not plist */
}

static bool geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (type(x) == type(y))
    {
      if (is_t_integer(x))
	return(integer(x) >= integer(y));
      if (is_t_real(x))
	return(real(x) >= real(y));
      if (is_t_ratio(x))
	return(fraction(x) >= fraction(y));
#if With_Gmp
      if (is_t_big_integer(x))
	return(mpz_cmp(big_integer(x), big_integer(y)) >= 0);
      if (is_t_big_ratio(x))
	return(mpq_cmp(big_ratio(x), big_ratio(y)) >= 0);
      if (is_t_big_real(x))
	return(mpfr_greaterequal_p(big_real(x), big_real(y)));
#endif
    }
  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_RATIO:	return(integer(x) >= fraction(y)); /* ?? */
	case T_REAL:	return(integer(x) >= real(y));
#if With_Gmp
	case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) <= 0);
	case T_BIG_RATIO:   return(mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) <= 0));
#endif
	default: return(geq_out_y(sc, x, y));
	}
      break;
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER: return(fraction(x) >= integer(y));
	case T_REAL:    return(fraction(x) >= real(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) <= 0);
	case T_BIG_REAL:
	  if (mpfr_nan_p(big_real(y))) return(false);
	  mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
	  return(mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0);
#endif
	default: return(geq_out_y(sc, x, y));
	}
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(real(x) >= integer(y));
	case T_RATIO:	return(real(x) >= fraction(y));
#if With_Gmp
	case T_BIG_INTEGER:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0);
	case T_BIG_RATIO:
	  if (is_NaN(real(x))) return(false);
	  mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
	  return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0);
	case T_BIG_REAL:
	  if (is_NaN(real(x))) return(false);
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) <= 0));
#endif
	default: return(geq_out_y(sc, x, y));
	}
      break;

#if With_Gmp
    case T_BIG_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpz_cmp_si(big_integer(x), integer(y)) >= 0);
	case T_RATIO:
	  mpq_set_z(sc->mpq_1, big_integer(x));
	  return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0);
	case T_BIG_RATIO:
	  return(mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0));
	default: return(geq_out_y(sc, x, y));
	}
    case T_BIG_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0);
	case T_RATIO:
	  return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) >= 0);
	case T_REAL:
	  if (is_NaN(real(y))) return(false);
	  mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);
	  return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0);
	case T_BIG_INTEGER:
	  return(mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0);
	case T_BIG_REAL:
	  return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0));
	default: return(geq_out_y(sc, x, y));
	}
    case T_BIG_REAL:
      if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false);
      switch (type(y))
	{
	case T_INTEGER:
	  return(mpfr_cmp_si(big_real(x), integer(y)) >= 0);
	case T_RATIO:
	  mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
	  return(mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0);
	case T_REAL:
	  return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) >= 0));
	case T_BIG_INTEGER:
	  return(mpfr_cmp_z(big_real(x), big_integer(y)) >= 0);
	case T_BIG_RATIO:
	  return(mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0);
	default: return(geq_out_y(sc, x, y));
	}
#endif
    default: return(geq_out_x(sc, x, y));
    }
  return(true);
}

static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order"
  #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  s7_pointer x = car(args), p = cdr(args);
  if (is_null(cdr(p)))
    return(make_boolean(sc, geq_b_7pp(sc, x, car(p))));

  for (; is_pair(p); x = car(p), p = cdr(p))
    if (!geq_b_7pp(sc, x, car(p)))
      {
	for (p = cdr(p); is_pair(p); p = cdr(p))
	  if (!is_real_via_method(sc, car(p)))
	    wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]);
	return(sc->F);
      }
  return(sc->T);
}

static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer 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));}

static s7_pointer g_geq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args))));}

static s7_pointer g_geq_xf(s7_scheme *sc, s7_pointer args)
{
  s7_double y = real(cadr(args));
  s7_pointer x = car(args);
  return(make_boolean(sc, ((is_t_real(x)) ? (real(x) >= y) : geq_b_7pp(sc, car(args), cadr(args)))));
}

static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args)
{
  const s7_int y = integer(cadr(args));
  const s7_pointer x = car(args);

  if (is_t_integer(x))
    return(make_boolean(sc, integer(x) >= y));
  if (is_t_real(x))
    return(make_boolean(sc, real(x) >= y));
  if (is_t_ratio(x))
    return(make_boolean(sc, !ratio_lt_pi(x, y)));
#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0));
  if (is_t_big_real(x))
    {
      if (mpfr_nan_p(big_real(x))) return(sc->F);
      return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0));
    }
  if (is_t_big_ratio(x))
    return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0));
#endif
  return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1));
}

static bool geq_b_pi(s7_scheme *sc, s7_pointer 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 With_Gmp
  if (is_t_big_integer(x))
    return(mpz_cmp_si(big_integer(x), y) >= 0);
  if (is_t_big_real(x))
    return((!mpfr_nan_p(big_real(x))) && (mpfr_cmp_si(big_real(x), y) >= 0));
  if (is_t_big_ratio(x))
    return(mpq_cmp_si(big_ratio(x), y, 1) >= 0);
#endif
  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, set_mlist_2(sc, x, make_integer(sc, y))));   /* not plist */
}

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 s7_pointer geq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  s7_pointer arg2;
  if (args != 2) return(func);
  arg2 = caddr(expr);
  if ((is_t_integer(arg2)) && (integer(arg2) < s7_Int32_Max) && (integer(arg2) > s7_Int32_Min))
    return(sc->geq_xi);
  if ((is_t_real(arg2)) && (real(arg2) < s7_Int32_Max) && (real(arg2) > s7_Int32_Min))
    return(sc->geq_xf);
  return(sc->geq_2);
}


/* ---------------------------------------- real-part ---------------------------------------- */
s7_double s7_real_part(s7_pointer x)
{
  switch(type(x))
    {
    case T_INTEGER:     return((s7_double)integer(x));
    case T_RATIO:       return((s7_double)fraction(x));
    case T_REAL:        return(real(x));
    case T_COMPLEX:     return(real_part(x));
#if With_Gmp
    case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x)));
    case T_BIG_RATIO:   return((s7_double)((long_double)mpz_get_si(mpq_numref(big_ratio(x))) /
					   (long_double)mpz_get_si(mpq_denref(big_ratio(x)))));
    case T_BIG_REAL:    return((s7_double)mpfr_get_d(big_real(x), Mpfr_Rndn));
    case T_BIG_COMPLEX: return((s7_double)mpfr_get_d(mpc_realref(big_complex(x)), Mpfr_Rndn));
#endif
    }
  return(0.0);
}

static s7_double real_part_d_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_number(x)) return(s7_real_part(x));
  sole_arg_wrong_type_error_nr(sc, sc->real_part_symbol, x, A_Number_String);
#ifdef __TINYC__
  return(0.0);
#endif
}

static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_complex(x)) return(make_real(sc, real_part(x)));
  switch (type(x))
    {
    case T_INTEGER: case T_RATIO: case T_REAL:
      return(x);
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
      return(x);
    case T_BIG_COMPLEX:
      {
	s7_pointer y;
	new_cell(sc, y, T_BIG_REAL);
	big_real_bgf(y) = alloc_bigflt(sc);
	add_big_real(sc, y);
	mpc_real(big_real(y), big_complex(x), Mpfr_Rndn);
	return(y);
      }
#endif
    default:
      return(method_or_bust_p(sc, x, sc->real_part_symbol, A_Number_String));
    }
}

static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
{
  #define H_real_part "(real-part num) returns the real part of num"
  #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
  return(real_part_p_p(sc, car(args)));
}


/* ---------------------------------------- imag-part ---------------------------------------- */
s7_double s7_imag_part(s7_pointer x)
{
  if (is_t_complex(x))
    return(imag_part(x));
#if With_Gmp
  if (is_t_big_complex(x))
    return((s7_double)mpfr_get_d(mpc_imagref(big_complex(x)), Mpfr_Rndn));
#endif
  return(0.0);
}

static s7_double imag_part_d_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_number(x)) return(s7_imag_part(x));
  sole_arg_wrong_type_error_nr(sc, sc->imag_part_symbol, x, A_Number_String);
#ifdef __TINYC__
  return(0.0);
#endif
}

static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_complex(x)) return(make_real(sc, imag_part(x)));
  switch (type(x))
    {
    case T_INTEGER: case T_RATIO:
      return(Int_Zero);
    case T_REAL:
      return(Real_Zero);
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO:
      return(Int_Zero);
    case T_BIG_REAL:
      return(Real_Zero);
    case T_BIG_COMPLEX:
      {
	s7_pointer y;
	new_cell(sc, y, T_BIG_REAL);
	big_real_bgf(y) = alloc_bigflt(sc);
	add_big_real(sc, y);
	mpc_imag(big_real(y), big_complex(x), Mpfr_Rndn);
	return(y);
      }
#endif
    default:
      return(method_or_bust_p(sc, x, sc->imag_part_symbol, A_Number_String));
    }
}

static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
{
  #define H_imag_part "(imag-part num) returns the imaginary part of num"
  #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
  /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */
  return(imag_part_p_p(sc, car(args)));
}


/* ---------------------------------------- numerator denominator ---------------------------------------- */
static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_ratio(x)) return(numerator(x));
  if (is_t_integer(x)) return(integer(x));
#if With_Gmp
  if (is_t_big_ratio(x)) return(mpz_get_si(mpq_numref(big_ratio(x))));
  if (is_t_big_integer(x)) return(mpz_get_si(big_integer(x)));
#endif
  return(integer(method_or_bust_p(sc, x, sc->numerator_symbol, A_Rational_String)));
}

static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args)
{
  #define H_numerator "(numerator rat) returns the numerator of the rational number rat"
  #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)

  const s7_pointer x = car(args);
  switch (type(x))
    {
    case T_RATIO:       return(make_integer(sc, numerator(x)));
    case T_INTEGER:     return(x);
#if With_Gmp
    case T_BIG_INTEGER: return(x);
    case T_BIG_RATIO:   return(mpz_to_integer(sc, mpq_numref(big_ratio(x))));
#endif
    default:            return(method_or_bust_p(sc, x, sc->numerator_symbol, A_Rational_String));
    }
}


static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
{
  #define H_denominator "(denominator rat) returns the denominator of the rational number rat"
  #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)

  const s7_pointer x = car(args);
  switch (type(x))
    {
    case T_RATIO:       return(make_integer(sc, denominator(x)));
    case T_INTEGER:     return(Int_One);
#if With_Gmp
    case T_BIG_INTEGER: return(Int_One);
    case T_BIG_RATIO:   return(mpz_to_integer(sc, mpq_denref(big_ratio(x))));
#endif
    default:            return(method_or_bust_p(sc, x, sc->denominator_symbol, A_Rational_String));
    }
}

static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_ratio(x)) return(denominator(x));
  if (is_t_integer(x)) return(1);
#if With_Gmp
  if (is_t_big_ratio(x)) return(mpz_get_si(mpq_denref(big_ratio(x))));
  if (is_t_big_integer(x)) return(1);
#endif
  return(integer(method_or_bust_p(sc, x, sc->denominator_symbol, A_Rational_String)));
}


/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real?  ---------------------------------------- */
static s7_pointer g_is_number(s7_scheme *sc, s7_pointer args)
{
  #define H_is_number "(number? obj) returns #t if obj is a number"
  #define Q_is_number sc->pl_bt
  check_boolean_method(sc, is_number, sc->is_number_symbol, args);
}

bool s7_is_bignum(s7_pointer obj) {return(is_big_number(obj));}

static s7_pointer g_is_bignum(s7_scheme *sc, s7_pointer args)
{
  #define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number."
  #define Q_is_bignum sc->pl_bt
  return(make_boolean(sc, is_big_number(car(args))));
}

static s7_pointer g_is_integer(s7_scheme *sc, s7_pointer args)
{
  #define H_is_integer "(integer? obj) returns #t if obj is an integer"
  #define Q_is_integer sc->pl_bt
  check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args);
}

static bool is_byte(s7_pointer x) {return((s7_is_integer(x)) && (s7_integer(x) >= 0) && (s7_integer(x) < 256));}
static s7_pointer g_is_byte(s7_scheme *sc, s7_pointer args)
{
  #define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)"
  #define Q_is_byte sc->pl_bt
  check_boolean_method(sc, is_byte, sc->is_byte_symbol, args);
}

static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args)
{
  #define H_is_real "(real? obj) returns #t if obj is a real number"
  #define Q_is_real sc->pl_bt
  check_boolean_method(sc, is_real, sc->is_real_symbol, args);
}

static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args)
{
  #define H_is_complex "(complex? obj) returns #t if obj is a number"
  #define Q_is_complex sc->pl_bt
  check_boolean_method(sc, is_number, sc->is_complex_symbol, args);
}

static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args)
{
  #define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)"
  #define Q_is_rational sc->pl_bt
  check_boolean_method(sc, is_rational, sc->is_rational_symbol, args);
  /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc */
}

static s7_pointer g_is_float(s7_scheme *sc, s7_pointer args)
{
  #define H_is_float "(float? x) returns #t is x is real and not rational."
  #define Q_is_float sc->pl_bt
#if With_Gmp
  /* return(make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); *//* (float? pi) */
  #define is_t_float(P) (is_t_real(P) || (is_t_big_real(P)))
  check_boolean_method(sc, is_t_float, sc->is_float_symbol, args);
#else
  /* (float? (openlet (inlet 'x 0.0 'float? (lambda (obj) (and (real? (obj 'x)) (not (exact? (obj 'x)))))))) */
  check_boolean_method(sc, is_t_real, sc->is_float_symbol, args);
  /* return(make_boolean(sc, is_t_real(p))); */
#endif
}

#if With_Gmp
static bool is_float_b(s7_pointer x) {return((is_t_real(x)) || (is_t_big_real(x)));}
#else
static bool is_float_b(s7_pointer x) {return(is_t_real(x));}
#endif


/* ---------------------------------------- nan? ---------------------------------------- */
static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(is_NaN(real(x)));
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:   return(false);
    case T_COMPLEX: return((is_NaN(real_part(x))) || (is_NaN(imag_part(x))));
#if With_Gmp
    case T_BIG_INTEGER:
    case T_BIG_RATIO:   return(false);
    case T_BIG_REAL:    return(mpfr_nan_p(big_real(x)) != 0);
    case T_BIG_COMPLEX: return((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0));
#endif
    default:
      if (!has_active_methods(sc, x)) return(false);
      return(apply_boolean_method(sc, x, sc->is_nan_symbol) != sc->F);
    }
  return(false);
}

static s7_pointer g_is_nan(s7_scheme *sc, s7_pointer args)
{
  #define H_is_nan "(nan? obj) returns #t if obj is a NaN"
  #define Q_is_nan sc->pl_bt
  return(make_boolean(sc, is_nan_b_7p(sc, car(args))));
}


/* ---------------------------------------- infinite? ---------------------------------------- */
static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:    return(false);
    case T_REAL:     return(is_inf(real(x)));
    case T_COMPLEX:  return((is_inf(real_part(x))) || (is_inf(imag_part(x))));
#if With_Gmp
    case T_BIG_INTEGER:
    case T_BIG_RATIO: return(false);
    case T_BIG_REAL:  return(mpfr_inf_p(big_real(x)) != 0);
    case T_BIG_COMPLEX:
      return((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) ||
	     (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0));
#endif
    default:
      if (!has_active_methods(sc, x)) return(false);
      return(apply_boolean_method(sc, x, sc->is_infinite_symbol) != sc->F);
    }
  return(false);
}

static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args)
{
  #define H_is_infinite "(infinite? obj) returns #t if obj has an infinite real or imaginary part"
  #define Q_is_infinite sc->pl_bt
  return(make_boolean(sc, is_infinite_b_7p(sc, car(args))));
}


/* ---------------------------------------- even? odd?---------------------------------------- */
static bool is_even_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x))
    return((integer(x) & 1) == 0);
#if With_Gmp
  if (is_t_big_integer(x))
    return(mpz_even_p(big_integer(x)));
#endif
  return(method_or_bust_p(sc, x, sc->is_even_symbol, sc->type_names[T_INTEGER]) != sc->F);
}

static s7_pointer is_even_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x))
    return(make_boolean(sc, (integer(x) & 1) == 0));
  return(make_boolean(sc, is_even_b_7p(sc, x)));
}

static bool is_even_i(s7_int i1) {return((i1 & 1) == 0);}

static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args)
{
  #define H_is_even "(even? int) returns #t if the integer int32_t is even"
  #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
  return(make_boolean(sc, is_even_b_7p(sc, car(args))));
}


static bool is_odd_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x))
    return((integer(x) & 1) == 1);
#if With_Gmp
  if (is_t_big_integer(x))
    return(mpz_odd_p(big_integer(x)));
#endif
  return(method_or_bust_p(sc, x, sc->is_odd_symbol, sc->type_names[T_INTEGER]) != sc->F);
}

static s7_pointer is_odd_p_p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x))
    return(make_boolean(sc, (integer(x) & 1) == 1));
  return(make_boolean(sc, is_odd_b_7p(sc, x)));
}

static bool is_odd_i(s7_int i1) {return((i1 & 1) == 1);}

static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args)
{
  #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd"
  #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
  return(make_boolean(sc, is_odd_b_7p(sc, car(args))));
}


/* ---------------------------------------- zero? ---------------------------------------- */
static bool is_zero(s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:     return(integer(x) == 0);
    case T_REAL:        return(real(x) == 0.0);
#if With_Gmp
    case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0);
    case T_BIG_REAL:    return(mpfr_zero_p(big_real(x)));
#endif
    default:
      return(false); /* ratios and complex numbers here are already collapsed into integers and reals */
    }
}

static bool is_zero_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x)) return(integer(x) == 0);
  if (is_t_real(x))    return(real(x) == 0.0);
#if With_Gmp
  if (is_number(x))    return(is_zero(x));
#else
  if (is_number(x))    return(false);
#endif
  return(method_or_bust_p(sc, x, sc->is_zero_symbol, A_Number_String) != sc->F);
}

static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args)
{
  #define H_is_zero "(zero? num) returns #t if the number num is zero"
  #define Q_is_zero sc->pl_bn
  return(make_boolean(sc, is_zero_b_7p(sc, car(args))));
}

static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer x) {return(make_boolean(sc, is_zero_b_7p(sc, x)));}
static bool is_zero_i(s7_int i) {return(i == 0);}
static bool is_zero_d(s7_double x) {return(x == 0.0);}


/* -------------------------------- positive? -------------------------------- */
static bool is_positive(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:     return(integer(x) > 0);
    case T_RATIO:       return(numerator(x) > 0);
    case T_REAL:        return(real(x) > 0.0);
#if With_Gmp
    case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0);
    case T_BIG_RATIO:   return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0);
    case T_BIG_REAL:    return(mpfr_cmp_ui(big_real(x), 0) > 0);
#endif
    default:
      sole_arg_wrong_type_error_nr(sc, sc->is_positive_symbol, x, sc->type_names[T_REAL]);
    }
  return(false);
}

static bool is_positive_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x)) return(integer(x) > 0);
  if (is_t_real(x))    return(real(x) > 0.0);
#if With_Gmp
  if (is_number(x))    return(is_positive(sc, x));
#else
  if (is_t_ratio(x))   return(numerator(x) > 0);
#endif
  return(method_or_bust_p(sc, x, sc->is_positive_symbol, sc->type_names[T_REAL]) != sc->F);
}

static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args)
{
  #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)"
  #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
  return(make_boolean(sc, is_positive_b_7p(sc, car(args))));
}

static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer x) {return(make_boolean(sc, is_positive_b_7p(sc, x)));}
static bool is_positive_i(s7_int i) {return(i > 0);}
static bool is_positive_d(s7_double x) {return(x > 0.0);}


/* -------------------------------- negative? -------------------------------- */
static bool is_negative(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:     return(integer(x) < 0);
    case T_RATIO:       return(numerator(x) < 0);
    case T_REAL:        return(real(x) < 0.0);
#if With_Gmp
    case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) < 0);
    case T_BIG_RATIO:   return(mpq_cmp_ui(big_ratio(x), 0, 1) < 0);
    case T_BIG_REAL:    return(mpfr_cmp_ui(big_real(x), 0) < 0);
#endif
    default:
      sole_arg_wrong_type_error_nr(sc, sc->is_negative_symbol, x, sc->type_names[T_REAL]);
    }
  return(false);
}

static bool is_negative_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x)) return(integer(x) < 0);
  if (is_t_real(x))    return(real(x) < 0.0);
#if With_Gmp
  if (is_number(x))    return(is_negative(sc, x));
#else
  if (is_t_ratio(x))   return(numerator(x) < 0);
#endif
  return(method_or_bust_p(sc, x, sc->is_negative_symbol, sc->type_names[T_REAL]) != sc->F);
}

static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args)
{
  #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)"
  #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
  return(make_boolean(sc, is_negative_b_7p(sc, car(args))));
}

static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer x) {return(make_boolean(sc, is_negative_b_7p(sc, x)));}
static bool is_negative_i(s7_int p) {return(p < 0);}
static bool is_negative_d(s7_double p) {return(p < 0.0);}


#if !With_Pure_s7
/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */
static s7_pointer exact_to_inexact_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
#if With_Gmp
      if ((integer(x) > Int64_To_Double_Limit) || (integer(x) < -Int64_To_Double_Limit))
	return(s7_number_to_big_real(sc, x));
#endif
      return(make_real(sc, (s7_double)(integer(x))));

    case T_RATIO:
#if With_Gmp
      if ((numerator(x) > Int64_To_Double_Limit) || (numerator(x) < -Int64_To_Double_Limit) ||
 	  (denominator(x) > Int64_To_Double_Limit))  /* just a guess */
	return(s7_number_to_big_real(sc, x));
#endif
      return(make_real(sc, (s7_double)(fraction(x))));

#if With_Gmp
    case T_BIG_INTEGER:
      return(big_integer_to_big_real(sc, x));
    case T_BIG_RATIO:
      return(big_ratio_to_big_real(sc, x));
#endif
    case T_REAL:    case T_BIG_REAL:
    case T_COMPLEX: case T_BIG_COMPLEX:
      return(x); /* apparently (exact->inexact 1+i) is not an error */
    default:
      return(method_or_bust_p(sc, x, sc->exact_to_inexact_symbol, A_Number_String));
    }
}

static s7_pointer g_exact_to_inexact(s7_scheme *sc, s7_pointer args)
{
  #define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5"
  #define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol)
  /* arg can be complex -> itself! */
  return(exact_to_inexact_p_p(sc, car(args)));
}

static s7_pointer inexact_to_exact_p_p(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER: case T_BIG_INTEGER:
    case T_RATIO:   case T_BIG_RATIO:
      return(x);

#if With_Gmp
    case T_BIG_REAL:
      return(big_rationalize(sc, set_plist_1(sc, x)));
#endif

    case T_REAL:
      {
	s7_int numer = 0, denom = 1;
	const s7_double val = real(x);
	if ((is_inf(val)) || (is_NaN(val)))
	  sole_arg_wrong_type_error_nr(sc, sc->inexact_to_exact_symbol, x, A_Normal_Real_String);

	if ((val > Double_To_Int64_Limit) || (val < -(Double_To_Int64_Limit)))
	  {
#if With_Gmp
	    return(big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */
#else
	    sole_arg_out_of_range_error_nr(sc, sc->inexact_to_exact_symbol, x, It_Is_Too_Large_String);
#endif
	  }
	/* c_rationalize limit is Rationalize_Limit=1e12 currently so this is a tighter limit than Double_To_Int64_Limit */
	if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom))
	  return(make_simpler_ratio_or_integer(sc, numer, denom));
      }

    default:
      return(method_or_bust_p(sc, x, sc->inexact_to_exact_symbol, sc->type_names[T_REAL]));
    }
  return(x);
}

static s7_pointer g_inexact_to_exact(s7_scheme *sc, s7_pointer args)
{
  #define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2"
  #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
  return(inexact_to_exact_p_p(sc, car(args)));
}

static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args)
{
  #define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)"
  #define Q_is_exact sc->pl_bn

  const s7_pointer x = car(args);
  switch (type(x))
    {
    case T_INTEGER: case T_BIG_INTEGER:
    case T_RATIO:   case T_BIG_RATIO:
      return(sc->T);
    case T_REAL:    case T_BIG_REAL:
    case T_COMPLEX: case T_BIG_COMPLEX:
      return(sc->F);
    default:
      return(method_or_bust_p(sc, x, sc->is_exact_symbol, A_Number_String));
    }
}

static bool is_exact_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (!is_number(x))
    return(method_or_bust_p(sc, x, sc->is_exact_symbol, A_Number_String) != sc->F);
  return(is_rational(x));
}


static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args)
{
  #define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)"
  #define Q_is_inexact sc->pl_bn

  const s7_pointer x = car(args);
  switch (type(x))
    {
    case T_INTEGER:  case T_BIG_INTEGER:
    case T_RATIO:    case T_BIG_RATIO:
      return(sc->F);
    case T_REAL:     case T_BIG_REAL:
    case T_COMPLEX:  case T_BIG_COMPLEX:
      return(sc->T);
    default:
      return(method_or_bust_p(sc, x, sc->is_inexact_symbol, A_Number_String));
    }
}

static bool is_inexact_b_7p(s7_scheme *sc, s7_pointer x)
{
  if (!is_number(x))
    return(method_or_bust_p(sc, x, sc->is_inexact_symbol, A_Number_String) != sc->F);
  return(!is_rational(x));
}


/* ---------------------------------------- integer-length ---------------------------------------- */
static int32_t integer_length(s7_int a)
{
  if (a < 0)
    {
      if (a == s7_Int64_Min) return(63);
      a = -a;
    }
  if (a < Intlen_Bits_Size) return(intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */
  if (a < 65536LL) return(8 + intlen_bits[a >> 8]);
  if (a < 16777216LL) return(16 + intlen_bits[a >> 16]);
  if (a < 4294967296LL) return(24 + intlen_bits[a >> 24]);
  if (a < 1099511627776LL) return(32 + intlen_bits[a >> 32]);
  if (a < 281474976710656LL) return(40 + intlen_bits[a >> 40]);
  if (a < 72057594037927936LL) return(48 + intlen_bits[a >> 48]);
  return(56 + intlen_bits[a >> 56]);
}

static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args)
{
  #define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': \
(ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))"
  #define Q_integer_length sc->pcl_i

  const s7_pointer num = car(args);
  if (is_t_integer(num))
    {
      s7_int x = integer(num);
      return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x)));
    }
#if With_Gmp
  if (is_t_big_integer(num))
    return(make_integer(sc, mpz_sizeinbase(big_integer(num), 2)));
#endif
  return(sole_arg_method_or_bust(sc, num, sc->integer_length_symbol, args, sc->type_names[T_INTEGER]));
}

static s7_int integer_length_i_i(s7_int x) {return((x < 0) ? integer_length(-(x + 1)) : integer_length(x));}
#endif /* !pure s7 */


/* ---------------------------------------- integer-decode-float ---------------------------------------- */
static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args)
{
  #define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \
sign of 'x' (1 = positive, -1 = negative).  (integer-decode-float 0.0): (0 0 1)"
  #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol)

  decode_float_t num;
  const s7_pointer x = car(args);
  if (is_t_real(x))
    {
      if (real(x) == 0.0)
	return(list_3(sc, Int_Zero, Int_Zero, Int_One));
      num.fx = (double)real(x);
      return(list_3(sc,
		    make_integer_unchecked(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)),
		    make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)),
		    ((num.ix & 0x8000000000000000LL) != 0) ? Minus_One : Int_One));
    }
#if With_Gmp
  if (is_t_big_real(x))
    {
      mp_exp_t exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x));
      bool neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0);
      if (neg) mpz_abs(sc->mpz_1, sc->mpz_1);
      return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), (neg) ? Minus_One : Int_One));
      /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */
    }
#endif
  return(method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19)));
}


/* -------------------------------- logior -------------------------------- */

#if With_Gmp
static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args)
{
  mpz_set_si(sc->mpz_1, start);
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
      const s7_pointer n = car(p);
      switch (type(n))
	{
	case T_BIG_INTEGER:
	  mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(n));
	  break;
	case T_INTEGER:
	  mpz_set_si(sc->mpz_2, integer(n));
	  mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	  break;
	default:
	  if (!is_integer_via_method(sc, n))
	    wrong_type_error_nr(sc, sc->logior_symbol, position_of(p, args), n, sc->type_names[T_INTEGER]);
	  return(method_or_bust(sc, n, sc->logior_symbol,
				set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), p),
				sc->type_names[T_INTEGER], position_of(p, args)));
	}}
  return(mpz_to_integer(sc, sc->mpz_1));
}
#endif

static s7_pointer g_logior(s7_scheme *sc, s7_pointer args)
{
  #define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)"
  #define Q_logior sc->pcl_i

  s7_int result = 0;
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
#if With_Gmp
      if (is_t_big_integer(car(p)))
	return(big_logior(sc, result, p));
#endif
      if (!is_t_integer(car(p)))
	return(method_or_bust(sc, car(p), sc->logior_symbol,
			      (p == args) ? p : set_ulist_1(sc, make_integer(sc, result), p),
			      sc->type_names[T_INTEGER], position_of(p, args)));
      result |= integer(car(p));
    }
  return(make_integer(sc, result));
}

static s7_int logior_i_ii(s7_int i1, s7_int i2) {return(i1 | i2);}
static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 | i2 | i3);}

static s7_pointer g_logior_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, integer(car(args)) | integer(cadr(args))));}

static s7_pointer g_logior_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)))
    return(make_integer(sc, integer(arg1) | integer(arg2)));
  return(g_logior(sc, args));
}

static s7_pointer g_logior_2_wrapped(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)))
    return(wrap_integer(sc, integer(arg1) | integer(arg2)));
  return(g_logior(sc, args));
}

static s7_pointer logior_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2)
    {
      if (has_two_int_args(sc, expr)) return(sc->logior_ii);
      return(sc->logior_2);
    }
  return(func);
}


/* -------------------------------- logxor -------------------------------- */
#if With_Gmp
static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args)
{
  mpz_set_si(sc->mpz_1, start);
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
      const s7_pointer n = car(p);
      switch (type(n))
	{
	case T_BIG_INTEGER:
	  mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(n));
	  break;
	case T_INTEGER:
	  mpz_set_si(sc->mpz_2, integer(n));
	  mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	  break;
	default:
	  if (!is_integer_via_method(sc, n))
	    wrong_type_error_nr(sc, sc->logxor_symbol, position_of(p, args), n, sc->type_names[T_INTEGER]);
	  return(method_or_bust(sc, n, sc->logxor_symbol,
				set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), p),
				sc->type_names[T_INTEGER], position_of(p, args)));
	}}
  return(mpz_to_integer(sc, sc->mpz_1));
}
#endif

static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args)
{
  #define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)"
  #define Q_logxor sc->pcl_i

  s7_int result = 0;
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
#if With_Gmp
      if (is_t_big_integer(car(p)))
	return(big_logxor(sc, result, p));
#endif
      if (!is_t_integer(car(p)))
	return(method_or_bust(sc, car(p), sc->logxor_symbol,
			      (p == args) ? p : set_ulist_1(sc, make_integer(sc, result), p), /* not (result == 0), (logxor 1 1) is 0 */
			      sc->type_names[T_INTEGER], position_of(p, args)));
      result ^= integer(car(p));
    }
  return(make_integer(sc, result));
}

static s7_int logxor_i_ii(s7_int i1, s7_int i2) {return(i1 ^ i2);}
static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 ^ i2 ^ i3);}

static s7_pointer g_logxor_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)))
    return(make_integer(sc, integer(arg1) ^ integer(arg2)));
  return(g_logxor(sc, args));
}

static s7_pointer logxor_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->logxor_2 : func);}


/* -------------------------------- logand -------------------------------- */
#if With_Gmp
static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args)
{
  mpz_set_si(sc->mpz_1, start);
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
      const s7_pointer n = car(p);
      switch (type(n))
	{
	case T_BIG_INTEGER:
	  mpz_and(sc->mpz_1, sc->mpz_1, big_integer(n));
	  break;
	case T_INTEGER:
	  mpz_set_si(sc->mpz_2, integer(n));
	  mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2);
	  break;
	default:
	  if (!is_integer_via_method(sc, n))
	    wrong_type_error_nr(sc, sc->logand_symbol, position_of(p, args), n, sc->type_names[T_INTEGER]);
	  return(method_or_bust(sc, n, sc->logand_symbol,
				set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), p),
				sc->type_names[T_INTEGER], position_of(p, args)));
	}}
  return(mpz_to_integer(sc, sc->mpz_1));
}
#endif

static s7_pointer g_logand(s7_scheme *sc, s7_pointer args)
{
  #define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)"
  #define Q_logand sc->pcl_i

  s7_int result = -1;
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    {
#if With_Gmp
      if (is_t_big_integer(car(p)))
	return(big_logand(sc, result, p));
#endif
      if (!is_t_integer(car(p)))
	return(method_or_bust(sc, car(p), sc->logand_symbol,
			      (p == args) ? p : set_ulist_1(sc, make_integer(sc, result), p),
			      sc->type_names[T_INTEGER], position_of(p, args)));
      result &= integer(car(p));
    }
  return(make_integer(sc, result));
}

static s7_int logand_i_ii(s7_int i1, s7_int i2) {return(i1 & i2);}
static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 & i2 & i3);}

static s7_pointer g_logand_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, integer(car(args)) & integer(cadr(args))));}
static s7_pointer g_logand_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)))
    return(make_integer(sc, integer(arg1) & integer(arg2)));
  return(g_logand(sc, args));
}

static s7_pointer g_logand_2_wrapped(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg1 = car(args), arg2 = cadr(args);
  if ((is_t_integer(arg1)) && (is_t_integer(arg2)))
    return(wrap_integer(sc, integer(arg1) & integer(arg2)));
  return(g_logand(sc, args));
}

static s7_pointer logand_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2)
    {
      if (has_two_int_args(sc, expr)) return(sc->logand_ii);
      return(sc->logand_2);
    }
  return(func);
}


/* -------------------------------- lognot -------------------------------- */
static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args)
{
  #define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1"
  #define Q_lognot sc->pcl_i

  const s7_pointer x = car(args);
  if (is_t_integer(x))
    return(make_integer(sc, ~integer(x)));

#if With_Gmp
  if (is_t_big_integer(x))
    {
      mpz_com(sc->mpz_1, big_integer(x));
      return(mpz_to_integer(sc, sc->mpz_1));
    }
#endif
  return(sole_arg_method_or_bust(sc, x, sc->lognot_symbol, args, sc->type_names[T_INTEGER]));
}

static s7_int lognot_i_i(s7_int i1) {return(~i1);}

#if !With_Gmp
static s7_pointer g_lognot_wrapped(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args);
  if (is_t_integer(x))
    return(wrap_integer(sc, ~integer(x)));
  return(sole_arg_method_or_bust(sc, x, sc->lognot_symbol, args, sc->type_names[T_INTEGER]));
}
#endif


/* -------------------------------- logbit? -------------------------------- */
/* logbit?  CL is (logbitp index int) using 2^index, but that order strikes me as backwards
 *   at least gmp got the arg order right!
 */

static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args)
{
  #define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \
order here follows gmp, and is the opposite of the CL convention.  (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))."
  #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)

  const s7_pointer x = car(args), y = cadr(args);
  s7_int index;      /* index in gmp is mp_bitcnt which is an unsigned long int */

  if (!s7_is_integer(x))
    return(method_or_bust(sc, x, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 1));
  if (!s7_is_integer(y))
    return(method_or_bust(sc, y, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 2));

  index = s7_integer_clamped_if_gmp(sc, y);
  if (index < 0)
    out_of_range_error_nr(sc, sc->logbit_symbol, Int_Two, y, It_Is_Negative_String);

#if With_Gmp
  if (is_t_big_integer(x))
    return(make_boolean(sc, (mpz_tstbit(big_integer(x), index) != 0)));
#endif

  if (index >= s7_Int_Bits)           /* not sure about the >: (logbit? -1 64) ?? */
    return(make_boolean(sc, integer(x) < 0));
  /* (zero? (logand most-positive-fixnum (ash 1 63))) -> ash argument 2, 63, is out of range (shift is too large)
   *   so logbit? has a wider range than the logand/ash shuffle above.
   */

  /* all these s7_ints are necessary, else C turns it into an int, gets confused about signs etc */
  return(make_boolean(sc, ((((s7_int)(1LL << (s7_int)index)) & (s7_int)integer(x)) != 0)));
}

static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2)
{
  if (i2 < 0)
    {
      out_of_range_error_nr(sc, sc->logbit_symbol, Int_Two, wrap_integer(sc, i1), It_Is_Negative_String);
      return(false);
    }
  if (i2 >= s7_Int_Bits) return(i1 < 0);
  return((((s7_int)(1LL << (s7_int)i2)) & (s7_int)i1) != 0);
}

static bool logbit_b_7pp(s7_scheme *sc, s7_pointer i1, s7_pointer i2)
{
  if (is_t_integer(i1))
    {
      if (is_t_integer(i2))
	return(logbit_b_7ii(sc, integer(i1), integer(i2)));
      return(method_or_bust(sc, i2, sc->logbit_symbol, set_plist_2(sc, i1, i2), sc->type_names[T_INTEGER], 2) != sc->F);
    }
#if With_Gmp
  return(g_logbit(sc, set_plist_2(sc, i1, i2)));
#else
  return(method_or_bust(sc, i1, sc->logbit_symbol, set_plist_2(sc, i1, i2), sc->type_names[T_INTEGER], 1) != sc->F);
#endif
}


/* -------------------------------- ash -------------------------------- */
static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2)
{
  if (arg2 >= s7_Int_Bits)
    {
      if ((arg1 == -1) && (arg2 == 63))   /* (ash -1 63): most-negative-fixnum */
	return(s7_Int64_Min);
      if (arg1 == 0) return(0);
      out_of_range_error_nr(sc, sc->ash_symbol, Int_Two, wrap_integer(sc, arg2), It_Is_Too_Large_String);
    }
  if (arg2 < 0)
    {
      if (arg2 < -s7_Int_Bits)
	return((arg1 < 0) ? -1 : 0);      /* (ash -31 -100) */
      return(arg1 >> -arg2);
    }
  /* (ash 9223372036854775807 1) -> -2, anyone using ash must know something about bits */
  return(arg1 << arg2);
}

static s7_pointer g_ash(s7_scheme *sc, s7_pointer args)
{
  #define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1"
  #define Q_ash sc->pcl_i

#if With_Gmp
  /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */
  const s7_pointer i1 = car(args), i2 = cadr(args);

  /* here, as in expt, there are cases like (ash 1 63) which need to be bignums so there's no easy way to tell when it's safe to drop into g_ash instead */
  if ((s7_is_integer(i1)) && /* this includes bignum ints... */
      (s7_is_integer(i2)))
    {
      s7_int shift;
      const bool i1_is_big = is_big_number(i1);
      int32_t i1_compared_to_zero = 0;

      if (i1_is_big)
	i1_compared_to_zero = mpz_cmp_ui(big_integer(i1), 0);
      else
	if (integer(i1) > 0)
	  i1_compared_to_zero = 1;
	else i1_compared_to_zero = (integer(i1) < 0) ? -1 : 0;

      if (i1_compared_to_zero == 0)
	return(Int_Zero);

      if (is_big_number(i2))
	{
	  if (!mpz_fits_sint_p(big_integer(i2)))
	    {
	      if (mpz_cmp_ui(big_integer(i2), 0) > 0)
		out_of_range_error_nr(sc, sc->ash_symbol, Int_Two, i2, It_Is_Too_Large_String);

	      /* here if i1 is negative, we need to return -1 */
	      return((i1_compared_to_zero == 1) ? Int_Zero : Minus_One);
	    }
	  shift = mpz_get_si(big_integer(i2));
	}
      else
	{
	  shift = integer(i2);
	  if (shift < s7_Int32_Min)
	    return((i1_compared_to_zero == 1) ? Int_Zero : Minus_One);
	}
      if (shift > s7_Int32_Max)
	out_of_range_error_nr(sc, sc->ash_symbol, Int_Two, i2, It_Is_Too_Large_String); /* gmp calls abort if overflow here */

      if (is_t_big_integer(i1))
	mpz_set(sc->mpz_1, big_integer(i1));
      else mpz_set_si(sc->mpz_1, integer(i1));

      if (shift > 0)     /* left */
	mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift);
      else
	if (shift < 0) /* right */
	  mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift));

      return(mpz_to_integer(sc, sc->mpz_1));
    }
#endif
  const s7_pointer x = car(args), y = cadr(args);

  if (!s7_is_integer(x))
    return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1));
  if (!s7_is_integer(y))
    return(method_or_bust(sc, y, sc->ash_symbol, args, sc->type_names[T_INTEGER], 2));
  return(make_integer(sc, c_ash(sc, s7_integer_clamped_if_gmp(sc, x), s7_integer_clamped_if_gmp(sc, y))));
}

static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 << i2);} /* this may need gmp special handling, and out-of-range as in c_ash */
static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 >> (-i2));}
static s7_int rsh_i_i2_direct(s7_int i1, s7_int unused_i2) {return(i1 >> 1);}

#if !With_Gmp
static s7_int ash_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_ash(sc, i1, i2));}
/* this duplication (with c_ash) makes a big difference to callgrind -- why? */

static s7_pointer g_ash_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, c_ash(sc, integer(car(args)), integer(cadr(args)))));}

static s7_pointer g_ash_ic(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer x = car(args);
  const s7_int y = integer(cadr(args));
  if (!s7_is_integer(x))
    return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1));
  return(make_integer(sc, c_ash(sc, integer(x), y)));
}

static s7_pointer ash_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2)
    {
      const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
      if ((is_pair(arg1)) && (has_fn(arg1)))
	{
	  if (fn_proc(arg1) == g_logand_2) set_fn_direct(arg1, g_logand_2_wrapped);
	}
      if (has_two_int_args(sc, expr)) return(sc->ash_ii);
      if ((is_t_integer(arg2)) && (integer(arg2) > 0) && (integer(arg2) < s7_Int_Bits)) return(sc->ash_ic);
    }
  return(func);
}
#endif


/* -------------------------------- random-state -------------------------------- */
/* random numbers.  The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm.
 *     (random num) -> a number (0..num), if num == 0 return 0, use global default state
 *     (random num state) -> same but use this state
 *     (random-state seed) -> make a new state
 *   to save the current seed, use copy, to save it across load, random-state->list and list->random-state.
 *   random-state? returns #t if its arg is one of these guys
 */

static s7_pointer random_state_copy(s7_scheme *sc, s7_pointer args)
{
#if With_Gmp
  return(sc->F); /* I can't find a way to copy a gmp random generator */
#else
  s7_pointer new_r;
  const s7_pointer obj = car(args);
  if (!is_random_state(obj)) return(sc->F);
  new_cell(sc, new_r, T_RANDOM_STATE);
  random_seed(new_r) = random_seed(obj);
  random_carry(new_r) = random_carry(obj);
  return(new_r);
#endif
}

#ifndef MWC_32
  #define MWC_32 1
#endif

s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \
Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
    (let ((seed (random-state 1234))) (random 1.0 seed))"
  #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)

#if With_Gmp
  s7_pointer rs, seed;
  if (is_null(args))
    seed = s7_int_to_big_integer(sc, 1234); /* ?? */
  else
    {
      seed = car(args);
      if (!s7_is_integer(seed))
	return(sole_arg_method_or_bust(sc, seed, sc->random_state_symbol, args, sc->type_names[T_INTEGER]));
      if (is_t_integer(seed))
	seed = s7_int_to_big_integer(sc, integer(seed));
    }
  new_cell(sc, rs, T_RANDOM_STATE);
  gmp_randinit_default(random_gmp_state(rs));            /* Mersenne twister */
  gmp_randseed(random_gmp_state(rs), big_integer(seed)); /* this is ridiculously slow! */
  add_big_random_state(sc, rs);
  return(rs);
#else
  s7_pointer r1, r2, rs;
  s7_int i1, i2;  /* 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);
    }
  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);
#endif
}

#define g_random_state s7_random_state

static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc)
{
#if !With_Gmp
  if (loc == 0) return(make_integer(sc, random_seed(r)));
  if (loc == 1) return(make_integer(sc, random_carry(r)));
#endif
  return(sc->F);
}

static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val)
{
#if !With_Gmp
  if (is_t_integer(val))
    {
      s7_int i = s7_integer_clamped_if_gmp(sc, val);
      if (loc == 0) random_seed(r) = i;
      if (loc == 1) random_carry(r) = i;
    }
#endif
  return(sc->F);
}


/* -------------------------------- random-state? -------------------------------- */
static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)."
  #define Q_is_random_state sc->pl_bt
  check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args);
}

bool s7_is_random_state(s7_pointer r) {return(type(r) == T_RANDOM_STATE);}


/* -------------------------------- random-state->list -------------------------------- */
s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\
You can later apply random-state to this list to continue a random number sequence from any point."
  #define Q_random_state_to_list s7_make_signature(sc, 2, (With_Gmp) ? sc->is_list_symbol : sc->is_pair_symbol, sc->is_random_state_symbol)

#if With_Gmp
  if ((is_pair(args)) &&
      (!is_random_state(car(args))))
    return(method_or_bust(sc, car(args), sc->random_state_to_list_symbol, args, A_Random_State_Object_String, 1));
  return(sc->nil);
#else
  const s7_pointer r = (is_null(args)) ? sc->default_random_state : car(args);
  if (!is_random_state(r))
    return(method_or_bust(sc, r, sc->random_state_to_list_symbol, args, A_Random_State_Object_String, 1));
  return(list_2(sc, make_integer(sc, random_seed(r)), make_integer_unchecked(sc, random_carry(r))));
#endif
}

#define g_random_state_to_list s7_random_state_to_list

void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry)
{
#if !With_Gmp
  s7_pointer rs;
  new_cell(sc, rs, T_RANDOM_STATE);
  random_seed(rs) = (s7_uint)seed;
  random_carry(rs) = (s7_uint)carry;
  sc->default_random_state = rs;
#endif
}


/* -------------------------------- random -------------------------------- */
#if With_Gmp
static s7_double next_random(s7_scheme *sc)
#else
static s7_double next_random(s7_pointer r)
#endif
{
#if !With_Gmp
#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;
  const 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. */

  const 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

  return(result);
#else
  mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_random_state));
  return(mpfr_get_d(sc->mpfr_1, Mpfr_Rndn));
#endif
}

static s7_pointer g_random(s7_scheme *sc, s7_pointer args)
{
  #define H_random "(random num state) returns a random number of the same type as num between zero and num, equalling num only if num is zero"
  #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
  s7_pointer r, num;

  /* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)).  If
   *   we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following
   *   must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))).  The definition above is consistent
   *   with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1.
   */
  if (is_null(cdr(args)))
    r = sc->default_random_state;
  else
    {
      r = cadr(args);
      if (!is_random_state(r))
	return(method_or_bust(sc, r, sc->random_symbol, args, A_Random_State_Object_String, 2));
    }
  num = car(args);
  switch (type(num))
    {
#if !With_Gmp
    case T_INTEGER:
      return(make_integer(sc, (s7_int)(integer(num) * next_random(r))));
    case T_RATIO:
      {
	const s7_double x = fraction(num);
	s7_double error;
	s7_int numer = 0, denom = 1;
	/* the error here needs to take the size of the fraction into account.  Otherwise, if
	 *    error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807,
	 *    c_rationalize will always return 0.  But even that isn't foolproof:
	 *    (random 1/562949953421312) -> 1/376367230475000
	 */
	if ((x < 1.0e-10) && (x > -1.0e-10))
	  {
	    /* 1e-12 is not tight enough:
	     *    (random 1/2251799813685248) -> 1/2250240579436280
	     *    (random -1/4503599627370496) -> -1/4492889778435526
	     *    (random 1/140737488355328) -> 1/140730223985746
	     *    (random -1/35184372088832) -> -1/35183145492420
	     *    (random -1/70368744177664) -> -1/70366866392738
	     *    (random 1/4398046511104) -> 1/4398033095756
	     *    (random 1/137438953472) -> 1/137438941127
	     */
	    if (numerator(num) < -10)
	      numer = -(s7_int)(floor(-numerator(num) * next_random(r)));
	    else
	      if (numerator(num) > 10)
		numer = (s7_int)floor(numerator(num) * next_random(r));
	      else
		{
		  const s7_int diff = s7_Int64_Max - denominator(num);
		  numer = numerator(num);
		  if (diff < 100)
		    return(make_ratio(sc, numer, denominator(num)));
		  denom = denominator(num) + (s7_int)floor(diff * next_random(r));
		  return(make_ratio_with_div_check(sc, sc->random_symbol, numer, denom));
		}
	    return(make_ratio(sc, numer, denominator(num)));
	  }
	error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12;
	c_rationalize(x * next_random(r), error, &numer, &denom);
	return(make_simpler_ratio_or_integer(sc, numer, denom));
      }
    case T_REAL:
      return(make_real(sc, real(num) * next_random(r)));
      /* (x >> 11) * 0x1.0p-53, (1LL << 50) * 0x1.0p-53) -> .125, here "x" is 64 bits, but isn't this int64 related? */
    case T_COMPLEX:
      return(make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r)));
#else
    case T_INTEGER:
      if (integer(num) == 0) return(Int_Zero);
      mpz_set_si(sc->mpz_1, integer(num));
      mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1);
      if (integer(num) < 0) mpz_neg(sc->mpz_1, sc->mpz_1);
      return(make_integer(sc, mpz_get_si(sc->mpz_1)));
    case T_BIG_INTEGER:
      if (mpz_cmp_si(big_integer(num), 0) == 0) return(Int_Zero);
      mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num));
      /* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary */
      if (mpz_cmp_ui(big_integer(num), 0) < 0)
	mpz_neg(sc->mpz_1, sc->mpz_1);
      return(mpz_to_integer(sc, sc->mpz_1));
    case T_RATIO:
      mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
      mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
      mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, Mpfr_Rndn);
      mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, Mpfr_Rndn);
      return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2))));
    case T_BIG_RATIO:
      mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
      mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), Mpfr_Rndn);
      mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, Mpfr_Rndn);
      return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2))));
    case T_REAL:
      mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
      mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), Mpfr_Rndn);
      return(make_real(sc, mpfr_get_d(sc->mpfr_1, Mpfr_Rndn)));
    case T_BIG_REAL:
      mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
      mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), Mpfr_Rndn);
      return(mpfr_to_big_real(sc, sc->mpfr_1));
    case T_COMPLEX:
      mpc_urandom(sc->mpc_1, random_gmp_state(r));
      mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), real_part(num), Mpfr_Rndn);
      mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), imag_part(num), Mpfr_Rndn);
      return(make_complex(sc, mpfr_get_d(mpc_realref(sc->mpc_1), Mpfr_Rndn), mpfr_get_d(mpc_imagref(sc->mpc_1), Mpfr_Rndn)));
    case T_BIG_COMPLEX:
      mpc_urandom(sc->mpc_1, random_gmp_state(r));
      mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), mpc_realref(big_complex(num)), Mpfr_Rndn);
      mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), mpc_imagref(big_complex(num)), Mpfr_Rndn);
      return(mpc_to_number(sc, sc->mpc_1));
#endif
    default:
      return(method_or_bust(sc, num, sc->random_symbol, args, A_Number_String, 1));
    }
  return(sc->F);
}

s7_double s7_random(s7_scheme *sc, s7_pointer state)
{
#if With_Gmp
  mpfr_set_ui(sc->mpfr_1, 1, Mpfr_Rndn);
  mpfr_urandomb(sc->mpfr_1, random_gmp_state((state) ? state : sc->default_random_state));
  return((s7_double)mpfr_get_d(sc->mpfr_1, Mpfr_Rndn));
#else
  return(next_random((state) ? state : sc->default_random_state));
#endif
}

static s7_double random_d_7d(s7_scheme *sc, s7_double x)
{
#if With_Gmp
  return(real(g_random(sc, set_plist_1(sc, wrap_real(sc, x)))));
#else
  return(x * next_random(sc->default_random_state));
#endif
}

static s7_int random_i_7i(s7_scheme *sc, s7_int i)
{
#if With_Gmp
  return(integer(g_random(sc, set_plist_1(sc, wrap_integer(sc, i)))));
#else
  return((s7_int)(i * next_random(sc->default_random_state)));
#endif
}

static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args)
{
#if With_Gmp
  return(g_random(sc, args));
#else
  return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state))));
#endif
}

static s7_pointer g_random_f(s7_scheme *sc, s7_pointer args)
{
#if With_Gmp
  return(g_random(sc, args));
#else
  return(make_real(sc, real(car(args)) * next_random(sc->default_random_state)));
#endif
}

static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args)
{
#if !With_Gmp
  const s7_pointer num = car(args), r = sc->default_random_state;
  if (is_t_integer(num))
    return(make_integer(sc, (s7_int)(integer(num) * next_random(r))));
  if (is_t_real(num))
    return(make_real(sc, real(num) * next_random(r)));
#endif
  return(g_random(sc, args));
}

static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num)
{
#if !With_Gmp
  if (is_t_integer(num))
    return(make_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state))));
  if (is_t_real(num))
    return(make_real(sc, real(num) * next_random(sc->default_random_state)));
#endif
  return(g_random(sc, set_plist_1(sc, num)));
}

static s7_pointer random_p_p_wrapped(s7_scheme *sc, s7_pointer num)
{
#if !With_Gmp
  if (is_t_integer(num))
    return(wrap_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state))));
  if (is_t_real(num))
    return(wrap_real(sc, real(num) * next_random(sc->default_random_state)));
#endif
  return(g_random(sc, set_plist_1(sc, num)));
}

static s7_pointer random_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 1)
    {
      s7_pointer arg1 = cadr(expr);
      if (is_t_integer(arg1))
	return(sc->random_i);
      return((is_t_real(arg1)) ? sc->random_f : sc->random_1);
    }
  return(func);
}

static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args)
{
#if With_Gmp
  return(add_p_pp(sc, car(args), random_p_p_wrapped(sc, cadadr(args))));
#else
  s7_int x = integer(car(args)), y = opt3_int(args); /* cadadr */
  return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
#endif
}


/* -------------------------------- char<->integer -------------------------------- */
static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args)
{
  #define H_char_to_integer "(char->integer c) converts the character c to an integer"
  #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)

  if (!is_character(car(args)))
    return(sole_arg_method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, sc->type_names[T_CHARACTER]));
  return(small_int(character(car(args))));
}

static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(integer(method_or_bust_p(sc, c, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER])));
  return(character(c));
}

static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(method_or_bust_p(sc, c, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER]));
  return(make_integer(sc, character(c)));
}

static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x)
{
  s7_int ind;
  if (!s7_is_integer(x))
    return(method_or_bust_p(sc, x, sc->integer_to_char_symbol, sc->type_names[T_INTEGER]));
  ind = s7_integer_clamped_if_gmp(sc, x);
  if ((ind < 0) || (ind >= Num_Chars))
    sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doesn't fit in an unsigned byte", 34));
  return(chars[(uint8_t)ind]);
}

static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args)
{
  #define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character"
  #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)
  return(integer_to_char_p_p(sc, car(args)));
}

static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind)
{
  if ((ind < 0) || (ind >= Num_Chars))
    sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, wrap_integer(sc, ind),
				   wrap_string(sc, "it doesn't fit in an unsigned byte", 34)); /* int2 s7_out... uses 1 */
  return(chars[(uint8_t)ind]);
}


static uint8_t uppers[Num_Chars], lowers[Num_Chars];
static void init_uppers(void)
{
  for (int32_t i = 0; i < Num_Chars; i++)
    {
      uppers[i] = (uint8_t)toupper(i);
      lowers[i] = (uint8_t)tolower(i);
    }
}

static int digitp(int c) {return(((c >= '0') && (c <= '9')) ? 1 : 0);}

static void init_chars(void)
{
  s7_cell *cells = (s7_cell *)Calloc(Num_Chars + 1, sizeof(s7_cell));
  chars = (s7_pointer *)Malloc((Num_Chars + 1) * sizeof(s7_pointer));
  chars[0] = &cells[0];
  eof_object = chars[0];
  set_full_type(eof_object, T_EOF | T_Immutable | T_Unheap);
  eof_name_length(eof_object) = 6;
  eof_name(eof_object) = "#<eof>";
  chars++;                    /* now chars[EOF] == chars[-1] == #<eof> */
  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++)
    {
      const s7_pointer cp = &cells[i];
      const 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 Char_Name_Size 12
	  character_name_length(cp) = snprintf((char *)(&(character_name(cp))), Char_Name_Size, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c);
	  break;
	}}
}


/* -------------------------------- char-upcase, char-downcase ----------------------- */
static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(method_or_bust_p(sc, c, sc->char_upcase_symbol, sc->type_names[T_CHARACTER]));
  return(chars[upper_character(c)]);
}

static s7_pointer char_upcase_p_p_unchecked(s7_scheme *unused_sc, s7_pointer c) {return(chars[upper_character(c)]);}

static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args)
{
  #define H_char_upcase "(char-upcase c) converts the character c to upper case"
  #define Q_char_upcase sc->pcl_c
  return(char_upcase_p_p(sc, car(args)));
}

static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args)
{
  #define H_char_downcase "(char-downcase c) converts the character c to lower case"
  #define Q_char_downcase sc->pcl_c
  s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->char_downcase_symbol, args, sc->type_names[T_CHARACTER]));
  return(chars[lowers[character(c)]]);
}


/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */
static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic"
  #define Q_is_char_alphabetic sc->pl_bc
  s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, args, sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_alphabetic(c)));
  /* isalpha returns #t for (integer->char 226) and others in that range */
}

static bool is_char_alphabetic_b_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    sole_arg_wrong_type_error_nr(sc, sc->is_char_alphabetic_symbol, c, sc->type_names[T_CHARACTER]);
    /* return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* slower? see tmisc */
  return(is_char_alphabetic(c));
}

static s7_pointer is_char_alphabetic_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_alphabetic(c)));
}

static s7_pointer g_is_char_numeric(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit"
  #define Q_is_char_numeric sc->pl_bc

  const s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, args, sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_numeric(c)));
}

static bool is_char_numeric_b_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    sole_arg_wrong_type_error_nr(sc, sc->is_char_numeric_symbol, c, sc->type_names[T_CHARACTER]);
  /* return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* as above */
  return(is_char_numeric(c));
}

static s7_pointer is_char_numeric_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_numeric(c)));
}


static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character"
  #define Q_is_char_whitespace sc->pl_bc

  const s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_whitespace_symbol, args, sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_whitespace(c)));
}

static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    sole_arg_wrong_type_error_nr(sc, sc->is_char_whitespace_symbol, c, sc->type_names[T_CHARACTER]);
  return(is_char_whitespace(c));
}

static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_whitespace(c)));
}

static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(make_boolean(sc, is_char_whitespace(c)));}


/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */
static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case"
  #define Q_is_char_upper_case sc->pl_bc

  const s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_upper_case_symbol, args, sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_uppercase(c)));
}

static bool is_char_upper_case_b_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F);
  return(is_char_uppercase(c));
}

static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case"
  #define Q_is_char_lower_case sc->pl_bc

  const s7_pointer c = car(args);
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_lower_case_symbol, args, sc->type_names[T_CHARACTER]));
  return(make_boolean(sc, is_char_lowercase(c)));
}

static bool is_char_lower_case_b_7p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(sole_arg_method_or_bust(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F);
  return(is_char_lowercase(c));
}


/* -------------------------------- char? -------------------------------- */
static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char "(char? obj) returns #t if obj is a character"
  #define Q_is_char sc->pl_bt
  check_boolean_method(sc, is_character, sc->is_char_symbol, args);
}

static s7_pointer is_char_p_p(s7_scheme *sc, s7_pointer p) {return((is_character(p)) ? sc->T : sc->F);}

s7_pointer s7_make_character(s7_scheme *sc, uint8_t c) {return(chars[c]);}

bool s7_is_character(s7_pointer c) {return(is_character(c));}

uint8_t s7_character(s7_pointer c) {return(character(c));}


/* -------------------------------- char<? char<=? char>? char>=? char=? -------------------------------- */
static int32_t charcmp(uint8_t c1, uint8_t c2)
{
  return((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1);
  /* not tolower here -- the single case is apparently supposed to be upper case
   *   this matters in a case like (char-ci<? #\_ #\e) which Guile and Gauche say is #f
   *   although (char<? #\_ #\e) is #t -- the spec does not say how to interpret this!
   */
}

static bool is_character_via_method(s7_scheme *sc, s7_pointer p)
{
  if (is_character(p))
    return(true);
  if (has_active_methods(sc, p))
    {
      s7_pointer func = find_method_with_let(sc, p, sc->is_char_symbol);
      if (func != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p))));
    }
  return(false);
}

static s7_pointer char_with_error_check(s7_scheme *sc, s7_pointer args_left, s7_pointer args, s7_pointer caller)
{
  for (s7_pointer chrs = cdr(args_left); is_pair(chrs); chrs = cdr(chrs)) /* before returning #f, check for bad trailing arguments */
    if (!is_character_via_method(sc, car(chrs)))
      wrong_type_error_nr(sc, caller, position_of(chrs, args), car(chrs), sc->type_names[T_CHARACTER]);
  return(sc->F);
}

static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer c = car(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, sym, args, sc->type_names[T_CHARACTER], 1));
  for (s7_pointer chrs = cdr(args); is_pair(chrs); c = car(chrs), chrs = cdr(chrs))
    {
      if (!is_character(car(chrs)))
	return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, c, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args)));
      if (charcmp(character(c), character(car(chrs))) != val)
	return(char_with_error_check(sc, chrs, args, sym));
    }
  return(sc->T);
}

static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer c = car(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, sym, args, sc->type_names[T_CHARACTER], 1));
  for (s7_pointer chrs = cdr(args); is_pair(chrs); c = car(chrs), chrs = cdr(chrs))
    {
      if (!is_character(car(chrs)))
	return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, c, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args)));
      if (charcmp(character(c), character(car(chrs))) == val)
	return(char_with_error_check(sc, chrs, args, sym));
    }
  return(sc->T);
}

static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal"
  #define Q_chars_are_equal sc->pcl_bc

  const s7_pointer c = car(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1));
  for (s7_pointer chrs = cdr(args); is_pair(chrs); chrs = cdr(chrs))
    {
      if (!is_character(car(chrs)))
	return(method_or_bust(sc, car(chrs), sc->char_eq_symbol, set_ulist_1(sc, c, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args)));
      if (car(chrs) != c)
	return(char_with_error_check(sc, chrs, args, sc->char_eq_symbol));
    }
  return(sc->T);
}


static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_less "(char<? char ...) returns #t if all the character arguments are increasing"
  #define Q_chars_are_less sc->pcl_bc
  return(g_char_cmp(sc, args, -1, sc->char_lt_symbol));
}

static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing"
  #define Q_chars_are_greater sc->pcl_bc
  return(g_char_cmp(sc, args, 1, sc->char_gt_symbol));
}

static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing"
  #define Q_chars_are_geq sc->pcl_bc
  return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol));
}

static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing"
  #define Q_chars_are_leq sc->pcl_bc
  return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol));
}

static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, car(args) == cadr(args)));} /* chooser checks types */
static s7_pointer g_simple_char_eq1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer c1 = car(args), c2 = cadr(args);
  if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2));
  return(make_boolean(sc, c1 == c2)); /* chars are unique so we can compare pointers */
}
static s7_pointer g_simple_char_eq2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer c1 = car(args), c2 = cadr(args);
  if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1));
  return(make_boolean(sc, c1 == c2));
}

#define check_char2_args(Sc, Caller, C1, C2) \
  do { \
      if (!is_character(C1)) return(method_or_bust(Sc, C1, Caller, set_plist_2(Sc, C1, C2), Sc->type_names[T_CHARACTER], 1) != sc->F); \
      if (!is_character(C2)) return(method_or_bust(Sc, C2, Caller, set_plist_2(Sc, C1, C2), Sc->type_names[T_CHARACTER], 2) != sc->F); \
     } while (0)

static bool char_lt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 < c2);}
static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_lt_symbol, c1, c2);
  return(c1 < c2);
}

static bool char_leq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 <= c2);}
static bool char_leq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_leq_symbol, c1, c2);
  return(c1 <= c2);
}

static bool char_gt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 > c2);}
static bool char_gt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_gt_symbol, c1, c2);
  return(c1 > c2);
}

static bool char_geq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 >= c2);}
static bool char_geq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_geq_symbol, c1, c2);
  return(c1 >= c2);
}

static bool char_eq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 == c2);}

static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 1) != sc->F);
  if (c1 == c2) return(true);
  if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 2) != sc->F);
  return(false);
}

static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 1));
  if (c1 == c2) return(sc->T);
  if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 2));
  return(sc->F);
}

static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1));
  if (car(args) == cadr(args))
    return(sc->T);
  if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2));
  return(sc->F);
}

static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 1));
  if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 2));
  return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}

static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 1));
  if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 2));
  return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}

static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1)
{
  if (is_symbol(arg1))
    {
      s7_pointer slot = s7_slot(sc, arg1);
      if (is_slot(slot)) return(s7_type_of(sc, slot_value(slot)));
    }
  else
    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))))
	  {
	    const 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 return(s7_type_of(sc, arg1));
  return(NULL);
}

static bool returns_char(s7_scheme *sc, s7_pointer arg) {return(argument_type(sc, arg) == sc->is_char_symbol);}

static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args != 2) return(func);
    {
      const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
      if (returns_char(sc, arg1))
	{
	  if (returns_char(sc, arg2)) return(sc->simple_char_eq);
	  return(sc->simple_char_eq1);
	}
      else
	if (returns_char(sc, arg2)) return(sc->simple_char_eq2);
    }
  return(sc->char_equal_2);
}

static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)    {return((args == 2) ? sc->char_less_2 : func);}
static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->char_greater_2 : func);}


/* -------------------------------- char-ci<? char-ci<=? char-ci>? char-ci>=? char-ci=? -------------------------------- */
#if !With_Pure_s7
static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer c = car(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, sym, args, sc->type_names[T_CHARACTER], 1));

  for (s7_pointer chrs = cdr(args); is_pair(chrs); c = car(chrs), chrs = cdr(chrs))
    {
      if (!is_character(car(chrs)))
	return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, c, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args)));
      if (charcmp(upper_character(c), upper_character(car(chrs))) != val)
	return(char_with_error_check(sc, chrs, args, sym));
    }
  return(sc->T);
}

static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer c = car(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, sym, args, sc->type_names[T_CHARACTER], 1));
  for (s7_pointer chrs = cdr(args); is_pair(chrs); c = car(chrs), chrs = cdr(chrs))
    {
      if (!is_character(car(chrs)))
	return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, c, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args)));
      if (charcmp(upper_character(c), upper_character(car(chrs))) == val)
	return(char_with_error_check(sc, chrs, args, sym));
    }
  return(sc->T);
}

static s7_pointer g_chars_are_ci_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case"
  #define Q_chars_are_ci_equal sc->pcl_bc
  return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol));
}

static s7_pointer g_chars_are_ci_less(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_ci_less "(char-ci<? char ...) returns #t if all the character arguments are increasing, ignoring case"
  #define Q_chars_are_ci_less sc->pcl_bc
  return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol));
}

static s7_pointer g_chars_are_ci_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case"
  #define Q_chars_are_ci_greater sc->pcl_bc
  return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol));
}

static s7_pointer g_chars_are_ci_geq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case"
  #define Q_chars_are_ci_geq sc->pcl_bc
  return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol));
}

static s7_pointer g_chars_are_ci_leq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case"
  #define Q_chars_are_ci_leq sc->pcl_bc
  return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol));
}


static bool char_ci_lt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) < upper_character(c2));}
static bool char_ci_lt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_ci_lt_symbol, c1, c2);
  return(upper_character(c1) < upper_character(c2));
}

static bool char_ci_leq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) <= upper_character(c2));}
static bool char_ci_leq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_ci_leq_symbol, c1, c2);
  return(upper_character(c1) <= upper_character(c2));
}

static bool char_ci_gt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) > upper_character(c2));}
static bool char_ci_gt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_ci_gt_symbol, c1, c2);
  return(upper_character(c1) > upper_character(c2));
}

static bool char_ci_geq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) >= upper_character(c2));}
static bool char_ci_geq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_ci_geq_symbol, c1, c2);
  return(upper_character(c1) >= upper_character(c2));
}

static bool char_ci_eq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) == upper_character(c2));}
static bool char_ci_eq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2)
{
  check_char2_args(sc, sc->char_ci_eq_symbol, c1, c2);
  return(upper_character(c1) == upper_character(c2));
}

#endif /* not pure s7 */


/* -------------------------------- char-position -------------------------------- */
static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
{
  #define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f"
  #define Q_char_position s7_make_signature(sc, 4, \
                            s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \
                            s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), \
                            sc->is_string_symbol, sc->is_integer_symbol)
  s7_int start;
  const s7_pointer arg1 = car(args);
  s7_pointer arg2;

  if ((!is_character(arg1)) && (!is_string(arg1)))
    return(method_or_bust(sc, arg1, sc->char_position_symbol, args, sc->type_names[T_CHARACTER], 1));

  arg2 = cadr(args);
  if (!is_string(arg2))
    return(method_or_bust(sc, arg2, sc->char_position_symbol, args, sc->type_names[T_STRING], 2));

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(method_or_bust(sc, arg3, sc->char_position_symbol, args, sc->type_names[T_INTEGER], 3));
      start = s7_integer_clamped_if_gmp(sc, arg3);
      if (start < 0)
	wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, A_Non_Negative_Integer_String);
    }
  else start = 0;

  {
    const char *porig = string_value(arg2);
    const s7_int len = string_length(arg2);
    if (start >= len) return(sc->F);

    if (is_character(arg1))
      {
	char c = character(arg1);
	const char *p = strchr((const char *)(porig + start), (int)c); /* use strchrnul in Gnu C to catch embedded null case */
	return((p) ? make_integer(sc, p - porig) : sc->F);
      }
    if (string_length(arg1) == 0)
      return(sc->F);
    {
      const char *pset = string_value(arg1);
      const s7_int pos = strcspn((const char *)(porig + start), (const char *)pset);
      if ((pos + start) < len)
	return(make_integer(sc, pos + start));
    }}
  /* if the string has an embedded null, we can get erroneous results here --
   *   perhaps check for null at pos+start?  What about a searched-for string that also has embedded nulls?
   */
  return(sc->F);
}

static s7_pointer char_position_p_ppi(s7_scheme *sc, s7_pointer chr, s7_pointer str, s7_int start)
{
  if (!is_string(str))
    wrong_type_error_nr(sc, sc->char_position_symbol, 2, str, sc->type_names[T_STRING]);
  if (start < 0)
    wrong_type_error_nr(sc, sc->char_position_symbol, 3, wrap_integer(sc, start), A_Non_Negative_Integer_String);
  {
    const char *p;
    const char c = character(chr);
    const s7_int len = string_length(str);
    const char *porig = string_value(str);
    if (start >= len) return(sc->F);
    p = strchr((const char *)(porig + start), (int)c);
    if (p) return(make_integer(sc, p - porig));
  }
  return(sc->F);
}

static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args)
{
  /* assume char arg1, no end */
  const char *porig;
  const char c = character(car(args));
  const s7_pointer arg2 = cadr(args);
  s7_int start, len;

  if (!is_string(arg2))
    return(g_char_position(sc, args));

  len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */
  porig = string_value(arg2);
  if (is_pair(cddr(args)))
    {
      const s7_pointer arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(g_char_position(sc, args));
      start = s7_integer_clamped_if_gmp(sc, arg3);
      if (start < 0)
	wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, A_Non_Negative_Integer_String);
      if (start >= len) return(sc->F);
    }
  else start = 0;
  if (len == 0) return(sc->F);
  {
    const char *p = strchr((const char *)(porig + start), (int)c); /* const for g++, see also below */
    return((p) ? make_integer(sc, p - porig) : sc->F);
  }
}

static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((is_character(cadr(expr))) && ((args == 2) || (args == 3)))
    return(sc->char_position_csi);
  return(func);
}


/* -------------------------------- string-position -------------------------------- */
static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args)
{
  #define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f"
  #define Q_string_position s7_make_signature(sc, 4, \
                              s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \
                              sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
  s7_int start = 0;
  const s7_pointer str1 = car(args), str2 = cadr(args);

  if (!is_string(str1))
    return(method_or_bust(sc, str1, sc->string_position_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_string(str2))
    return(method_or_bust(sc, str2, sc->string_position_symbol, args, sc->type_names[T_STRING], 2));

  if (is_pair(cddr(args)))
    {
      const s7_pointer arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(method_or_bust(sc, arg3, sc->string_position_symbol, args, sc->type_names[T_INTEGER], 3));
      start = s7_integer_clamped_if_gmp(sc, arg3);
      if (start < 0)
	wrong_type_error_nr(sc, sc->string_position_symbol, 3, caddr(args), A_Non_Negative_Integer_String);
    }
  if (string_length(str1) == 0) return(sc->F);
  if (start >= string_length(str2)) return(sc->F);
  {
    const char *s1 = string_value(str1);
    const char *s2 = string_value(str2);
    const char *p2 = strstr((const char *)(s2 + start), s1); /* g++ insists on const */
    return((p2) ? make_integer(sc, p2 - s2) : sc->F);
  }
}


/* -------------------------------- strings -------------------------------- */
bool s7_is_string(s7_pointer p) {return(is_string(p));}

static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args)
{
  #define H_is_string "(string? obj) returns #t if obj is a string"
  #define Q_is_string sc->pl_bt
  check_boolean_method(sc, is_string, sc->is_string_symbol, args);
}


s7_int s7_string_length(s7_pointer str) {return(string_length(str));}

static s7_pointer nil_string; /* permanent "" */
/* nil_vector is complicated by the many vector types, and s7test assumes it is mutable! and not eq? to other nil_vectors (watch out for add_vector!) */

static 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 | 0xffff00000000))) != (T_STRING | T_Unheap | T_Safe_Procedure | T_Immutable | T_Wrapper)) /* ignore opt_bits */
    {fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, temp_str)); abort();}
  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 s7_make_string_wrapper(s7_scheme *sc, const char *str) {return(wrap_string(sc, str, safe_strlen(str)));}
s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len) {return(wrap_string(sc, str, len));}

static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, char fill)
{
  s7_pointer new_string;
  block_t *b = inline_mallocate(sc, len + 1);
  if ((s7_Debugging) && (len == 0)) {fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__); return(nil_string);}
  new_cell(sc, new_string, T_STRING);
  string_block(new_string) = b;
  string_value(new_string) = (char *)block_data(b);
  if (fill != '\0')
    local_memset((void *)(string_value(new_string)), fill, len);
  string_value(new_string)[len] = 0;
  string_hash(new_string) = 0;
  string_length(new_string) = len;
  add_string(sc, new_string);
  return(new_string);
}

static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));}

s7_pointer s7_make_string(s7_scheme *sc, const char *str)
{
  s7_int len = safe_strlen(str);
  return((len > 0) ? make_string_with_length(sc, str, len) : nil_string);
}

static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */
{
  const 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);
}

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 not calloc'd (checks T_Immutable which malloc might include) */
  set_alloc_info(new_string, __func__, __LINE__);
  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", 30);
  Result_Is_Too_Large_String =    make_permanent_string("result is too large", 19);
  Something_Applicable_String =   make_permanent_string("a procedure or something applicable", 35);
  Too_Many_Indices_String =       make_permanent_string("too many indices", 16);
#if !Have_Complex_Numbers
  No_Complex_Numbers_String =     make_permanent_string("this version of s7 does not support complex numbers", 51);
#endif
  Keyword_Value_Missing_String =  make_permanent_string("~A: keyword argument's value is missing: ~S in ~S", 49);

  Format_String_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A", 24);
  Format_String_2 = make_permanent_string("format: ~S: ~A", 14);
  Format_String_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A", 30);
  Format_String_4 = make_permanent_string("format: ~S~&~NT^: ~A", 20);

  Too_Many_Arguments_String = make_permanent_string("~S: too many arguments: ~A", 26);
  Not_Enough_Arguments_String = make_permanent_string("~S: not enough arguments: ~A", 28);
}


/* -------------------------------- make-string -------------------------------- */
s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) {return(make_string_with_length(sc, str, len));}

static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args)
{
  #define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)"
  #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)

  const s7_pointer n = car(args);
  s7_int len;
  if (!s7_is_integer(n))
    {
      if_method_exists_return_value(sc, n, sc->make_string_symbol, args);
      wrong_type_error_nr(sc, sc->make_string_symbol, 1, n, sc->type_names[T_INTEGER]);
    }
  if ((is_pair(cdr(args))) &&
      (!is_character(cadr(args))))
    return(method_or_bust(sc, cadr(args), sc->make_string_symbol, args, sc->type_names[T_CHARACTER], 2));

  len = s7_integer_clamped_if_gmp(sc, n);
  if (len == 0) return(nil_string);
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_string_symbol, Int_One, n, It_Is_Negative_String);
  if (len > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
  if (is_null(cdr(args)))
    return(make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */
  {
    char fill = s7_character(cadr(args));
    s7_pointer result = make_empty_string(sc, len, fill);
    if (fill == '\0')
      memclr((void *)string_value(result), (size_t)len);
    return(result);
  }
}

static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len)
{
  if (len == 0) return(nil_string);
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_string_symbol, Int_One, wrap_integer(sc, len), It_Is_Negative_String);
  if (len > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
  return(make_empty_string(sc, len, '\0'));
}


#if !With_Pure_s7
/* -------------------------------- string-length -------------------------------- */
static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args)
{
  #define H_string_length "(string-length str) returns the length of the string str"
  #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
  s7_pointer str = car(args);
  if (!is_string(str))
    return(sole_arg_method_or_bust(sc, str, sc->string_length_symbol, args, sc->type_names[T_STRING]));
  return(make_integer(sc, string_length(str)));
}

static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer str)
{
  if (!is_string(str))
    return(integer(method_or_bust_p(sc, str, sc->string_length_symbol, sc->type_names[T_STRING])));
  return(string_length(str));
}
#endif


/* -------------------------------- string-up|downcase -------------------------------- */
static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args)
{
  #define H_string_downcase "(string-downcase str) returns the lower case version of str."
  #define Q_string_downcase sc->pcl_s

  const s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust_p(sc, str, sc->string_downcase_symbol, sc->type_names[T_STRING]));
  {
    const s7_int len = string_length(str);
    if (len == 0) return(nil_string);
    {
      const s7_pointer newstr = make_empty_string(sc, len, '\0');
      const uint8_t *ostr = (const uint8_t *)string_value(str);
      uint8_t *nstr = (uint8_t *)string_value(newstr);
      if (len >= 128)
	{
	  s7_int i = len - 1;
	  while (i >= 8)
	    Loop_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--);
	  while (i >= 0) {nstr[i] = lowers[(uint8_t)ostr[i]]; i--;}
	}
      else
	for (s7_int i = 0; i < len; i++) nstr[i] = lowers[(uint8_t)ostr[i]];
      return(newstr);
    }}
}

static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args)
{
  #define H_string_upcase "(string-upcase str) returns the upper case version of str."
  #define Q_string_upcase sc->pcl_s

  const s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust_p(sc, str, sc->string_upcase_symbol, sc->type_names[T_STRING]));

  {
    const s7_int len = string_length(str);
    if (len == 0) return(nil_string);
    {
      const s7_pointer newstr = make_empty_string(sc, len, '\0');
      const uint8_t *ostr = (const uint8_t *)string_value(str);
      uint8_t *nstr = (uint8_t *)string_value(newstr);
      if (len >= 128)
	{
	  s7_int i = len - 1;
	  while (i >= 8)
	    Loop_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--);
	  while (i >= 0) {nstr[i] = uppers[(uint8_t)ostr[i]]; i--;}
	}
      else
	for (s7_int i = 0; i < len; i++) nstr[i] = uppers[(uint8_t)ostr[i]];
      return(newstr);
    }}
}


/* -------------------------------- string-ref -------------------------------- */
static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index)
{
  char *str;
  s7_int ind;

  if (!s7_is_integer(index))
    return(method_or_bust_pp(sc, index, sc->string_ref_symbol, strng, index, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if (ind < 0)
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, index, It_Is_Negative_String);
  if (ind >= string_length(strng))
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, index, It_Is_Too_Large_String);

  str = string_value(strng);
  return(chars[((uint8_t *)str)[ind]]);
}

static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str"
  #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)

  s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->string_ref_symbol, args, sc->type_names[T_STRING], 1));
  return(string_ref_1(sc, str, cadr(args)));
}

static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer str, s7_int index)
{
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->string_ref_symbol, set_plist_2(sc, str, make_integer(sc, index)), sc->type_names[T_STRING], 1));
  if ((index < 0) || (index >= string_length(str)))
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(chars[((uint8_t *)string_value(str))[index]]);
}

static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer index)
{
  if (!is_string(str))
    return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, index, sc->type_names[T_STRING], 1));
  return(string_ref_1(sc, str, index));
}

static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer str, s7_pointer unused_index)
{
  if (!is_string(str))
    return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, Int_Zero, sc->type_names[T_STRING], 1));
  if (string_length(str) <= 0)
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, Int_Zero, It_Is_Too_Large_String);
  return(chars[((uint8_t *)string_value(str))[0]]);
}

static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer str) /* tmock */
{
  s7_pointer len = method_or_bust_p(sc, str, sc->length_symbol, sc->type_names[T_STRING]);
  return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, make_integer(sc, integer(len) - 1), sc->type_names[T_STRING], 1));
}

static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer str, s7_pointer unused_index)
{
  if (!is_string(str))
    return(string_plast_via_method(sc, str));
  if (string_length(str) <= 0)
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, wrap_integer(sc, string_length(str) - 1), It_Is_Too_Large_String);
  return(chars[((uint8_t *)string_value(str))[string_length(str) - 1]]);
}

static inline s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer str, s7_int index)
{
  if ((index < 0) || (index >= string_length(str)))
    out_of_range_error_nr(sc, sc->string_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(chars[((uint8_t *)string_value(str))[index]]);
}

static s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index) {return(chars[((uint8_t *)string_value(str))[index]]);}


/* -------------------------------- string-set! -------------------------------- */
static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
{
  #define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr"
  #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)

  const s7_pointer strng = car(args), index = cadr(args);
  s7_int ind;

  if (!is_mutable_string(strng))
    return(mutable_method_or_bust(sc, strng, sc->string_set_symbol, args, sc->type_names[T_STRING], 1));
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->string_set_symbol, args, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if (ind < 0)
    out_of_range_error_nr(sc, sc->string_set_symbol, Int_Two, index, A_Non_Negative_Integer_String);
  if (ind >= string_length(strng))
    out_of_range_error_nr(sc, sc->string_set_symbol, Int_Two, index, It_Is_Too_Large_String);
  {
    char *str = string_value(strng);
    const s7_pointer c = caddr(args);
    if (!is_character(c))
      return(method_or_bust(sc, c, sc->string_set_symbol, args, sc->type_names[T_CHARACTER], 3));
    str[ind] = (char)s7_character(c);
    return(c);
  }
}

static s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr)
{
  if (!is_string(str))
    wrong_type_error_nr(sc, sc->string_set_symbol, 1, str, sc->type_names[T_STRING]);
  if (!is_character(chr))
    wrong_type_error_nr(sc, sc->string_set_symbol, 2, chr, sc->type_names[T_CHARACTER]);
  if ((index >= 0) && (index < string_length(str)))
    string_value(str)[index] = s7_character(chr);
  else out_of_range_error_nr(sc, sc->string_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(chr);
}

static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr)
{
  if ((index >= 0) && (index < string_length(str)))
    string_value(str)[index] = s7_character(chr);
  else out_of_range_error_nr(sc, sc->string_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(chr);
}

static s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index, s7_pointer chr)
{
  string_value(str)[index] = s7_character(chr);
  return(chr);
}


/* -------------------------------- string-append -------------------------------- */
static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj);

static bool sequence_is_empty(s7_scheme *sc, s7_pointer seq) /* "is_empty" is taken by C++?? */
{
  switch (type(seq))
    {
    case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR:
    case T_VECTOR:     return(vector_length(seq) == 0);
    case T_NIL:        return(true);
    case T_PAIR:       return(false);
    case T_STRING:     return(string_length(seq) == 0);
    case T_HASH_TABLE: return(hash_table_entries(seq) == 0);
    case T_C_OBJECT:   return(s7_is_eqv(sc, c_object_length(sc, seq), Int_Zero));
    case T_LET:        if (seq != sc->rootlet) return(!is_slot_checked(let_slots(seq))); /* (append (rootlet) #f) */
    default:           return(false);
    }
}

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);
    }
}

static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args);

static void string_append_2(s7_scheme *sc, s7_pointer newstr, s7_pointer args, const s7_pointer stop_arg, s7_pointer caller)
{
  s7_int len;
  char *pos = string_value(newstr);
  for (s7_pointer strs = args; strs != stop_arg; strs = cdr(strs))
    {
      const s7_pointer str = car(strs);
      if (is_string(str))
	{
	  len = string_length(str);
	  if (len > 0)
	    {
	      memcpy(pos, string_value(str), len);
	      pos += len;
	    }}
      else
	if (!sequence_is_empty(sc, str))
	  {
	    char *old_str = string_value(newstr);
	    string_value(newstr) = pos;
	    len = sequence_length(sc, str);
	    s7_copy_1(sc, caller, set_plist_2(sc, str, newstr));
	    string_value(newstr) = old_str;
	    pos += len;
	  }}
}

static s7_pointer string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  #define H_string_append "(string-append str1 ...) appends all its string arguments into one string"
  #define Q_string_append sc->pcl_s

  s7_int len = 0;
  s7_pointer newstr;
  bool just_strings = true;

  if (is_null(args))
    return(nil_string);

  gc_protect_via_stack(sc, args);
  /* get length for new string */
  for (s7_pointer strs = args; is_pair(strs); strs = cdr(strs))
    {
      const s7_pointer str = car(strs);
      if (is_string(str))
	len += string_length(str);
      else
	{
	  s7_int newlen;
	  if (!is_sequence(str))
	    {
	      unstack_gc_protect(sc);
	      wrong_type_error_nr(sc, caller, position_of(strs, args), str, sc->type_names[T_STRING]);
	    }
	  if (has_active_methods(sc, str)) /* look for string-append and if found, cobble up a plausible intermediate call */
	    {
	      const s7_pointer func = find_method_with_let(sc, str, caller);
	      if (func != sc->undefined)
		{
		  if (len == 0)
		    {
		      unstack_gc_protect(sc);
		      return(s7_apply_function(sc, func, strs)); /* not args (string-append "" "" ...) */
		    }
		  newstr = make_empty_string(sc, len, '\0');
		  string_append_2(sc, newstr, args, strs, caller);
		  unstack_gc_protect(sc);
		  return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, strs)));
		}}
	  if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol))
	    {
	      unstack_gc_protect(sc);
	      wrong_type_error_nr(sc, caller, position_of(strs, args), str, sc->type_names[T_STRING]);
	    }
	  newlen = sequence_length(sc, str);
	  if (newlen < 0)
	    {
	      unstack_gc_protect(sc);
	      wrong_type_error_nr(sc, caller, position_of(strs, args), str, sc->type_names[T_STRING]);
	    }
	  just_strings = false;
	  len += newlen;
	}}
  if (len == 0)
    {
      unstack_gc_protect(sc);
      return(nil_string);
    }
  if (len > sc->max_string_length)
    {
      unstack_gc_protect(sc);
      error_nr(sc, sc->out_of_range_symbol,
	       set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70),
			   caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
    }
  newstr = inline_make_empty_string(sc, len, '\0');
  if (just_strings)
    {
      s7_pointer strs = args;
      for (char *pos = string_value(newstr); is_pair(strs); strs = cdr(strs))
	{
	  len = string_length(car(strs));
	  if (len > 0)
	    {
	      memcpy(pos, string_value(car(strs)), len);
	      pos += len;
	    }}}
  else string_append_2(sc, newstr, args, sc->nil, caller);
  unstack_gc_protect(sc);
  return(newstr);
}

static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args) {return(string_append_1(sc, args, sc->string_append_symbol));}

static inline s7_pointer string_append_3(s7_scheme *sc, s7_pointer s1, s7_pointer s2)
{
  if ((is_string(s1)) && (is_string(s2)))
    {
      s7_int len;
      const s7_int pos = string_length(s1);
      s7_pointer newstr;
      if (pos == 0) return(make_string_with_length(sc, string_value(s2), string_length(s2)));
      len = pos + string_length(s2);
      if (len == pos) return(make_string_with_length(sc, string_value(s1), string_length(s1)));
      if (len > sc->max_string_length)
	error_nr(sc, sc->out_of_range_symbol,
		 set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70),
			     sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
      begin_temp(sc->x, s2); /* or temp6 if this collides */
      newstr = make_empty_string(sc, len, '\0'); /* len+1 0-terminated */
      memcpy(string_value(newstr), string_value(s1), pos);
      memcpy((char *)(string_value(newstr) + pos), string_value(s2), string_length(s2));
      end_temp(sc->x);
      return(newstr);
    }
  return(string_append_1(sc, list_2(sc, s1, s2), sc->string_append_symbol));
}

static s7_pointer string_append_p_pp(s7_scheme *sc, s7_pointer s1, s7_pointer s2) {return(string_append_3(sc, s1, s2));}

static s7_pointer g_string_append_2(s7_scheme *sc, s7_pointer args) {return(string_append_3(sc, car(args), cadr(args)));}

static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr);

static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return((args == 2) ? sc->string_append_2 : func);
}


/* -------------------------------- substring -------------------------------- */
static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_pointer index_args, s7_int *start, s7_int *end)
{
  /* we assume that *start=0 and *end=length, that end is "exclusive", return sc->unused if method called but wants to indicate that it gives up -- is this useful?? */
  const s7_pointer pstart = car(index_args);
  s7_int index;

  if (!s7_is_integer(pstart))
    return(method_or_bust(sc, pstart, caller, args, sc->type_names[T_INTEGER], position));
  index = s7_integer_clamped_if_gmp(sc, pstart);
  if ((index < 0) ||
      (index > *end)) /* *end == length here */
    out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  *start = index;

  if (is_pair(cdr(index_args)))
    {
      const s7_pointer pend = cadr(index_args);
      if (!s7_is_integer(pend))
	return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1));
      index = s7_integer_clamped_if_gmp(sc, pend);
      if ((index < *start) ||
	  (index > *end))
	out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? It_Is_Too_Small_String : It_Is_Too_Large_String);
      *end = index;
    }
  return(sc->unused);
}

static s7_pointer g_substring(s7_scheme *sc, s7_pointer args)
{
  #define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \
end: (substring \"01234\" 1 2) -> \"1\""
  #define Q_substring s7_make_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol)

  const s7_pointer str = car(args);
  s7_int start = 0, end, len;
  char *s;

  if (!is_string(str))
    return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1));
  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      s7_pointer p = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end);
      if (p != sc->unused) return(p);
    }
  s = string_value(str);
  len = end - start;
  if (len == 0) return(nil_string);
  {
    s7_pointer result = inline_make_string_with_length(sc, (char *)(s + start), len);
    string_value(result)[len] = 0;
    return(result);
  }
}

static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args)
{
  #define H_substring_uncopied "(substring-uncopied str start (end (length str))) returns an immutable string sharing the portion of the string str between start and \
end: (substring-uncopied \"01234\" 1 2) -> \"1\".  substring-uncopied does not GC protect the original string; it is intended for very brief uses."
  #define Q_substring_uncopied s7_make_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol)

  const s7_pointer str = car(args);
  s7_int start = 0, end, len;

  if (!is_string(str))
    return(method_or_bust(sc, str, sc->substring_uncopied_symbol, args, sc->type_names[T_STRING], 1));
  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      s7_pointer p = start_and_end(sc, sc->substring_uncopied_symbol, args, 2, cdr(args), &start, &end);
      if (p != sc->unused) return(p); /* perhaps start_and_end triggered a method call */
    }
  len = end - start;
  if (len == 0) return(nil_string);
  return(wrap_string(sc, string_value(str) + start, len));
}

static s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end)
{
  /* is_string(arg1) already checked in opt */
  if ((end < start) || (end > string_length(str)))
    out_of_range_error_nr(sc, sc->substring_uncopied_symbol, Int_Three, wrap_integer(sc, end), (end < start) ? It_Is_Too_Small_String : It_Is_Too_Large_String);
  if (start < 0)
    out_of_range_error_nr(sc, sc->substring_uncopied_symbol, Int_Two, wrap_integer(sc, start), It_Is_Negative_String);
  return(wrap_string(sc, string_value(str) + start, end - start));
}

static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args);

static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr)
{
  int32_t substrs = 0;
  /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */
  for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p))
    {
      const s7_pointer arg = car(p);
      if ((is_pair(arg)) &&
	  (is_symbol(car(arg))) &&
	  (is_safely_optimized(arg)) &&
	  (has_fn(arg)))
	{
	  if ((fn_proc(arg) == g_substring) &&
	      ((!is_pair(cadr(arg))) || (caadr(arg) != sc->substring_uncopied_symbol)))
	    /* string_value of an unncopied substring is the original -- need string_length: (file-exists? (substring (substring-uncopied "abcdefg" 0 2))) */
	    /*   maybe just remove the file-exists? chooser */
	    {
	      if (substrs < Num_String_Wrappers)
		set_class_and_fn_proc(arg, sc->substring_uncopied);
	      /* this makes the returned string immutable, but I think that is not problematic given where we make this substitution */
	      substrs++;
	    }
	  else
	    if (fn_proc(arg) == g_symbol_to_string)
	      set_class_and_fn_proc(arg, sc->symbol_to_string_uncopied);
	    else
	      if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg))))
		set_class_and_fn_proc(arg, sc->get_output_string_uncopied);
	}}
}

static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  /* used by several string functions */
  check_for_substring_temp(sc, expr);
  return(func);
}


/* -------------------------------- string-copy -------------------------------- */
static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args)
{
  #define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument.  If dest-str is given, \
    string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str"
  #define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol)

  const s7_pointer source = car(args);
  s7_pointer p, dest;
  s7_int start, end;

  if (!is_string(source))
    return(method_or_bust(sc, source, sc->string_copy_symbol, args, sc->type_names[T_STRING], 1));
  if (is_null(cdr(args)))
    {
      if (string_length(source) == 0) return(nil_string);
      return(make_string_with_length(sc, string_value(source), string_length(source)));
    }
  dest = cadr(args);
  if (!is_string(dest))
    return(method_or_bust(sc, dest, sc->string_copy_symbol, args, sc->type_names[T_STRING], 2));
  if (is_immutable_string(dest))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't string-copy to ~S; it is immutable", 40), dest));

  end = string_length(dest);
  p = cddr(args);
  if (is_null(p))
    start = 0;
  else
    {
      if (!s7_is_integer(car(p)))
	return(method_or_bust(sc, car(p), sc->string_copy_symbol, args, sc->type_names[T_STRING], 3));
      start = s7_integer_clamped_if_gmp(sc, car(p));
      if (start < 0) start = 0;
      p = cdr(p);
      if (is_null(p))
	end = start + string_length(source);
      else
	{
	  if (!s7_is_integer(car(p)))
	    return(method_or_bust(sc, car(p), sc->string_copy_symbol, args, sc->type_names[T_STRING], 4));
	  end = s7_integer_clamped_if_gmp(sc, car(p));
	  if (end < 0) end = start;
	}}
  if (end > string_length(dest)) end = string_length(dest);
  if (end <= start) return(dest);
  if ((end - start) > string_length(source)) end = start + string_length(source);
  memmove((void *)(string_value(dest) + start), (void *)(string_value(source)), end - start);
  /* although I haven't tracked down a case, libasan+auto-tester reported source<dest with overlap, so use memmove */
  return(dest);
}

static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 1) check_for_substring_temp(sc, expr);
  return(func);
}


/* -------------------------------- string comparisons -------------------------------- */
static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2)
{
  /* tricky here because str[i] must be treated as unsigned: (string<? (string (integer->char #xf0)) (string (integer->char #x70)))
   *   and null or lack thereof does not say anything about the string end
   */
  const size_t len1 = (size_t)string_length(s1);
  const size_t len2 = (size_t)string_length(s2);
  const size_t len = (len1 > len2) ? len2 : len1;
  const char *str1 = string_value(s1);
  const char *str2 = string_value(s2);

  if (len < sizeof(size_t))
    for (size_t i = 0; i < len; i++)
      {
	if ((uint8_t)(str1[i]) < (uint8_t )(str2[i]))
	  return(-1);
	if ((uint8_t)(str1[i]) > (uint8_t)(str2[i]))
	  return(1);
      }
  else
    {
      /* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */
      size_t i = 0, last = len / sizeof(size_t);
      for (const size_t *ptr1 = (size_t *)str1, *ptr2 = (size_t *)str2; i < last; i++)
	if (ptr1[i] != ptr2[i])
	  break;
      for (size_t pos = i * sizeof(size_t); pos < len; pos++)
	{
	  if ((uint8_t)str1[pos] < (uint8_t)str2[pos]) return(-1);
	  if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) return(1);
	}}
  if (len1 < len2)
    return(-1);
  return((len1 > len2) ? 1 : 0);
}

static bool is_string_via_method(s7_scheme *sc, s7_pointer obj)
{
  if (s7_is_string(obj))
    return(true);
  if (has_active_methods(sc, obj))
    {
      s7_pointer func = find_method_with_let(sc, obj, sc->is_string_symbol);
      if (func != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, obj))));
    }
  return(false);
}

static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1));
  for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs))
    {
      if (!is_string(car(strs)))
	return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args)));
      if (scheme_strcmp(str, car(strs)) != val)
	{
	  for (s7_pointer strp = cdr(strs); is_pair(strp); strp = cdr(strp))
	    if (!is_string_via_method(sc, car(strp)))
	      wrong_type_error_nr(sc, sym, position_of(strp, args), car(strp), sc->type_names[T_STRING]);
	  return(sc->F);
	}}
  return(sc->T);
}

static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1));
  for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs))
    {
      if (!is_string(car(strs)))
	return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args)));
      if (scheme_strcmp(str, car(strs)) == val)
	{
	  for (s7_pointer strp = cdr(strs); is_pair(strp); strp = cdr(strp))
	    if (!is_string_via_method(sc, car(strp)))
	      wrong_type_error_nr(sc, sym, position_of(strp, args), car(strp), sc->type_names[T_STRING]);
	  return(sc->F);
	}}
  return(sc->T);
}

static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y)
{
  return((string_length(x) == string_length(y)) &&
	 (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x)))); /* unaligned */
}

static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal"
  #define Q_strings_are_equal sc->pcl_bs

  /* C-based check stops at null, but we can have embedded nulls.
   *   (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2))
   */
  s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
  for (s7_pointer arglist = cdr(args); is_pair(arglist); arglist = cdr(arglist))
    {
      s7_pointer p = car(arglist);
      if (!is_string(p))
	return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, str, arglist), sc->type_names[T_STRING], position_of(arglist, args)));
      if (!scheme_strings_are_equal(p, str))
	{
	  for (s7_pointer strp = cdr(arglist); is_pair(strp); strp = cdr(strp))
	    if (!is_string_via_method(sc, car(strp)))
	      wrong_type_error_nr(sc, sc->string_eq_symbol, position_of(strp, args), car(strp), sc->type_names[T_STRING]);
	  return(sc->F);
	}}
  return(sc->T);
}

static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_less "(string<? str ...) returns #t if all the string arguments are increasing"
  #define Q_strings_are_less sc->pcl_bs
  return(g_string_cmp(sc, args, -1, sc->string_lt_symbol));
}

static s7_pointer g_strings_are_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing"
  #define Q_strings_are_greater sc->pcl_bs
  return(g_string_cmp(sc, args, 1, sc->string_gt_symbol));
}

static s7_pointer g_strings_are_geq(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing"
  #define Q_strings_are_geq sc->pcl_bs
  return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol));
}

static s7_pointer g_strings_are_leq(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing"
  #define Q_strings_are_leq sc->pcl_bs
  return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol));
}

static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_string(cadr(args)))
    return(method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}

static s7_pointer g_string_equal_2c(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
  return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}

static s7_pointer string_eq_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  if (!is_string(str1))
    return(method_or_bust(sc, str1, sc->string_eq_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1));
  if (!is_string(str2))
    return(method_or_bust(sc, str2, sc->string_eq_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strings_are_equal(str1, str2)));
}

static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    return(method_or_bust(sc, car(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_string(cadr(args)))
    return(method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
}

static s7_pointer string_lt_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  if (!is_string(str1))
    return(method_or_bust(sc, str1, sc->string_lt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1));
  if (!is_string(str2))
    return(method_or_bust(sc, str2, sc->string_lt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strcmp(str1, str2) == -1));
}

static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    return(method_or_bust(sc, car(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_string(cadr(args)))
    return(method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
}

static s7_pointer string_gt_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  if (!is_string(str1))
    return(method_or_bust(sc, str1, sc->string_gt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1));
  if (!is_string(str2))
    return(method_or_bust(sc, str2, sc->string_gt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2));
  return(make_boolean(sc, scheme_strcmp(str1, str2) == 1));
}

#define check_string2_args(Sc, Caller, Str1, Str2) \
  do { \
      if (!is_string(Str1)) return(method_or_bust(sc, Str1, Caller, set_plist_2(Sc, Str1, Str2), Sc->type_names[T_STRING], 1) != Sc->F); \
      if (!is_string(Str2)) return(method_or_bust(sc, Str2, Caller, set_plist_2(Sc, Str1, Str2), Sc->type_names[T_STRING], 2) != Sc->F); \
     } while (0)

static bool string_lt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) == -1);}
static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_lt_symbol, str1, str2);
  return(scheme_strcmp(str1, str2) == -1);
}

static bool string_leq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) != 1);}
static bool string_leq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_leq_symbol, str1, str2);
  return(scheme_strcmp(str1, str2) != 1);
}

static bool string_gt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) == 1);}
static bool string_gt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_gt_symbol, str1, str2);
  return(scheme_strcmp(str1, str2) == 1);
}

static bool string_geq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) != -1);}
static bool string_geq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_geq_symbol, str1, str2);
  return(scheme_strcmp(str1, str2) != -1);
}

static bool string_eq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strings_are_equal(str1, str2));}
static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_eq_symbol, str1, str2);
  return(scheme_strings_are_equal(str1, str2));
}

static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : func);
}

static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return((args == 2) ? sc->string_less_2 : func);
}

static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return((args == 2) ? sc->string_greater_2 : func);
}


#if !With_Pure_s7
static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2)
{
  /* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end).
   */
  const s7_int len1 = string_length(s1);
  const s7_int len2 = string_length(s2);
  const s7_int len = (len1 > len2) ? len2 : len1;
  const uint8_t *str1 = (const uint8_t *)string_value(s1);
  const uint8_t *str2 = (const uint8_t *)string_value(s2);

  for (s7_int i = 0; i < len; i++)
    {
      if (uppers[(int32_t)str1[i]] < uppers[(int32_t)str2[i]]) return(-1);
      if (uppers[(int32_t)str1[i]] > uppers[(int32_t)str2[i]]) return(1);
    }
  if (len1 < len2)
    return(-1);
  return((len1 > len2) ? 1 : 0);
}

static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2)
{
  /* same as scheme_strcmp -- watch out for unwanted sign! */
  const s7_int len = string_length(s1);
  const s7_int len2 = string_length(s2);
  const uint8_t *str1, *str2;

  if (len != len2) return(false);
  str1 = (const uint8_t *)string_value(s1);
  str2 = (const uint8_t *)string_value(s2);
  for (s7_int i = 0; i < len; i++)
    if (uppers[(int32_t)str1[i]] != uppers[(int32_t)str2[i]])
      return(false);
  return(true);
}

static s7_pointer check_rest_are_strings(s7_scheme *sc, s7_pointer sym, s7_pointer x, s7_pointer args)
{
  for (s7_pointer strs = x; is_pair(strs); strs = cdr(strs))
    if (!is_string_via_method(sc, car(strs)))
      wrong_type_error_nr(sc, sym, position_of(strs, args), car(strs), sc->type_names[T_STRING]);
  return(sc->F);
}

static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1));

  for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs))
    {
      if (!is_string(car(strs)))
	return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args)));
      if (val == 0)
	{
	  if (!scheme_strequal_ci(str, car(strs)))
	    return(check_rest_are_strings(sc, sym, cdr(strs), args));
	}
      else
	if (scheme_strcasecmp(str, car(strs)) != val)
	  return(check_rest_are_strings(sc, sym, cdr(strs), args));
    }
  return(sc->T);
}

static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
{
  s7_pointer str = car(args);

  if (!is_string(str))
    return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1));
  for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs))
    {
      if (!is_string(car(strs)))
	return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args)));
      if (scheme_strcasecmp(str, car(strs)) == val)
	return(check_rest_are_strings(sc, sym, cdr(strs), args));
    }
  return(sc->T);
}

static s7_pointer g_strings_are_ci_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case"
  #define Q_strings_are_ci_equal sc->pcl_bs
  return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol));
}

static s7_pointer g_strings_are_ci_less(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_ci_less "(string-ci<? str ...) returns #t if all the string arguments are increasing, ignoring case"
  #define Q_strings_are_ci_less sc->pcl_bs
  return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol));
}

static s7_pointer g_strings_are_ci_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case"
  #define Q_strings_are_ci_greater sc->pcl_bs
  return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol));
}

static s7_pointer g_strings_are_ci_geq(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case"
  #define Q_strings_are_ci_geq sc->pcl_bs
  return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol));
}

static s7_pointer g_strings_are_ci_leq(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case"
  #define Q_strings_are_ci_leq sc->pcl_bs
  return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol));
}

static bool string_ci_lt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == -1);}
static bool string_ci_lt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_ci_lt_symbol, str1, str2);
  return(scheme_strcasecmp(str1, str2) == -1);
}

static bool string_ci_leq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) != 1);}
static bool string_ci_leq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_ci_leq_symbol, str1, str2);
  return(scheme_strcasecmp(str1, str2) != 1);
}

static bool string_ci_gt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == 1);}
static bool string_ci_gt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_ci_gt_symbol, str1, str2);
  return(scheme_strcasecmp(str1, str2) == 1);
}

static bool string_ci_geq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) != -1);}
static bool string_ci_geq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_ci_geq_symbol, str1, str2);
  return(scheme_strcasecmp(str1, str2) != -1);
}

static bool string_ci_eq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == 0);}
static bool string_ci_eq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2)
{
  check_string2_args(sc, sc->string_ci_eq_symbol, str1, str2);
  return(scheme_strcasecmp(str1, str2) == 0);
}
#endif /* pure s7 */


/* -------------------------------- string-fill! -------------------------------- */

static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
{
  const s7_pointer str = car(args);
  s7_pointer c;
  s7_int start = 0, end;

  if (!is_string(str))
    return(method_or_bust(sc, str, caller, args, sc->type_names[T_STRING], 1)); /* not two methods here */
  if (is_immutable_string(str))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, caller, str));

  c = cadr(args);
  if (!is_character(c))
    return(method_or_bust(sc, c, caller, args, sc->type_names[T_CHARACTER], 2));

  end = string_length(str);
  if (!is_null(cddr(args)))
    {
      s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
      if (p != sc->unused) return(p);
      if (start == end) return(c); /* this is what Guile does, and r7rs says end is "exclusive" in these situations, so (string-fill! str #\a 3 3) is a no-op */
    }
  if (end == 0) return(c);
  local_memset((void *)(string_value(str) + start), (int32_t)character(c), end - start); /* not memclr even if c=#\null! */ /* unaligned */
  return(c);
}

#if !With_Pure_s7
static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr"
  #define Q_string_fill s7_make_signature(sc, 5, \
                          s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), \
                          sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
  return(g_string_fill_1(sc, sc->string_fill_symbol, args));
}
#endif


/* -------------------------------- string -------------------------------- */
const char *s7_string(s7_pointer str) {return(string_value(str));}

static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
  int32_t len;
  s7_pointer chrs, newstr;
  char *str;

  /* get length for new string and check arg types */
  for (len = 0, chrs = args; is_pair(chrs); len++, chrs = cdr(chrs))
    {
      const s7_pointer c = car(chrs);
      if (!is_character(c))
	{
	  if (has_active_methods(sc, c))
	    {
	      const s7_pointer func = find_method_with_let(sc, c, sym);
	      if (func != sc->undefined)
		{
		  if (len == 0)
		    return(s7_apply_function(sc, func, args));
		  newstr = make_empty_string(sc, len, '\0');
		  str = string_value(newstr);
		  {
		    s7_pointer ok_chrs = args;
		    for (int32_t i = 0; ok_chrs != chrs; i++, ok_chrs = cdr(ok_chrs))
		      str[i] = character(car(ok_chrs));
		  }
		  return(string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, chrs)), sym));
		}}
	  wrong_type_error_nr(sc, sym, len + 1, c, sc->type_names[T_CHARACTER]);
	}}
  if (len > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_4(sc, wrap_string(sc, "~S result string is too large (> ~D ~D) (*s7* 'max-string-length)", 65),
			 sym, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
  newstr = inline_make_empty_string(sc, len, '\0');
  str = string_value(newstr);
  chrs = args;
  for (int32_t i = 0; is_pair(chrs); i++, chrs = cdr(chrs))
    str[i] = character(car(chrs));
  return(newstr);
}

static s7_pointer g_string(s7_scheme *sc, s7_pointer args)
{
  #define H_string "(string chr...) appends all its character arguments into one string"
  #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol)
  return((is_null(args)) ? nil_string : g_string_1(sc, args, sc->string_symbol));
}

static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer c = car(args), str;
  /* no multiple values here because no pairs below */
  if (!is_character(c))
    return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1));
  str = inline_make_empty_string(sc, 1, '\0'); /* can't put character(c) here because null is handled specially */
  string_value(str)[0] = character(c);
  return(str);
}

static s7_pointer string_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : func);
}

static s7_pointer string_p_p(s7_scheme *sc, s7_pointer c)
{
  s7_pointer str;
  if (!is_character(c)) return(g_string_1(sc, set_plist_1(sc, c), sc->string_symbol));
  str = inline_make_empty_string(sc, 1, '\0');
  string_value(str)[0] = character(c);
  return(str);
}


/* -------------------------------- list->string -------------------------------- */
#if !With_Pure_s7
static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)"
  #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol)

  const s7_pointer lst = car(args);
  if (is_null(lst))
    return(nil_string);
  if (!s7_is_proper_list(sc, lst))
    return(method_or_bust_p(sc, lst, sc->list_to_string_symbol, wrap_string(sc, "a (proper, non-circular) list of characters", 43)));
  return(g_string_1(sc, lst, sc->list_to_string_symbol));
}
#endif


/* -------------------------------- string->list -------------------------------- */
static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len)
{
  if (len == 0)
    return(sc->nil);
  check_free_heap_size(sc, len);
  begin_temp(sc->y, sc->nil);
  for (s7_int i = len - 1; i >= 0; i--)
    sc->y = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->y);
  return_with_end_temp(sc->y);
}

#if !With_Pure_s7
static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)"
  #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol)

  s7_int start = 0, end;
  const s7_pointer str = car(args);

  if (!is_string(str))
    return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, args, sc->type_names[T_STRING]));
  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      const s7_pointer p = start_and_end(sc, sc->string_to_list_symbol, args, 2, cdr(args), &start, &end);
      if (p != sc->unused) return(p);
      if (start == end) return(sc->nil);
    }
  else
    if (end == 0) return(sc->nil);
  if ((end - start) > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_5(sc, wrap_string(sc, "string->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78),
			 wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start),
			 wrap_integer(sc, sc->max_list_length)));
  check_free_heap_size(sc, end - start);
  begin_temp(sc->y, sc->nil);
  for (s7_int i = end - 1; i >= start; i--)
    sc->y = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->y);
  return_with_end_temp(sc->y);
}

static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str)
{
  s7_int len;
  const uint8_t *val;
  if (!is_string(str))
    return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), sc->type_names[T_STRING]));
  len = string_length(str);
  if (len == 0) return(sc->nil);
  if (len > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "string->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length)));
  check_free_heap_size(sc, len);
  val = (const uint8_t *)string_value(str);
  {
    s7_pointer result = sc->nil;
    for (s7_int i = len - 1; i >= 0; i--) result = cons_unchecked(sc, chars[val[i]], result);
    return(result);
  }
}
#endif


/* -------------------------------- port-closed? -------------------------------- */
static s7_pointer g_is_port_closed(s7_scheme *sc, s7_pointer args)
{
  #define H_is_port_closed "(port-closed? p) returns #t if the port p is closed."
  #define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, \
                              s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol))
  const s7_pointer port = car(args);
  if (is_any_port(port))
    return(make_boolean(sc, port_is_closed(port)));
  if ((port == current_output_port(sc)) && (port == sc->F))
    return(sc->F);
  return(method_or_bust_p(sc, port, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)));
}

static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer port)
{
  if (is_any_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_any_port(port))
    return(method_or_bust_p(sc, port, sc->port_string_symbol, wrap_string(sc, "a port", 6)));
  if (!is_string_port(port))
    sole_arg_wrong_type_error_nr(sc, sc->port_string_symbol, 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;

  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 */
  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));
  {
    const s7_int 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); /* this does not preserve anything */
  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_any_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_int position;
  s7_pointer pos;

  if (!is_input_port(port))
    wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, An_Input_Port_String);
  if (port_is_closed(port))
    wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, An_Open_Input_Port_String);

  pos = cadr(args);
  if (!is_t_integer(pos))
    wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 2, pos, sc->type_names[T_INTEGER]);
  position = s7_integer_clamped_if_gmp(sc, pos);
  if (position < 0)
    out_of_range_error_nr(sc, sc->port_position_symbol, Int_Two, pos, It_Is_Negative_String);
  if (is_string_port(port))
    port_position(port) = (position > port_data_size(port)) ? port_data_size(port) : position;
#if !MS_Windows
  else
    if (is_file_port(port))
      {
	rewind(port_file(port));
	fseek(port_file(port), (long)position, SEEK_SET);
      }
#endif
  return(pos);
}


/* -------------------------------- port-file -------------------------------- */
static s7_pointer g_port_file(s7_scheme *sc, s7_pointer args)
{
  #define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object"
  #define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))

  const s7_pointer port = car(args);
  if (!is_any_port(port))
    return(method_or_bust_p(sc, port, sc->port_file_symbol, wrap_string(sc, "a port", 6)));
  if (port_is_closed(port))
    sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "an open port", 12));
#if !MS_Windows
  if (is_file_port(port))
    return(s7_make_c_pointer_with_type(sc, (void *)(port_file(port)), sc->file__symbol, sc->F));
#endif
  return(s7_make_c_pointer(sc, NULL));
}


/* -------------------------------- port-line-number -------------------------------- */
static s7_pointer port_line_number_p_p(s7_scheme *sc, s7_pointer x)
{
  if (!is_input_port(x)) /* used to check port_is_closed? */
    return(method_or_bust_p(sc, x, sc->port_line_number_symbol, An_Input_Port_String));
  return(make_integer(sc, port_line_number(x)));
}

static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args)
{
  #define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port"
  #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol)
  return(port_line_number_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
}

s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p)
{
  if (!is_input_port(p))
    sole_arg_wrong_type_error_nr(sc, sc->port_line_number_symbol, p, sc->type_names[T_INPUT_PORT]);
  return(port_line_number(p));
}

static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port, line;
  if ((is_null(car(args))) ||
      ((is_null(cdr(args))) && (is_t_integer(car(args)))))
    port = current_input_port(sc);
  else
    {
      port = car(args);
      if (!is_input_port(port))
	wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, port, An_Input_Port_String);
    }
  line = (is_null(cdr(args)) ? car(args) : cadr(args));
  if (!is_t_integer(line))
    wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 2, line, sc->type_names[T_INTEGER]);
  port_line_number(port) = integer(line);
  return(line);
}


/* -------------------------------- port-filename -------------------------------- */
const char *s7_port_filename(s7_scheme *sc, s7_pointer port)
{
  if ((is_any_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_any_port(port)) && (!port_is_closed(port)))
    {
      if (port_filename(port))
	{
	  if (port_filename_length(port) > sc->max_string_length)
	    error_nr(sc, sc->out_of_range_symbol,
		     set_elist_3(sc, wrap_string(sc, "port-filename is too long (> ~D ~D) (*s7* 'max-string-length)", 61),
				 wrap_integer(sc, port_filename_length(port)), wrap_integer(sc, sc->max_string_length)));
	  return(make_string_with_length(sc, port_filename(port), port_filename_length(port))); /* not wrapper here! */
	}
      return(nil_string);
      /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
    }
  return(method_or_bust_p(sc, port, sc->port_filename_symbol, wrap_string(sc, "an open port", 12)));
}

static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args)
{
  #define H_port_filename "(port-filename file-port) returns the filename associated with port"
  #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
  return(port_filename_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
}


/* -------------------------------- pair-line-number -------------------------------- */
static s7_pointer pair_line_number_p_p(s7_scheme *sc, s7_pointer p)
{
  if (!is_pair(p))
    return(method_or_bust_p(sc, p, sc->pair_line_number_symbol, sc->type_names[T_PAIR]));
  return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F);
}

static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args)
{
  #define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available"
  #define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol)
  return(pair_line_number_p_p(sc, car(args)));
}


/* -------------------------------- pair-filename -------------------------------- */
static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args)
{
  #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'"
  #define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol)

  const s7_pointer p = car(args);
  if (is_pair(p))
    return((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */
  if_method_exists_return_value(sc, p, sc->pair_filename_symbol, args);
  sole_arg_wrong_type_error_nr(sc, sc->pair_filename_symbol, p, sc->type_names[T_PAIR]);
  return(NULL);
}


/* -------------------------------- input-port? -------------------------------- */
bool s7_is_input_port(s7_scheme *sc, s7_pointer p) {return(is_input_port(p));}
static bool is_input_port_b(s7_pointer p)          {return(is_input_port(p));}

static s7_pointer g_is_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_is_input_port "(input-port? p) returns #t if p is an input port"
  #define Q_is_input_port sc->pl_bt
  check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, args);
}


/* -------------------------------- output-port? -------------------------------- */
bool s7_is_output_port(s7_scheme *sc, s7_pointer p) {return(is_output_port(p));}
static bool is_output_port_b(s7_pointer p)          {return(is_output_port(p));}

static s7_pointer g_is_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_is_output_port "(output-port? p) returns #t if p is an output port"
  #define Q_is_output_port sc->pl_bt
  check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, args);
}


/* -------------------------------- current-input-port -------------------------------- */
s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));}

static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_current_input_port "(current-input-port) returns the current input port"
  #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol)
  return(current_input_port(sc));
}

static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port"
  #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol)

  const s7_pointer port = car(args), old_port = current_input_port(sc);
  if ((is_input_port(port)) &&
      (!port_is_closed(port)))
    set_current_input_port(sc, port);
  else
    {
      if_method_exists_return_value(sc, port, sc->set_current_input_port_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->set_current_input_port_symbol, port, An_Open_Input_Port_String);
    }
  return(old_port);
}

s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port = current_input_port(sc);
  set_current_input_port(sc, port);
  return(old_port);
}


/* -------------------------------- current-output-port -------------------------------- */
s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));}

s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port = current_output_port(sc);
  set_current_output_port(sc, port);
  return(old_port);
}

static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_current_output_port "(current-output-port) returns the current output port"
  #define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  return(current_output_port(sc));
}

static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
  #define Q_set_current_output_port s7_make_signature(sc, 2, \
                                      s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \
                                      s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  const s7_pointer port = car(args);
  const s7_pointer old_port = current_output_port(sc);
  if (((is_output_port(port)) &&
       (!port_is_closed(port))) || (port == sc->F))
    set_current_output_port(sc, port);
  else
    {
      if_method_exists_return_value(sc, port, sc->set_current_output_port_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->set_current_output_port_symbol, port, An_Output_Port_Or_F_String);
    }
  return(old_port);
}


/* -------------------------------- current-error-port -------------------------------- */
s7_pointer s7_current_error_port(s7_scheme *sc) {return(current_error_port(sc));}

s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port = current_error_port(sc);
  set_current_error_port(sc, port);
  return(old_port);
}

static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_current_error_port "(current-error-port) returns the current error port"
  #define Q_current_error_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  return(current_error_port(sc));
}

static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port"
  #define Q_set_current_error_port s7_make_signature(sc, 2, \
                                     s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \
                                     s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  const s7_pointer port = car(args);
  const s7_pointer old_port = current_error_port(sc);
  if (((is_output_port(port)) &&
       (!port_is_closed(port))) ||
      (port == sc->F))
    set_current_error_port(sc, port);
  else
    {
      if_method_exists_return_value(sc, port, sc->set_current_error_port_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->set_current_error_port_symbol, port, An_Output_Port_Or_F_String);
    }
  return(old_port);
}


/* -------------------------------- char-ready? -------------------------------- */
#if !With_Pure_s7
static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port"
  #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol)
  s7_pointer port;

  if (is_null(args))
    return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc)))));
  port = car(args);
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->is_char_ready_symbol, An_Input_Port_String));
  if (port_is_closed(port))
    sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, port, An_Open_Input_Port_String);
  if (!is_function_port(port))
    return(make_boolean(sc, is_string_port(port)));
  {
    const s7_pointer result = (*(port_input_function(port)))(sc, S7_IS_CHAR_READY, port);
    if (is_multiple_value(result))
      {
	clear_multiple_value(result);
	error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), result));
      }
    return(make_boolean(sc, (result != sc->F))); /* char-ready? returns a boolean */
  }
}
#endif

/* -------- ports -------- */
static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port);
static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol);
static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port);
static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port);
static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port);

static void close_closed_port(s7_scheme *unused_sc, s7_pointer unused_port) {return;}

static port_functions_t closed_port_functions =
  {closed_port_read_char, closed_port_write_char, closed_port_write_string, NULL, NULL, NULL, NULL,
   closed_port_read_line, closed_port_display, close_closed_port};


static void close_input_file(s7_scheme *sc, s7_pointer port)
{
  if (port_filename(port)) /* for string ports, this is the original input file name */
    {
      liberate(sc, port_filename_block(port));
      port_filename(port) = NULL;
    }
  if (port_file(port))
    {
      fclose(port_file(port));
      port_file(port) = NULL;
    }
  if (port_needs_free(port))
    free_port_data(sc, port);
  port_port(port)->pf = &closed_port_functions;
  port_set_closed(port, true);
  port_position(port) = 0;
}

static void close_input_string(s7_scheme *sc, s7_pointer port)
{
  if (port_filename(port)) /* for string ports, this is the original input file name */
    {
      liberate(sc, port_filename_block(port));
      port_filename(port) = NULL;
    }
  if (port_needs_free(port))
    free_port_data(sc, port);
  port_port(port)->pf = &closed_port_functions;
  port_set_closed(port, true);
  port_position(port) = 0;
}

static void close_simple_input_string(s7_scheme *unused_sc, s7_pointer port)
{
#if s7_Debugging
  if (port_filename(port)) fprintf(stderr, "%s: port has a filename\n", __func__);
  if (port_needs_free(port)) fprintf(stderr, "%s: port needs free\n", __func__);
#endif
  port_port(port)->pf = &closed_port_functions;
  port_set_closed(port, true);
  port_position(port) = 0;
}

void s7_close_input_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);}


/* -------------------------------- close-input-port -------------------------------- */
static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_close_input_port "(close-input-port port) closes the port"
  #define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol)

  const s7_pointer port = car(args);
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->close_input_port_symbol, An_Input_Port_String));
  if ((!is_immutable_port(port)) &&  /* (close-input-port *stdin*) */
      (!is_loader_port(port)))       /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */
    s7_close_input_port(sc, port);
  return(sc->unspecified);
}


/* -------------------------------- flush-output-port -------------------------------- */
static no_return void file_error_nr(s7_scheme *sc, const char *caller, const char *descr, const char *name)
{
  error_nr(sc, sc->io_error_symbol,
	   set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9),
		       s7_make_string_wrapper(sc, caller),
		       s7_make_string_wrapper(sc, descr),
		       s7_make_string_wrapper(sc, name)));
}

bool s7_flush_output_port(s7_scheme *sc, s7_pointer port)
{
  bool result = true;
  if ((is_output_port(port)) && /* type=T_OUTPUT_PORT, so this excludes #f */
      (is_file_port(port)) &&
      (!port_is_closed(port)) &&
      (port_file(port)))
    {
      if (port_position(port) > 0)
	{
	  result = (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) == (size_t)port_position(port));
	  port_position(port) = 0;
	}
      if (fflush(port_file(port)) == -1)
	file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(port));
    }
  return(result);
}

static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)"
  #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))

  const s7_pointer port = (is_null(args)) ? current_output_port(sc) : car(args);
  if (!is_output_port(port))
    {
      if (port == sc->F) return(port);
      if_method_exists_return_value(sc, port, sc->flush_output_port_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, port, An_Output_Port_Or_F_String);
    }
  if (!s7_flush_output_port(sc, port))
    error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), port));
  return(port);
}


/* -------------------------------- close-output-port -------------------------------- */
static void close_output_file(s7_scheme *sc, s7_pointer port)
{
  if (port_filename(port)) /* only a file output port has a filename(?) */
    {
      /* type(port) might be T_FREE -- this is called in sweep if port is free_and_clear */
      if ((s7_Debugging) && (!is_free(port)) && ((!is_output_port(port)) || (!is_file_port(port))))
	fprintf(stderr, "%s[%d]: unexpected port\n", __func__, __LINE__);
      liberate(sc, port_filename_block(port));
      port_filename(port) = NULL;
      port_filename_length(port) = 0;
    }
  if (port_file(port))
    {
#if With_Warnings
      if ((port_position(port) > 0) &&
	  (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)))
	s7_warn(sc, 64, "fwrite trouble in close-output-port\n");
#else
      if (port_position(port) > 0)
	fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port));
#endif
      if (fflush(port_file(port)) == -1)
	s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno));
      fclose(port_file(port));
      port_file(port) = NULL;
    }
  port_port(port)->pf = &closed_port_functions;
  port_set_closed(port, true);
  port_position(port) = 0;
}

static void close_output_string(s7_scheme *unused_sc, s7_pointer port)
{
  if (port_data(port))
    {
      port_data(port) = NULL;
      port_data_size(port) = 0;
    }
  port_port(port)->pf = &closed_port_functions;
  port_set_closed(port, true);
  port_position(port) = 0;
}

static void close_output_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);}

void s7_close_output_port(s7_scheme *sc, s7_pointer port)
{
  if ((port == sc->F) || (is_immutable_port(port))) return; /* can these happen? */
  close_output_port(sc, port);
}

static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_close_output_port "(close-output-port port) closes the port"
  #define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))

  const s7_pointer port = car(args);
  if (!is_output_port(port))
    {
      if (port == sc->F) return(sc->unspecified);
      if_method_exists_return_value(sc, port, sc->close_output_port_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, port, An_Output_Port_Or_F_String);
    }
  s7_close_output_port(sc, port);
  return(sc->unspecified);
}


/* -------- read character functions -------- */

static int32_t file_read_char(s7_scheme *unused_sc, s7_pointer port)
{
  int32_t c = fgetc(port_file(port));
  if ((c == (int32_t)'\n') && (!is_loader_port(port))) port_line_number(port)++;
  return(c);
}

static int32_t function_read_char(s7_scheme *sc, s7_pointer port)
{
  const s7_pointer result = (*(port_input_function(port)))(sc, S7_READ_CHAR, port);
  if (is_eof(result)) return(EOF);
  if (!is_character(result))          /* port_input_function might return some non-character */
    {
      if (is_multiple_value(result))
	{
	  clear_multiple_value(result);
	  error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), result));
	}
      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), result));
    }
  return((int32_t)character(result));    /* kinda nutty -- we return chars[this] in g_read_char! */
}

static int32_t string_read_char(s7_scheme *unused_sc, s7_pointer port)
{
  uint8_t c;
  if (port_data_size(port) <= port_position(port)) return(EOF);
  c = (uint8_t)port_data(port)[port_position(port)++]; /* port_string_length is 0 if no port string, port_data is uint8_t* */
  if ((c == (uint8_t)'\n') && (!is_loader_port(port))) port_line_number(port)++;
  return(c);
}

static int32_t output_read_char(s7_scheme *sc, s7_pointer port) /* not reachable I think */
{
  sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, An_Input_Port_String);
  return(0);
}

static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, An_Open_Input_Port_String);
  return(0);
}


/* -------- read line functions -------- */

static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool unused_with_eol) /* not reachable I think */
{
  sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, An_Input_Port_String);
  return(NULL);
}

static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool unused_with_eol)
{
  sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, An_Open_Input_Port_String);
  return(NULL);
}

static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool unused_with_eol)
{
  const s7_pointer result = (*(port_input_function(port)))(sc, S7_READ_LINE, port);
  if (is_multiple_value(result))
    {
      clear_multiple_value(result);
      error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-line returned: ~S", 42), result));
    }
  return(result);
}

static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer unused_port, bool unused_with_eol)
{
  if (!sc->read_line_buf)
    {
      sc->read_line_buf_size = 1024;
      sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size);
    }
  if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin))
    return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */
  return(nil_string);
}

static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  /* read into read_line_buf concatenating reads until newline found.  string is read_line_buf to pos-of-newline.
   *   reset file position to reflect newline pos.
   */
  int32_t reads = 0;
  char *str;
  s7_int read_size;
  if (!sc->read_line_buf)
    {
      sc->read_line_buf_size = 1024;
      sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size);
    }
  read_size = sc->read_line_buf_size;
  str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */
  if (!str) return(eof_object);                               /* EOF or error with no char read */

  while (true)
    {
      s7_int cur_size;
      char *buf;
      const char *snew = strchr(sc->read_line_buf, (int)'\n'); /* or maybe just strlen + end-of-string=newline */
      if (snew)
	{
	  s7_int pos = (s7_int)(snew - sc->read_line_buf);
	  port_line_number(port)++;
	  return(inline_make_string_with_length(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos));
	}
      reads++;
      cur_size = strlen(sc->read_line_buf);
      if ((cur_size + reads) < read_size) /* end of data, no newline */
	return(make_string_with_length(sc, sc->read_line_buf, cur_size));

      /* need more data */
      sc->read_line_buf_size *= 2;
      sc->read_line_buf = (char *)Realloc(sc->read_line_buf, sc->read_line_buf_size);
      buf = (char *)(sc->read_line_buf + cur_size);
      str = fgets(buf, read_size, port_file(port));
      if (!str) return(eof_object);
      read_size = sc->read_line_buf_size;
    }
  return(eof_object);
}

static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  s7_int i;
  const char *port_str = (const char *)port_data(port);
  const s7_int port_start = port_position(port);
  const char *start = port_str + port_start;
  const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */
  if (cur)
    {
      s7_int len;
      port_line_number(port)++;
      i = cur - port_str;
      port_position(port) = i + 1;
      len = ((with_eol) ? i + 1 : i) - port_start;
      if (len == 0) return(nil_string);
      return(inline_make_string_with_length(sc, start, len));
    }
  i = port_data_size(port);
  port_position(port) = i;
  if (i <= port_start)         /* the < part can happen -- if not caught we try to create a string of length - 1 -> segfault */
    return(eof_object);
  return(make_string_with_length(sc, start, i - port_start));
}


/* -------- write character functions -------- */

static void resize_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size)
{
  const s7_int loc = port_data_size(port);
  block_t *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;
}

static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
{
  if (port_position(port) < port_data_size(port))
    port_data(port)[port_position(port)++] = c;
  else string_write_char_resized(sc, c, port);
}

static void stdout_write_char(s7_scheme *unused_sc, uint8_t c, s7_pointer unused_port) {fputc(c, stdout);}
static void stderr_write_char(s7_scheme *unused_sc, uint8_t c, s7_pointer unused_port) {fputc(c, stderr);}

static void function_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
{
  push_stack_direct(sc, OP_NO_VALUES);
  /* sc->args = sc->nil; */
  (*(port_output_function(port)))(sc, c, port);
  unstack_with(sc, OP_NO_VALUES);
  memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */
}

#ifndef OUTPUT_FILE_PORT_LENGTH
  #define OUTPUT_FILE_PORT_LENGTH 2048
#endif
#define Output_File_Port_Length OUTPUT_FILE_PORT_LENGTH

static Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
{
  if (port_position(port) == sc->output_file_port_length)
    {
      fwrite((void *)(port_data(port)), 1, sc->output_file_port_length, port_file(port));
      port_position(port) = 0;
    }
  port_data(port)[port_position(port)++] = c;
}

static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);}

static void input_write_char(s7_scheme *sc, uint8_t unused_c, s7_pointer port) /* not reachable I think */
{
  sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, An_Output_Port_String);
}

static void closed_port_write_char(s7_scheme *sc, uint8_t unused_c, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, An_Open_Output_Port_String);
}


/* -------- write string functions -------- */

static void input_write_string(s7_scheme *sc, const char *unused_str, s7_int unused_len, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, An_Output_Port_String);
}

static void closed_port_write_string(s7_scheme *sc, const char *unused_str, s7_int unused_len, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, An_Open_Output_Port_String);
}

static void input_display(s7_scheme *sc, const char *unused_str, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, An_Output_Port_String);
}

static void closed_port_display(s7_scheme *sc, const char *unused_str, s7_pointer port)
{
  sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, An_Open_Output_Port_String);
}

static void stdout_write_string(s7_scheme *unused_sc, const char *str, s7_int len, s7_pointer unused_port)
{
  if (str[len] == '\0')
    fputs(str, stdout);
  else
    for (s7_int i = 0; i < len; i++)
      fputc(str[i], stdout);
}

static void stderr_write_string(s7_scheme *unused_sc, const char *str, s7_int len, s7_pointer unused_port)
{
  if (str[len] == '\0')
    fputs(str, stderr);
  else
    for (s7_int i = 0; i < len; i++)
      fputc(str[i], stderr);
}

static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
{
  const s7_int new_len = port_position(port) + len;      /* len is known to be non-zero, str might not be 0-terminated */
  resize_port_data(sc, port, new_len * 2);
  memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len);
  port_position(port) = new_len;
}

static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
{
  if ((s7_Debugging) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();}
  if (port_position(port) + len < port_data_size(port))
    {
      memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len);
      /* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */
      port_position(port) += len;
    }
  else string_write_string_resized(sc, str, len, port);
}

static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
{
  const s7_int new_len = port_position(port) + len;
  if (new_len >= sc->output_file_port_length)
    {
      if (port_position(port) > 0)
	{
#if With_Warnings
	  if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port))
	    s7_warn(sc, 64, "fwrite trouble in write-string\n");
#else
	  fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port));
#endif
	  port_position(port) = 0;
	}
      fwrite((const void *)str, 1, len, port_file(port));
    }
  else
    {
      memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len);
      port_position(port) = new_len;
    }
}

static void string_display(s7_scheme *sc, const char *str, s7_pointer port)
{
  if (str) string_write_string(sc, str, safe_strlen(str), port);
}

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 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 *unused_sc, const char *str, s7_pointer unused_port) {if (str) fputs(str, stdout);}
static void stderr_display(s7_scheme *unused_sc, const char *str, s7_pointer unused_port) {if (str) fputs(str, stderr);}


/* -------------------------------- write-string -------------------------------- */
static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args)
{
  #define H_write_string "(write-string str port start end) writes str to port."
  #define Q_write_string s7_make_circular_signature(sc, 3, 4, \
                           sc->is_string_symbol, sc->is_string_symbol, \
                           s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol),\
                           sc->is_integer_symbol)
  const s7_pointer str = car(args);
  s7_pointer port;
  s7_int start = 0, end;
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->write_string_symbol, args, sc->type_names[T_STRING], 1));
  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      s7_pointer inds = cddr(args);
      port = cadr(args);
      if (!is_null(inds))
	{
	  s7_pointer p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end);
	  if (p != sc->unused) return(p);
	}}
  else port = current_output_port(sc);
  if (!is_output_port(port))
    {
      if (port == sc->F)
	{
	  s7_int len;
	  if ((start == 0) && (end == string_length(str)))
	    return(str);
	  len = (s7_int)(end - start);
	  return(make_string_with_length(sc, (char *)(string_value(str) + start), len));
	}
      if_method_exists_return_value(sc, port, sc->write_string_symbol, args);
      wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, An_Output_Port_Or_F_String);
    }
  if (port_is_closed(port)) wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, An_Open_Output_Port_String);
  if (start == end) return(str);
  port_write_string(port)(sc, (char *)(string_value(str) + start), (end - start), port);
  return(str);
}

static s7_pointer write_string_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer port)
{
  if (!is_string(str))
    return(method_or_bust_pp(sc, str, sc->write_string_symbol, str, port, sc->type_names[T_STRING], 1));
  if (!is_output_port(port))
    {
      if (port == sc->F) return(str);
      return(method_or_bust_pp(sc, port, sc->write_string_symbol, str, port, An_Output_Port_String, 2));
    }
  if (string_length(str) > 0)
    port_write_string(port)(sc, string_value(str), string_length(str), port);
  return(str);
}


/* -------- skip to newline readers -------- */
static token_t token(s7_scheme *sc);

static token_t file_read_semicolon(s7_scheme *sc, s7_pointer port)
{
  int32_t c;
  do (c = fgetc(port_file(port))); while ((c != '\n') && (c != EOF));
  port_line_number(port)++;
  return((c == EOF) ? Token_Eof : token(sc));
}

static token_t string_read_semicolon(s7_scheme *sc, s7_pointer port)
{
  const char *str = (const char *)(port_data(port) + port_position(port));
  const char *orig_str = strchr(str, (int)'\n');
  if (!orig_str)
    {
      port_position(port) = port_data_size(port);
      return(Token_Eof);
    }
  port_position(port) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */
  port_line_number(port)++;
  return(token(sc));
}


/* -------- white space readers -------- */

static int32_t file_read_white_space(s7_scheme *unused_sc, s7_pointer port)
{
  int32_t c;
  while (is_white_space(c = fgetc(port_file(port))))
    if (c == '\n')
      port_line_number(port)++;
  return(c);
}

static int32_t terminated_string_read_white_space(s7_scheme *unused_sc, s7_pointer port)
{
  const uint8_t *str = (const uint8_t *)(port_data(port) + port_position(port));
  uint8_t c;
  /* here we know we have null termination and white_space[#\null] is false */
  while (white_space[c = *str++]) /* 255 is not -1 = EOF */
    if (c == '\n')
      port_line_number(port)++;
  port_position(port) = (c) ? str - port_data(port) : port_data_size(port);
  return((int32_t)c);
}


/* -------- name readers -------- */
static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer port, bool atom_case)
{
  int32_t c;
  s7_int i = 1;  /* sc->strbuf[0] has the first char of the string we're reading */
  do {
    c = fgetc(port_file(port)); /* might return EOF */
    if (c == '\n')
      port_line_number(port)++;

    sc->strbuf[i++] = (unsigned char)c;
    if (i >= sc->strbuf_size)
      resize_strbuf(sc, i);
  } while ((c != EOF) && (char_ok_in_a_name[c]));

  if ((i == 2) &&
      (sc->strbuf[0] == '\\'))
    sc->strbuf[2] = '\0';
  else
    {
      if (c != EOF)
	{
	  if (c == '\n')
	    port_line_number(port)--;
	  ungetc(c, port_file(port));
	}
      sc->strbuf[i - 1] = '\0';
    }
  if (atom_case)
    return(make_atom(sc, sc->strbuf, Base_10, Symbol_Ok, With_Overflow_Error));
  return(make_sharp_constant(sc, sc->strbuf, With_Overflow_Error, port, true));
}

static s7_pointer file_read_name(s7_scheme *sc, s7_pointer port)  {return(file_read_name_or_sharp(sc, port, true));}
static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer port) {return(file_read_name_or_sharp(sc, port, false));}

static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer port)
{
  /* sc->strbuf[0] has the first char of the string we're reading */
  const uint8_t *str = (uint8_t *)(port_data(port) + port_position(port));

  if (char_ok_in_a_name[*str])
    {
      s7_int k;
      const uint8_t *orig_str = str - 1;
      str++;
      while (char_ok_in_a_name[*str]) str++;
      k = str - orig_str;
      if (*str != 0)
	port_position(port) += (k - 1);
      else port_position(port) = port_data_size(port);
      /* this is equivalent to:
       *    str = strpbrk(str, "(); \"\t\r\n");
       *    if (!str) {k = strlen(orig_str); str = (char *)(orig_str + k);} else k = str - orig_str;
       * but slightly faster.
       */
      if (!number_table[*orig_str])
	return(inline_make_symbol(sc, (const char *)orig_str, k));

      /* eval_c_string string is a constant so we can't set and unset the token's end char */
      if ((k + 1) >= sc->strbuf_size)
	resize_strbuf(sc, k + 1);
      memcpy((void *)(sc->strbuf), (void *)orig_str, k);
      sc->strbuf[k] = '\0';
      return(make_atom(sc, sc->strbuf, Base_10, Symbol_Ok, With_Overflow_Error));
    }
  {
    s7_pointer result = sc->singletons[(uint8_t)(sc->strbuf[0])];
    if (!result)
      {
	sc->strbuf[1] = '\0';
	result = make_symbol(sc, sc->strbuf, 1);
	sc->singletons[(uint8_t)(sc->strbuf[0])] = result;
      }
    return(result);
  }
}

static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer port)
{
  /* sc->strbuf[0] has the first char of the string we're reading.
   *   since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe
   */
  char *str = (char *)(port_data(port) + port_position(port));
  if (char_ok_in_a_name[(uint8_t)*str])
    {
      s7_int k;
      const char *orig_str = (char *)(str - 1);
      str++;
      while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;}
      k = str - orig_str;
      port_position(port) += (k - 1);
      if ((k + 1) >= sc->strbuf_size)
	resize_strbuf(sc, k + 1);
      memcpy((void *)(sc->strbuf), (void *)orig_str, k);
      sc->strbuf[k] = '\0';
      return(make_sharp_constant(sc, sc->strbuf, With_Overflow_Error, port, true));
    }
  if (sc->strbuf[0] == 'f') return(sc->F);
  if (sc->strbuf[0] == 't') return(sc->T);
  if (sc->strbuf[0] == '\\')
    {
      /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
      sc->strbuf[1] = str[0];
      sc->strbuf[2] = '\0';
      port_position(port)++;
    }
  else sc->strbuf[1] = '\0';
  return(make_sharp_constant(sc, sc->strbuf, With_Overflow_Error, port, true));
}

static s7_pointer string_read_name(s7_scheme *sc, s7_pointer port)
{
  /* port_string was allocated (and read from a file) so we can mess with it directly */
  s7_pointer result;
  uint8_t *str = (uint8_t *)(port_data(port) + port_position(port));
  if (char_ok_in_a_name[*str])
    {
      s7_int k;
      uint8_t endc;
      const uint8_t *orig_str = str - 1;
      str++;
      while (char_ok_in_a_name[*str]) str++;
      k = str - orig_str;
      port_position(port) += (k - 1);
      if (!number_table[*orig_str])
	return(inline_make_symbol(sc, (const char *)orig_str, k));
      endc = *str;
      *str = 0; /* temp end for make_atom */
      result = make_atom(sc, (char *)orig_str, Base_10, Symbol_Ok, With_Overflow_Error);
      *str = endc;
      return(result);
    }
  result = sc->singletons[(uint8_t)(sc->strbuf[0])];
  if (!result)
    {
      sc->strbuf[1] = '\0';
      result = make_symbol(sc, sc->strbuf, 1);
      sc->singletons[(uint8_t)(sc->strbuf[0])] = result;
    }
  return(result);
}

static void port_set_filename(s7_scheme *sc, s7_pointer 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};

static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller)
{
  s7_pointer port;
#if !MS_Windows
  s7_int size;
#endif
  block_t *b = mallocate_port(sc);
  new_cell(sc, port, T_INPUT_PORT);
  gc_protect_via_stack(sc, port);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  port_set_closed(port, false);
  port_set_string_or_function(port, sc->nil);
  port_filename_length(port) = safe_strlen(name);
  port_set_filename(sc, port, name, port_filename_length(port));
  port_line_number(port) = 1;  /* first line is numbered 1 */
  port_file_number(port) = 0;
  add_input_port(sc, port);

#if !MS_Windows
  /* this doesn't work in MS C */
  fseek(fp, 0, SEEK_END);
  size = ftell(fp);
  rewind(fp);
  /* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */
  if ((size > 0) &&   /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */
      ((max_size < 0) || (size < max_size))) /* load uses max_size = -1 */
    {
      block_t *block = mallocate(sc, size + 2);
      uint8_t *content = (uint8_t *)(block_data(block));
      const size_t bytes = fread(content, sizeof(uint8_t), size, fp);
      if (bytes != (size_t)size)
	{
#if !defined(_WIN32)
	  /* on Windows-based environments, ftell counts CRLF as 2 bytes, while fread in text mode converts them to LF, resulting in a byte count mismatch (Satoru Matsusaki) */
	  if (current_output_port(sc) != sc->F)
	    {
	      char tmp[s7_Warn_Bufsize];
	      int32_t len = snprintf(tmp, s7_Warn_Bufsize, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size);
	      port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, s7_Warn_Bufsize), current_output_port(sc));
	    }
#endif
	  size = bytes;
	}
      content[size] = '\0';
      content[size + 1] = '\0';
      fclose(fp);

      port_file(port) = NULL; /* make valgrind happy */
      set_is_string_port(port);
      port_data(port) = content;
      port_data_block(port) = block;
      port_data_size(port) = size;
      port_position(port) = 0;
      port_needs_free(port) = true;
      port_port(port)->pf = &input_string_functions_1;
    }
  else
    {
      port_file(port) = fp;
      set_is_file_port(port);
      port_data(port) = NULL;
      port_data_block(port) = NULL;
      port_data_size(port) = 0;
      port_position(port) = 0;
      port_needs_free(port) = false;
      port_port(port)->pf = &input_file_functions;
    }
#else
  /* _stat64 is no better than the fseek/ftell route, and
   *    GetFileSizeEx and friends requires Windows.h which makes hash of everything else.
   *    fread until done takes too long on big files, so use a file port
   */
  port_file(port) = fp;
  set_is_file_port(port);
  port_needs_free(port) = false;
  port_data(port) = NULL;
  port_data_block(port) = NULL;
  port_data_size(port) = 0;
  port_position(port) = 0;
  port_port(port)->pf = &input_file_functions;
#endif
  unstack_gc_protect(sc);
  return(port);
}


/* -------------------------------- open-input-file -------------------------------- */
static int32_t remember_file_name(s7_scheme *sc, const char *file)
{
  for (int32_t i = 0; i <= sc->file_names_top; i++)
    if (safe_strcmp(file, string_value(sc->file_names[i])))
      return(i);

  sc->file_names_top++;
  if (sc->file_names_top >= sc->file_names_size)
    {
      int32_t old_size = 0;
      /* what if file_names_size is greater than file_bits in pair|profile_file? */
      if (sc->file_names_size == 0)
	{
	  sc->file_names_size = Initial_File_Names_Size;
	  sc->file_names = (s7_pointer *)Malloc(sc->file_names_size * sizeof(s7_pointer));
	}
      else
	{
	  old_size = sc->file_names_size;
	  sc->file_names_size *= 2;
	  sc->file_names = (s7_pointer *)Realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer));
	}
      for (int32_t i = old_size; i < sc->file_names_size; i++)
	sc->file_names[i] = sc->F;
    }
  sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file);
  return(sc->file_names_top);
}

#ifndef MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION
  #define MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION 10000000
  /* I'd add this to *s7* but it doesn't make much difference unless you're reading a large text file */
#endif
#define Max_Size_For_File_To_String_Port_Conversion MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION

static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp)
{
  return(read_file(sc, fp, name, Max_Size_For_File_To_String_Port_Conversion, "open"));
}


#if !MS_Windows
#include <sys/stat.h>
#endif

static bool is_directory(const char *filename)
{
#if !MS_Windows
  #ifdef S_ISDIR
    struct stat statbuf;
    return((stat(filename, &statbuf) >= 0) &&
	   (S_ISDIR(statbuf.st_mode)));
  #endif
#endif
  return(false);
}

static block_t *expand_filename(s7_scheme *sc, s7_pointer name)
{
#if WITH_GCC
  const char *str = (const char *)string_value(name);
  if ((str[0] == '~') && (str[1] == '/'))    /* catch one special case, "~/..." */
    {
      char *home = getenv("HOME");
      if (home)
	{
	  s7_int len = string_length(name) + safe_strlen(home) + 1;
	  block_t *b = mallocate(sc, len);
	  char *filename = (char *)block_data(b);
	  filename[0] = '\0';
	  if (is_wrapper(name)) /* (file-exists? (substring-uncopied "abcdefg" 0 2)) */
	    {
	      char *true_name = copy_string_with_length(string_value(name), string_length(name));
	      catstrs(filename, len, home, (const char *)(true_name + 1), (char *)NULL);
	      free(true_name);
	    }
	  else catstrs(filename, len, home, (const char *)(str + 1), (char *)NULL);
	  return(b);
	}}
#endif
  return(NULL);
}

static s7_pointer open_input_file_1(s7_scheme *sc, s7_pointer pname, const char *mode, const char *caller)
{
  FILE *fp;
#if WITH_GCC
  block_t *b;
#endif
  const char *name = string_value(pname);
  /* see if we can open this file before allocating a port */
  if (is_directory(name))
    file_error_nr(sc, caller, "file is a directory:", name);
  errno = 0;
  fp = fopen(name, mode);
  if (fp)
    return(make_input_file(sc, name, fp));

#if !MS_Windows
  if (errno == EINVAL)
    file_error_nr(sc, caller, "invalid mode", mode);
#if WITH_GCC
  if ((!name) || (!*name))
    file_error_nr(sc, caller, strerror(errno), name);
  b = expand_filename(sc, pname);
  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, s7_make_string(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)))
    {
      if (is_wrapper(name))
	return(open_input_file_1(sc, s7_make_string_with_length(sc, string_value(name), string_length(name)), "r", "open-input-file"));
      return(open_input_file_1(sc, 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)); /* 29 checked in s7test.scm */
    /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */
    if (is_wrapper(name))
      return(open_input_file_1(sc, s7_make_string_with_length(sc, string_value(name), string_length(name)), string_value(mode), "open-input-file"));
    return(open_input_file_1(sc, name, string_value(mode), "open-input-file"));
  }
}

static void close_stdin(s7_scheme *unused_sc, s7_pointer unused_port) {return;}
static void close_stdout(s7_scheme *unused_sc, s7_pointer unused_port) {return;}
static void close_stderr(s7_scheme *unused_sc, s7_pointer unused_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));
  set_is_file_port(port);
  port_data(port) = NULL;
  port_data_block(port) = NULL;
  port_set_closed(port, false);
  port_line_number(port) = 0;
  port_needs_free(port) = false;
  return(port);
}

static void init_standard_ports(s7_scheme *sc)
{
  s7_pointer port;
  /* standard output */
  port = alloc_standard_output_port(sc);
  port_filename_length(port) = 8;
  port_set_filename(sc, port, "*stdout*", 8);
  port_file_number(port) = remember_file_name(sc, port_filename(port)); /* these numbers need to be correct for the evaluator (*function* data) */
  port_file(port) = stdout;
  port_port(port)->pf = &stdout_functions;
  sc->standard_output = port;

  /* standard error */
  port = alloc_standard_output_port(sc);
  port_filename_length(port) = 8;
  port_set_filename(sc, port, "*stderr*", 8);
  port_file_number(port) = remember_file_name(sc, port_filename(port));
  port_file(port) = stderr;
  port_port(port)->pf = &stderr_functions;
  sc->standard_error = port;

  /* standard input */
  port = alloc_pointer(sc);
  set_full_type(port, T_INPUT_PORT | T_Immutable | T_Unheap);
  port_port(port) = (port_t *)Calloc(1, sizeof(port_t));
  set_is_file_port(port);
  port_set_closed(port, false);
  port_set_string_or_function(port, sc->nil);
  port_filename_length(port) = 7;
  port_set_filename(sc, port, "*stdin*", 7);
  port_file_number(port) = remember_file_name(sc, port_filename(port));
  port_line_number(port) = 0;
  port_file(port) = stdin;
  port_data_block(port) = NULL;
  port_needs_free(port) = false;
  port_port(port)->pf = &stdin_functions;
  sc->standard_input = port;

  s7_define_variable_with_documentation(sc, "*stdin*", sc->standard_input, "*stdin* is the built-in input port, C's stdin");
  s7_define_variable_with_documentation(sc, "*stdout*", sc->standard_output, "*stdout* is the built-in buffered output port, C's stdout");
  s7_define_variable_with_documentation(sc, "*stderr*", sc->standard_error, "*stderr* is the built-in unbuffered output port, C's stderr");

  set_current_input_port(sc, sc->standard_input);
  set_current_output_port(sc, sc->standard_output);
  set_current_error_port(sc, sc->standard_error);
  sc->current_file = NULL;
  sc->current_line = -1;
}


/* -------------------------------- open-output-file -------------------------------- */
static const port_functions_t output_file_functions =
  {output_read_char, file_write_char, file_write_string, NULL, NULL, NULL, NULL, output_read_line, file_display, close_output_file};

s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode)
{
  FILE *fp;
  s7_pointer port;
  block_t *block, *b;
  /* see if we can open this file before allocating a port */

  errno = 0;
  fp = fopen(name, mode);
  if (!fp)
    {
#if !MS_Windows
      if (errno == EINVAL)
	file_error_nr(sc, "open-output-file", "invalid mode", mode);
#endif
      file_error_nr(sc, "open-output-file", strerror(errno), name);
    }
  new_cell(sc, port, T_OUTPUT_PORT);
  b = mallocate_port(sc);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  set_is_file_port(port);
  port_set_closed(port, false);
  port_filename_length(port) = safe_strlen(name);
  port_set_filename(sc, port, name, port_filename_length(port));
  port_line_number(port) = 1;
  port_file_number(port) = 0;
  port_file(port) = fp;
  port_needs_free(port) = true;  /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */
  port_position(port) = 0;
  port_data_size(port) = sc->output_file_port_length;
  block = mallocate(sc, sc->output_file_port_length);
  port_data_block(port) = block;
  port_data(port) = (uint8_t *)(block_data(block));
  port_port(port)->pf = &output_file_functions;
  add_output_port(sc, port);
  return(port);
}

static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args)
{
  #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing"
  #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol)

  const s7_pointer name = car(args);
  if (!is_string(name))
    return(method_or_bust(sc, name, sc->open_output_file_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_pair(cdr(args)))
    return(s7_open_output_file(sc, string_value(name), "w"));
  if (!is_string(cadr(args)))
    return(method_or_bust(sc, cadr(args), sc->open_output_file_symbol, args, wrap_string(sc, "a string (a mode such as \"w\")", 29), 2));
  return(s7_open_output_file(sc, string_value(name), string_value(cadr(args))));
}


/* -------------------------------- open-input-string -------------------------------- */

/* a version of string ports using a pointer to the current location and a pointer to the end
 *   (rather than an integer for both, indexing from the base string) was not faster.
 */

static const port_functions_t input_string_functions =
  {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space,
   string_read_name_no_free, string_read_sharp,	string_read_line, input_display, close_simple_input_string};

static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len)
{
  s7_pointer port;
  block_t *b = mallocate_port(sc);
  new_cell(sc, port, T_INPUT_PORT);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  set_is_string_port(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);
      abort();
    }
#endif
  port_port(port)->pf = &input_string_functions;
  add_input_string_port(sc, port);
  return(port);
}

static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str)
{
  const char *str_val = string_value(str);
  const s7_int len = string_length(str);
  s7_pointer port;
  if (str_val[len] != '\0') /* (eval-string|open-input-string (substring-uncopied "asdf" 0 2)) -- open_input_string will complain that the string is unterminated */
    str = make_string_with_length(sc, str_val, len);
  port = open_input_string(sc, string_value(str), string_length(str));
  port_set_string_or_function(port, str);
  return(port);
}

s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string)
{
  return(open_input_string(sc, input_string, safe_strlen(input_string)));
}

static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args)
{
  #define H_open_input_string "(open-input-string str) opens an input port reading str"
  #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol)
  s7_pointer input_string = car(args);
  if (!is_string(input_string))
    return(sole_arg_method_or_bust(sc, input_string, sc->open_input_string_symbol, args, sc->type_names[T_STRING]));
  return(open_and_protect_input_string(sc, input_string));
}


/* -------------------------------- open-output-string -------------------------------- */
#define Format_Port_Length 128
/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed
 *   256 is slightly slower (the calloc time below dominates the realloc time in string_write_string)
 *   64 is much slower (realloc dominates)
 */

static const port_functions_t output_string_functions =
  {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string};

s7_pointer s7_open_output_string(s7_scheme *sc)
{
  s7_pointer port;
  block_t *b = mallocate_port(sc);
  block_t *block = inline_mallocate(sc, sc->initial_string_port_length);
  new_cell(sc, port, T_OUTPUT_PORT);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  set_is_string_port(port);
  port_set_closed(port, false);
  port_data_size(port) = sc->initial_string_port_length;
  port_data_block(port) = block;
  port_data(port) = (uint8_t *)(block_data(block));
  port_data(port)[0] = '\0';        /* in case s7_get_output_string before any output */
  port_position(port) = 0;
  port_needs_free(port) = true;
  port_filename_block(port) = NULL;
  port_filename_length(port) = 0;   /* protect against (port-filename (open-output-string)) */
  port_filename(port) = NULL;
  port_port(port)->pf = &output_string_functions;
  add_output_port(sc, port);
  return(port);
}

static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_open_output_string "(open-output-string) opens an output string port"
  #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol)
  return(s7_open_output_string(sc));
}


/* -------------------------------- get-output-string -------------------------------- */
const char *s7_get_output_string(s7_scheme *unused_sc, s7_pointer port)
{
  port_data(port)[port_position(port)] = '\0';
  return((const char *)port_data(port));
}

s7_pointer s7_output_string(s7_scheme *sc, s7_pointer port)
{
  port_data(port)[port_position(port)] = '\0';
  if (port_position(port) == 0) return(nil_string);
  return(make_string_with_length(sc, (const char *)port_data(port), port_position(port)));
}

static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer port)
{
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, port, wrap_string(sc, "an active (open) string port", 28));
  if (port_position(port) > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length), ~D", 80),
			 wrap_integer(sc, port_position(port)), wrap_integer(sc, sc->max_string_length)));
}
/* if pos>max and clear, where should the clear be?  Not here because we might want to see output in error handler.
 *   similarly below if pos>size how can we call make_string (out-of-bounds) and ignore error?
 *   if pos>size shouldn't we raise an error somewhere?
 */

static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_get_output_string "(get-output-string port (clear-port #f)) returns the output accumulated in port.  \
If the optional 'clear-port' is #t, the current string is flushed."
  #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, \
                                 s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol)
  s7_pointer port;
  bool clear_port = false;
  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);

  /* 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)
{
  set_is_function_port(port);
  port_data(port) = NULL;
  port_data_block(port) = NULL;
  port_set_closed(port, false);
  port_needs_free(port) = false;
  port_filename_block(port) = NULL; /* next three protect against port-filename misunderstandings */
  port_filename(port) = NULL;
  port_filename_length(port) = 0;
  port_file_number(port) = 0;
  port_line_number(port) = 0;
  port_file(port) = NULL;
}

s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port))
{
  s7_pointer port;
  block_t *b = mallocate_port(sc);
  new_cell(sc, port, T_INPUT_PORT);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  function_port_set_defaults(port);
  port_set_string_or_function(port, sc->nil);
  port_input_function(port) = function;
  port_port(port)->pf = &input_function_functions;
  add_input_port(sc, port);
  return(port);
}

static void init_open_input_function_choices(s7_scheme *sc)
{
  sc->open_input_function_choices[S7_READ] = sc->read_symbol;
  sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol;
  sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol;
  sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol;
#if !With_Pure_s7
  sc->open_input_function_choices[S7_IS_CHAR_READY] = sc->is_char_ready_symbol;
#endif
}

static s7_pointer input_scheme_function_wrapper(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)
{
  return(s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, sc->open_input_function_choices[(int)read_choice])));
}

static s7_pointer g_open_input_function(s7_scheme *sc, s7_pointer args)
{
  #define H_open_input_function "(open-input-function func) opens an input function port"
  #define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))

  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);
  }
}


/* -------------------------------- 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);
  }
}


/* -------- current-input-port stack -------- */
#define Input_Port_Stack_Initial_Size 4

static /* inline */ void push_input_port(s7_scheme *sc, s7_pointer new_port)
{
  if (sc->input_port_stack_loc >= sc->input_port_stack_size)
    {
      sc->input_port_stack_size *= 2;
      sc->input_port_stack = (s7_pointer *)Realloc(sc->input_port_stack, sc->input_port_stack_size * sizeof(s7_pointer));
    }
  sc->input_port_stack[sc->input_port_stack_loc++] = current_input_port(sc);
  set_current_input_port(sc, new_port);
}

static void pop_input_port(s7_scheme *sc)
{
  set_current_input_port(sc, (sc->input_port_stack_loc > 0) ? sc->input_port_stack[--(sc->input_port_stack_loc)] : sc->standard_input);
}

static s7_pointer input_port_if_not_loading(s7_scheme *sc)
{
  const s7_pointer port = current_input_port(sc);
  int32_t c;
  if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */
    return(port);
  c = port_read_white_space(port)(sc, port);
  if (c > 0)            /* we can get either EOF or NULL at the end */
    {
      backchar(c, port);
      return(NULL);
    }
  return(sc->standard_input);
}


/* -------------------------------- read-char -------------------------------- */
s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port)
{
  int32_t c = port_read_character(port)(sc, port);
  return((c == EOF) ? eof_object : chars[c]);
}

static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
{
  #define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port"
  #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)

  s7_pointer port;
  if (is_pair(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(eof_object);
    }
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_char_symbol, An_Input_Port_String));
  return(chars[port_read_character(port)(sc, port)]);
}

static inline s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) /* inline for fx_c_o_read_char */
{
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_char_symbol, An_Input_Port_String));
  return(chars[port_read_character(port)(sc, port)]);
}

static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port = car(args);
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_char_symbol, An_Input_Port_String));
  return(chars[port_read_character(port)(sc, port)]);
}

static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 1) ? sc->read_char_1 : func);
}


/* -------------------------------- write-char -------------------------------- */
s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port)
{
  if (port != sc->F)
    port_write_character(port)(sc, s7_character(c), port);
  return(c);
}

static s7_pointer write_char_p_pp(s7_scheme *sc, s7_pointer c, s7_pointer port)
{
  if (!is_character(c))
    return(method_or_bust_pp(sc, c, sc->write_char_symbol, c, port, sc->type_names[T_CHARACTER], 1));
  if (!is_output_port(port))
    {
      if (port == sc->F) return(c);
      if_method_exists_return_value(sc, port, sc->write_char_symbol, set_mlist_2(sc, c, port));
      wrong_type_error_nr(sc, sc->write_char_symbol, 2, port, An_Output_Port_Or_F_String);
    }
  port_write_character(port)(sc, s7_character(c), port);
  return(c);
}

static s7_pointer write_char_p_p(s7_scheme *sc, s7_pointer c)
{
  if (!is_character(c))
    return(method_or_bust_p(sc, c, sc->write_char_symbol, sc->type_names[T_CHARACTER]));
  if (current_output_port(sc) == sc->F) return(c);
  port_write_character(current_output_port(sc))(sc, s7_character(c), current_output_port(sc));
  return(c);
}

static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args)
{
  #define H_write_char "(write-char char (port (current-output-port))) writes char to the output port"
  #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  if (is_null(cdr(args)))
    return(write_char_p_p(sc, car(args)));
  return(write_char_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}

static s7_pointer g_write_char_c(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port = current_output_port(sc), c = car(args);
  if (port != sc->F)
    port_write_character(port)(sc, character(c), port);
  return(c);
}

static s7_pointer write_char_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args == 1) && (is_character(cadr(expr))))
    return(sc->write_char_c);
  return(func);
}

/* (with-output-to-string (lambda () (write-char #\space))) -> " "
 * (with-output-to-string (lambda () (write #\space))) -> "#\\space"
 * (with-output-to-string (lambda () (display #\space))) -> " "
 * is this correct?  It's what Guile does.  write-char is actually display-char.
 */
/* should write-char, write, write-string, display, and newline count newlines for port-line-number?  Currently we only accept input ports */


/* -------------------------------- peek-char -------------------------------- */
s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port)
{
  int32_t c;              /* needs to be an int32_t so EOF=-1, but not 255 */
  if (is_string_port(port))
    return((port_data_size(port) <= port_position(port)) ? eof_object : chars[(uint8_t)port_data(port)[port_position(port)]]);
  c = port_read_character(port)(sc, port);
  if (c == EOF) return(eof_object);
  backchar(c, port);
  return(chars[c]);
}

static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args)
{
  #define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream"
  #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)

  s7_pointer result;
  const s7_pointer port = (is_pair(args)) ? car(args) : current_input_port(sc);
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->peek_char_symbol, An_Input_Port_String));
  if (port_is_closed(port))
    sole_arg_wrong_type_error_nr(sc, sc->peek_char_symbol, port, An_Open_Input_Port_String);
  if (is_string_port(port))
    return((port_data_size(port) <= port_position(port)) ? eof_object : chars[(uint8_t)port_data(port)[port_position(port)]]);
  if (!is_function_port(port))
    return(s7_peek_char(sc, port));

  result = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, port);
  if (is_multiple_value(result))
    {
      clear_multiple_value(result);
      error_nr(sc, sc->bad_result_symbol,
	       set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), result));
    }
  if (!is_character(result))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), result));
  return(result);
}


/* -------------------------------- read-byte(s) -------------------------------- */
static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args)
{
  #define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port"
  #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)

  s7_pointer port;
  if (is_pair(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(eof_object);
    }
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_byte_symbol, An_Input_Port_String));
  if (port_is_closed(port))          /* avoid reporting caller here as read-char */
    sole_arg_wrong_type_error_nr(sc, sc->read_byte_symbol, port, An_Open_Input_Port_String);
  {
    const int32_t c = port_read_character(port)(sc, port);
    return((c == EOF) ? eof_object : small_int(c));
  }
}


static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len);

static s7_pointer g_read_bytes(s7_scheme *sc, s7_pointer args)
{
  #define H_read_bytes "(read-bytes port n (destination-vector #f))): reads n elements from the input port, returns a byte-vector if no destination-vector is given. \
 destination-vector can be any numeric vector"
  #define Q_read_bytes s7_make_signature(sc, 4, sc->is_vector_symbol, sc->is_input_port_symbol, sc->is_integer_symbol, sc->is_vector_symbol)

  const s7_pointer port = car(args);
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_bytes_symbol, An_Input_Port_String));
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->read_bytes_symbol, 1, port, An_Open_Input_Port_String);
  if (is_function_port(port))
    wrong_type_error_nr(sc, sc->read_bytes_symbol, 1, port, wrap_string(sc, "read-bytes currently does not work with a function port", 55));
  /* since a vector is involved one way or another, I don't think max size error checks are needed here */
  {
    const s7_pointer bytes = cadr(args), dest = (is_pair(cddr(args))) ? caddr(args) : sc->F;
    s7_int n;

    if (!s7_is_integer(bytes))
      return(method_or_bust(sc, bytes, sc->read_bytes_symbol, args, sc->type_names[T_INTEGER], 2));
    if ((dest != sc->F) && (!is_numeric_vector(dest)))
      wrong_type_error_nr(sc, sc->read_bytes_symbol, 3, dest, wrap_string(sc, "a numeric vector", 16));
    n = s7_integer_clamped_if_gmp(sc, bytes);
    if (n < 0)
      wrong_type_error_nr(sc, sc->read_bytes_symbol, 2, bytes, A_Non_Negative_Integer_String);
    {
      s7_pointer bv = NULL;
      s7_int size = 1;
      if (dest == sc->F)
	bv = make_simple_byte_vector(sc, n);
      else
	{
	  const s7_int lim = vector_length(dest);
	  if (!is_byte_vector(dest)) size = (is_complex_vector(dest)) ? 16 : 8;
	  if (n > lim) n = lim;
	  bv = dest;
	}
      if (n == 0) return(bv);
      if (is_file_port(port)) /* so it has file_port(port), port_data/position are ignored(?) */
	{
	  const s7_int bytes_read = (s7_int)fread((void *)vector_bytes_unchecked(bv), size, n, port_file(port));
	  if ((bytes_read != (n * size)) && (dest == sc->F))
	    byte_vector_length(bv) = bytes_read;
	}
      else
	{ /* must be an input string port */
	  const s7_int bytes_available = (port_data_size(port) - port_position(port));
	  n *= size;
	  if (n > bytes_available)
	    {
	      if (dest == sc->F) /* we made bv too big above */
		byte_vector_length(bv) = bytes_available;
	      n = bytes_available;
	    }
	  if (n > 0)
	    {
	      memcpy((void *)vector_bytes_unchecked(bv), (uint8_t *)(port_data(port) + port_position(port)), n);
	      port_position(port) += n;
	    }}
      return(bv);
    }}
  return(NULL); /* can't happen */
}


/* -------------------------------- write-byte(s) -------------------------------- */
static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
{
  #define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port"
  #define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))

  const s7_pointer b = car(args);
  s7_int val;
  if (!s7_is_integer(b))
    return(method_or_bust(sc, b, sc->write_byte_symbol, args, sc->type_names[T_INTEGER], 1));

  val = s7_integer_clamped_if_gmp(sc, b);
  if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */
    wrong_type_error_nr(sc, sc->write_byte_symbol, 1, b, An_Unsigned_Byte_String);
  {
    s7_pointer port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc);
    if (!is_output_port(port))
      {
	if (port == sc->F) return(b);
	if_method_exists_return_value(sc, port, sc->write_byte_symbol, args);
	wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, An_Output_Port_Or_F_String);
      }
    if (port_is_closed(port))          /* avoid reporting caller here as write-char */
      wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, An_Open_Output_Port_String);

    port_write_character(port)(sc, (uint8_t)val, port);
  }
  return(b);
}

static s7_pointer g_write_bytes(s7_scheme *sc, s7_pointer args)
{
  #define H_write_bytes "(write-bytes port v n): write n elements of vector v to the output port, n defaults to the length of v. v can be any numeric vector"
  #define Q_write_bytes s7_make_signature(sc, 4, sc->is_vector_symbol, sc->is_output_port_symbol, sc->is_vector_symbol, sc->is_integer_symbol)
  /* signature entries 'vector? are incorrect -- they should be 'numeric-vector? */

  const s7_pointer port = car(args), bv = cadr(args);
  if (!is_output_port(port))
    return(method_or_bust_p(sc, port, sc->write_bytes_symbol, An_Output_Port_String));
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->write_bytes_symbol, 1, port, An_Open_Output_Port_String);
  if (is_function_port(port))
    wrong_type_error_nr(sc, sc->write_bytes_symbol, 1, port, wrap_string(sc, "write-bytes currently does not work with a function port", 56));
  if (!is_numeric_vector(bv))
    wrong_type_error_nr(sc, sc->write_bytes_symbol, 1, port, wrap_string(sc, "write-bytes: the second argument should be a numeric vector", 59));
  {
    s7_int lim;
    const s7_pointer bytes = (is_pair(cddr(args))) ? caddr(args) : sc->F;
    if (!s7_is_integer(bytes))
      {
	if (bytes == sc->F)
	  lim = vector_length(bv);
	else return(method_or_bust(sc, bytes, sc->write_bytes_symbol, args, sc->type_names[T_INTEGER], 2));
      }
    else
      {
	lim = s7_integer_clamped_if_gmp(sc, bytes);
	if (lim > vector_length(bv)) lim = vector_length(bv);
	else if (lim < 0) wrong_type_error_nr(sc, sc->write_bytes_symbol, 3, bytes, A_Non_Negative_Integer_String);
      }
    if (lim == 0) return(bv);
    {
      s7_int size = 1;
      if (!is_byte_vector(bv)) size = (is_complex_vector(bv)) ? 16 : 8;
      if (is_file_port(port))
	file_write_string(sc, (const char *)vector_bytes_unchecked(bv), lim * size, port);
      else string_write_string(sc, (const char *)vector_bytes_unchecked(bv), lim * size, port);
    }}
  return(bv);
}


/* -------------------------------- read-line -------------------------------- */
static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args)
{
  #define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #<eof>. \
If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
  #define Q_read_line s7_make_signature(sc, 3, \
                        s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \
                        sc->is_input_port_symbol, sc->is_boolean_symbol)
  s7_pointer port;
  bool with_eol = false;
  if (is_pair(args))
    {
      port = car(args);
      if (!is_input_port(port))
	return(method_or_bust(sc, port, sc->read_line_symbol, args, An_Input_Port_String, 1));
      if (is_pair(cdr(args)))
	{
	  with_eol = (cadr(args) == sc->T); /* sig says boolean? so insist on #t, else we get stuff like (read-line port (c-pointer 0)) */
	  if ((!with_eol) && (cadr(args) != sc->F))
	    wrong_type_error_nr(sc, sc->read_line_symbol, 2, cadr(args), A_Boolean_String);
	}}
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(eof_object);
    }
  return(port_read_line(port)(sc, port, with_eol));
}

static s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol)
{
  if (!is_input_port(port))
    return(method_or_bust_pp(sc, port, sc->read_line_symbol, port, with_eol, An_Input_Port_String, 1));
  if (!is_boolean(with_eol))
    wrong_type_error_nr(sc, sc->read_line_symbol, 2, with_eol, A_Boolean_String);
  return(port_read_line(port)(sc, port, with_eol != sc->F));
}

static s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port)
{
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_line_symbol, An_Input_Port_String));
  return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */
}


/* -------------------------------- read-string -------------------------------- */
#define Read_String_Line_Numbers 0/* 1 adds port-line-number support to read-string, doubling the time it takes */

static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
{
  /* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string)
   * should this worry about newlines?  read-char and read-line keep port-line-number up to date,
   *   but here we'd need to scan the new string (via strchr?) or xor with \n\n\n\n... up to 8-at-a-time, and count zeros.
   */
  #define H_read_string "(read-string k port) reads k characters from port into a new string and returns it."
  #define Q_read_string s7_make_signature(sc, 3, \
                          s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \
                          sc->is_integer_symbol, sc->is_input_port_symbol)
  const s7_pointer k = car(args);
  s7_pointer port, str;
  s7_int nchars;
  uint8_t *str_chars;

  if (!s7_is_integer(k))
    return(method_or_bust(sc, k, sc->read_string_symbol, args, sc->type_names[T_INTEGER], 1));
  nchars = s7_integer_clamped_if_gmp(sc, k);
  if (nchars < 0)
    out_of_range_error_nr(sc, sc->read_string_symbol, Int_One, k, It_Is_Negative_String);
  if (nchars > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "read-string first argument ~D is greater than (*s7* 'max-string-length), ~D", 75),
			 wrap_integer(sc, nchars), wrap_integer(sc, sc->max_string_length)));
  if (!is_null(cdr(args)))
    port = cadr(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(eof_object);
    }
  if (!is_input_port(port))
    return(method_or_bust_pp(sc, port, sc->read_string_symbol, k, port, An_Input_Port_String, 2));
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->read_string_symbol, 2, port, An_Open_Input_Port_String);

  if (nchars == 0) return(nil_string);
  str = make_empty_string(sc, nchars, '\0');
  str_chars = (uint8_t *)string_value(str);
  if (is_string_port(port))
    {
      const s7_int pos = port_position(port);
      const s7_int end = port_data_size(port);
      s7_int len = end - pos;
      if (len > nchars) len = nchars;
      if (len <= 0) return(eof_object);
      memcpy((void *)str_chars, (void *)(port_data(port) + pos), len);
      string_length(str) = len;
      str_chars[len] = '\0';
      port_position(port) += len;
#if Read_String_Line_Numbers
      for (s7_int i = 0; i < len; i++) if (str_chars[i] == '\n') port_line_number(port)++;
#endif
      return(str);
    }
  if (is_file_port(port))
    {
      const s7_int len = (s7_int)fread((void *)str_chars, 1, nchars, port_file(port));
      str_chars[len] = '\0';
      string_length(str) = len;
#if Read_String_Line_Numbers
      for (s7_int i = 0; i < len; i++) if (str_chars[i] == '\n') port_line_number(port)++;
#endif
      return(str);
    }
  for (s7_int i = 0; i < nchars; i++)
    {
      const int32_t c = port_read_character(port)(sc, port);
      if (c == EOF)
	{
	  if (i == 0)
	    return(eof_object);
	  string_length(str) = i;
	  return(str);
	}
      str_chars[i] = (uint8_t)c;
#if Read_String_Line_Numbers
      if (c == '\n') port_line_number(port)++;
#endif
    }
  return(str);
}


/* -------------------------------- read -------------------------------- */
#define declare_jump_info() bool old_longjmp; setjmp_loc_t old_jump_loc; jump_loc_t jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start

#define store_jump_info(Sc)			\
  do {						\
      old_longjmp = Sc->longjmp_ok;		\
      old_jump_loc = Sc->setjmp_loc;		\
      old_goto_start = Sc->Goto_Start;		\
  } while (0)

#define restore_jump_info(Sc)			\
  do {						\
    Sc->longjmp_ok = old_longjmp;		\
    Sc->setjmp_loc = old_jump_loc;		\
    Sc->Goto_Start = old_goto_start;		\
    if ((jump_loc == Error_Jump) &&		\
	(Sc->longjmp_ok))			\
      LongJmp(*(Sc->Goto_Start), Error_Jump);	\
  } while (0)

#define set_jump_info(Sc, Tag)			\
  do {						\
    Sc->longjmp_ok = true;			\
    Sc->setjmp_loc = Tag;			\
    jump_loc = (jump_loc_t)SetJmp(new_goto_start, 1);	\
    Sc->Goto_Start = &new_goto_start;		\
  } while (0)

static s7_pointer eval(s7_scheme *sc, opcode_t first_op);

s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
{
  if (!is_input_port(port))
    sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, An_Input_Port_String);
  {
    const s7_pointer old_let = sc->curlet;
    declare_jump_info();
    set_curlet(sc, sc->rootlet);
    push_input_port(sc, port);
    store_jump_info(sc);
    set_jump_info(sc, Read_Set_Jump);
    if (jump_loc != No_Jump)
      {
	if (jump_loc != Error_Jump)
	  eval(sc, sc->cur_op);
      }
    else
      {
	push_stack_no_let_no_code(sc, OP_BARRIER, port);
	push_stack_direct(sc, OP_EVAL_DONE);
	eval(sc, OP_READ_INTERNAL);
	if (sc->tok == Token_Eof)
	  sc->value = eof_object;
	if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */
	    (stack_top_op(sc) == OP_BARRIER))
	  pop_stack(sc);
      }
    pop_input_port(sc);
    set_curlet(sc, old_let);
    restore_jump_info(sc);
    return(sc->value);
  }
}

static s7_pointer g_read(s7_scheme *sc, s7_pointer args)
{
  #define H_read "(read (port (current-input-port))) returns the next object in the input port, or #<eof> at the end"
  #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)

  s7_pointer port;
  if (is_pair(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(eof_object);
    }
  if (!is_input_port(port))
    return(method_or_bust_p(sc, port, sc->read_symbol, An_Input_Port_String));

  if (is_function_port(port))
    {
      const s7_pointer result = (*(port_input_function(port)))(sc, S7_READ, port);
      if (is_multiple_value(result))
	{
	  clear_multiple_value(result);
	  error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), result));
	}
      return(result);
    }
  if ((is_string_port(port)) &&
      (port_data_size(port) <= port_position(port)))
    return(eof_object);

  push_input_port(sc, port);
  push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */
  push_stack_op_let(sc, OP_READ_INTERNAL);
  return(port);
}


/* -------------------------------- load -------------------------------- */
#if With_Multithread_Checks
typedef struct {
  s7_scheme* sc;
  const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing */
} lock_scope_t;

static lock_scope_t enter_lock_scope(s7_scheme *sc)
{
  const int32_t result = pthread_mutex_trylock(&sc->lock);
  if (result != 0)
    {fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", result, EBUSY); abort();}
  sc->lock_count++;
  {
    lock_scope_t st = {.sc = sc, .lock_count = sc->lock_count};
    return(st);
  }
}

static void leave_lock_scope(lock_scope_t *st)
{
  while (st->sc->lock_count > st->lock_count)
    {
      st->sc->lock_count--;
      pthread_mutex_unlock(&st->sc->lock);
    }
}

#define Track(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc)
#else
#define Track(Sc)
#endif

/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */

static block_t *search_load_path(s7_scheme *sc, const char *name)
{
  const s7_pointer lst = s7_load_path(sc);
  if (is_pair(lst))
    {
#if MS_Windows || defined(__linux__)
      #define s7_Filename_Max 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */
#else
      #define s7_Filename_Max 1024
#endif
      /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */
      block_t *b = mallocate(sc, s7_Filename_Max);
      char *filename = (char *)block_data(b);
      const s7_int name_len = safe_strlen(name);
      for (s7_pointer dir_names = lst; is_pair(dir_names); dir_names = cdr(dir_names))
	{
	  const char *new_dir = string_value(car(dir_names));
	  if (new_dir)
	    {
	      if ((With_Warnings) && (string_length(car(dir_names)) + name_len >= s7_Filename_Max))
		s7_warn(sc, s7_Warn_Bufsize, "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);
#if MS_Windows
	      if (_access(filename, 0) != -1)
		return(b);
#else
	      if (access(filename, F_OK) == 0)
		return(b);
#endif
	    }}
      liberate(sc, b);
    }
  return(NULL);
}

#if With_C_Loader
#include <dlfcn.h>

static block_t *full_filename(s7_scheme *sc, const char *filename)
{
  char *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, s7_Warn_Bufsize, "getcwd: %s\n", strerror(errno));
          memcpy((void *)new_name, (const void *)filename, filename_len);
          new_name[filename_len] = '\0';
	}}
  return(block);
}

static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointer let)
{
  /* if fname ends in .so|.dylib, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */
  const s7_int fname_len = safe_strlen(fname);
  if (((fname_len > 3) &&
       (local_strcmp((const char *)(fname + (fname_len - 3)), ".so"))) ||   /* linux */
      ((fname_len > 6) &&
       (local_strcmp((const char *)(fname + (fname_len - 3)), ".dylib"))))  /* mac */
    {
      void *library;
      char *pwd_name = NULL;
      block_t *pname = NULL;

      if ((access(fname, F_OK) == 0) || (fname[0] == '/'))
	{
	  pname = full_filename(sc, fname);
	  pwd_name = (char *)block_data(pname);
	}
      else
	{
	  block_t *searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */
	  if (searched)
	    {
	      if (((const char *)block_data(searched))[0] == '/')
		pname = searched;
	      else
		{ /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */
		  pname = full_filename(sc, (const char *)block_data(searched));
		  liberate(sc, searched);
		}
	      pwd_name = (char *)block_data(pname);
	    }
	  else /* perhaps no *load-path* entries */
	    {
	      pname = full_filename(sc, fname);
	      pwd_name = (char *)block_data(pname);
	    }}
      if ((s7_Debugging) && (!pname)) fprintf(stderr, "%s[%d]: pname is null\n", __func__, __LINE__);
      library = dlopen((pname) ? pwd_name : fname, RTLD_NOW);
      if (!library)
	s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror());
      else
	if (let) /* look for 'init_func in let -- let has been checked by caller that it actually is a let */
	  {
	    const s7_pointer init = let_ref_p_pp(sc, let, make_symbol(sc, "init_func", 9));
	    /* init is a symbol (surely not a gensym?), so it should not need to be protected */
	    if (!is_symbol(init))
	      s7_warn(sc, 512, "can't load %s: no init function\n", fname);
	    else
	      {
		const char *init_name;
		void *init_func;

		if (hook_has_functions(sc->load_hook))
		  s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (pname) ? (const char *)pwd_name : fname)));

		init_name = symbol_name(init);
		init_func = dlsym(library, init_name);
		if (init_func)
		  {
		    typedef void (*dl_func)(s7_scheme *sc);
		    typedef s7_pointer (*dl_func_with_args)(s7_scheme *sc, s7_pointer args);
		    const s7_pointer init_args = let_ref_p_pp(sc, let, make_symbol(sc, "init_args", 9));
		    s7_pointer result;
		    gc_protect_via_stack(sc, init_args);
		    if (is_pair(init_args))
		      {
			result = ((dl_func_with_args)init_func)(sc, init_args);
			set_gc_protected2(sc, result);
		      }
		    /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok,
		     *   but the returned value is whatever was last computed in the init_func.
		     */
		    else
		      {
			/* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when
			 *   init_func accesses the forgotten args. s7_is_valid can't catch this currently --
			 *   we need a better way to tell that a random value can't be an s7_cell pointer (scan permallocs and use heap_location?)
			 */
			((dl_func)init_func)(sc);
			result = sc->F;
		      }
		    unstack_gc_protect(sc);
		    if (pname) liberate(sc, pname);
		    return(result);
		  }
		s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n",
			fname, init_name, dlerror(), display(let));
		dlclose(library);
	      }
	    if (s7_Debugging) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init));
	    if (pname) liberate(sc, pname);
	    return(sc->undefined);
	  }
      if (pname) liberate(sc, pname);
    }
  return(NULL);
}
#endif

static s7_pointer load_file_1(s7_scheme *sc, const char *filename)
{
  char *local_file_name = NULL;
  FILE* fp = fopen(filename, "r");
#if WITH_GCC
  if (!fp) /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */
    {
      block_t *b = expand_filename(sc, s7_make_string(sc, filename));
      if (b)
	{
	  fp = fopen((char *)block_data(b), "r");
	  if (fp) local_file_name = copy_string((char *)block_data(b));
	  liberate(sc, b);
	}}
#endif
  if (!fp)
    {
      const char *fname;
      block_t *b = search_load_path(sc, filename);
      if (!b) return(NULL);
      fname = (const char *)block_data(b);
      fp = fopen(fname, "r");
      if (fp) local_file_name = copy_string_with_length(fname, safe_strlen(fname));
      liberate(sc, b);
    }
  if (fp)
    {
      s7_pointer port;
      if (hook_has_functions(sc->load_hook))
	s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (local_file_name) ? local_file_name : filename)));
      port = read_file(sc, fp, (local_file_name) ? local_file_name : filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */
      port_file_number(port) = remember_file_name(sc, (local_file_name) ? local_file_name : filename);
      if (local_file_name) free(local_file_name);
      set_loader_port(port);
      push_input_port(sc, port);
      return(port);
    }
  return(NULL);
}

s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer 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, s7_Warn_Bufsize, "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);

  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);

  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
  return(sc->value);
}

s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->rootlet));}

s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer 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))

  const s7_pointer name = car(args);
  const char *fname;

  if (!is_string(name))
    return(method_or_bust(sc, name, sc->load_symbol, args, sc->type_names[T_STRING], 1));
  if (is_pair(cdr(args)))
    {
      s7_pointer 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);

  push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF);  /* was pushing args and code, but I don't think they're used later */
  push_stack_op_let(sc, OP_READ_INTERNAL);
  return(sc->unspecified);
}


/* -------- *load-path* -------- */
s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_local_value(sc, sc->load_path_symbol, sc->curlet));}

s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir)
{
  s7_pointer slot = lookup_slot_from(sc->load_path_symbol, sc->curlet); /* rootlet possible here */
  s7_pointer path = cons(sc, s7_make_string(sc, dir), slot_value(slot));
  slot_set_value(slot, path);
  return(path);
}

static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args)
{
  /* new value must be either () or a (proper?) list of strings */
  s7_pointer strs;
  if (is_null(cadr(args))) return(cadr(args));
  if (!is_pair(cadr(args)))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args)));
  for (strs = cadr(args); is_pair(strs); strs = cdr(strs))
    if (!is_string(car(strs)))
      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "can't set *load-path* to ~S, ~S is not a string", 47), cadr(args), car(strs)));
  if ((s7_Debugging) && (!is_null(strs))) fprintf(stderr, "%s[%d]: strs: %s\n", __func__, __LINE__, display(args));
  return(cadr(args));
}

/* -------- *cload-directory* -------- */
static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args)
{
  /* this sets the directory for cload.scm's output */
  const s7_pointer cl_dir = cadr(args);
  if (!is_string(cl_dir))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *cload-directory* to ~S", 33), cadr(args)));
  s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir);
  if (string_length(cl_dir) > 0) /* was strlen(string_value)? */
    s7_add_to_load_path(sc, (const char *)(string_value(cl_dir)));
  /* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */
  return(cl_dir);
}


/* ---------------- autoload ---------------- */
#define Initial_Autoload_Names_Size 4

void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size)
{
  /* names should be sorted alphabetically by the symbol name (the even indexes in the names array)
   *   size is the number of symbol names (half the size of the names array(
   * the idea here is that by sticking to string constants we can handle 90% of the work at compile-time,
   *   with less start-up memory.  Then eventually we'll add C libraries and every name in those libraries
   *   will come as an import once dlopen has picked up the library.
   */
  if (sc->safety > Immutable_Vector_Safety)
    for (int32_t i = 0, k = 2; k < (size * 2); i += 2, k += 2)
      if ((names[i]) && (names[k]) && (strcmp(names[i], names[k]) > 0))
	{
	  s7_warn(sc, s7_Warn_Bufsize, "%s: names[%d]: %s is out of order\n", __func__, k, names[k]);
	  break;
	}
  if (!sc->autoload_names)
    {
      sc->autoload_names = (const char ***)Calloc(Initial_Autoload_Names_Size, sizeof(const char **));
      sc->autoload_names_sizes = (s7_int *)Calloc(Initial_Autoload_Names_Size, sizeof(s7_int));
      sc->autoloaded_already = (bool **)Calloc(Initial_Autoload_Names_Size, sizeof(bool *));
      sc->autoload_names_top = Initial_Autoload_Names_Size;
      sc->autoload_names_loc = 0;
    }
  else
    if (sc->autoload_names_loc >= sc->autoload_names_top)
      {
	sc->autoload_names_top *= 2;
	sc->autoload_names = (const char ***)Realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **));
	sc->autoload_names_sizes = (s7_int *)Realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(s7_int));
	sc->autoloaded_already = (bool **)Realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *));
	for (s7_int i = sc->autoload_names_loc; i < sc->autoload_names_top; i++)
	  {
	    sc->autoload_names[i] = NULL;
	    sc->autoload_names_sizes[i] = 0;
	    sc->autoloaded_already[i] = NULL;
	  }}
  sc->autoload_names[sc->autoload_names_loc] = names;
  sc->autoload_names_sizes[sc->autoload_names_loc] = size;
  sc->autoloaded_already[sc->autoload_names_loc] = (bool *)Calloc(size, sizeof(bool));
  sc->autoload_names_loc++;
}

static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading)
{
  const s7_int libs = sc->autoload_names_loc;
  const char *name = symbol_name(symbol);
  for (s7_int lib = 0, l = 0; lib < libs; lib++)
    {
      s7_int u = sc->autoload_names_sizes[lib] - 1;
      const char **names = sc->autoload_names[lib];
      while (true)
	{
	  s7_int comp, pos;
	  const char *this_name;
	  if (u < l) break;
	  pos = (l + u) / 2;
	  this_name = names[pos * 2];
	  comp = strcmp(this_name, name);
	  if (comp == 0)
	    {
	      *already_loaded = sc->autoloaded_already[lib][pos];
	      if (loading) sc->autoloaded_already[lib][pos] = true;
	      return(names[pos * 2 + 1]);   /* file name given func name */
	    }
	  if (comp < 0)
	    l = pos + 1;
	  else u = pos - 1;
	}}
  return(NULL);
}

s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function)
{
  /* add '(symbol . file) to s7's autoload table */
  if (is_null(sc->autoload_table))
    sc->autoload_table = s7_make_hash_table(sc, 32); /* add_hash_table here, perhaps sc->hash_tables->loc-- */
  if (sc->safety >= More_Safety_Warnings)
    {
      s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol);
      if ((p != missing_key_value(sc)) && (p != file_or_function))
	s7_warn(sc, s7_Warn_Bufsize, "'%s autoload value changed\n", symbol_name(symbol));
    }
  s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function);
  return(file_or_function);
}

static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args)
{
  #define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \
If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \
the function.  The function takes one argument, the calling environment.  Presumably the symbol is defined \
in the file, or by the function."
  #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T)

  s7_pointer sym = car(args), value;
  if (is_string(sym))
    {
      if (string_length(sym) == 0)                   /* (autoload "" ...) */
	wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25));
      sym = make_symbol(sc, string_value(sym), string_length(sym));
    }
  if (!is_symbol(sym))
    {
      if_method_exists_return_value(sc, sym, sc->autoload_symbol, args);
      wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a string (symbol-name) or a symbol", 34));
    }
  if (is_keyword(sym))
    wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a normal symbol (a keyword is never unbound)", 44));

  value = cadr(args);
  if (is_string(value))
    return(s7_autoload(sc, sym, s7_set_immutable(sc, make_string_with_length(sc, string_value(value), string_length(value))))); /* s7_set_immutable to pass arg through */
  if (((is_closure(value)) || (is_closure_star(value))) &&
      (s7_is_aritable(sc, value, 1)))
    return(s7_autoload(sc, sym, value));

  if_method_exists_return_value(sc, value, sc->autoload_symbol, args);
  wrong_type_error_nr(sc, sc->autoload_symbol, 2, value, wrap_string(sc, "a string (file-name) or a thunk", 31));
#ifdef __TINYC__
  return(NULL); /* make tcc happy */
#endif
}


/* -------------------------------- *autoload* -------------------------------- */
static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */
{
  #define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f."
  #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)

  const s7_pointer sym = car(args);
  if (!is_symbol(sym))
    {
      if_method_exists_return_value(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym));
      wrong_type_error_nr(sc, wrap_string(sc, "*autoload*", 10), 1, sym, sc->type_names[T_SYMBOL]);
    }
  if (sc->autoload_names)
    {
      bool loaded = false;
      const char *file = find_autoload_name(sc, sym, &loaded, false);
      if (file)
	return(s7_make_string(sc, file));
    }
  if (is_hash_table(sc->autoload_table))
    {
      s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym);
      if (val != missing_key_value(sc)) return(val);
    }
  return(sc->F);
}


/* ---------------- require ---------------- */
static bool is_a_feature(const s7_pointer sym, s7_pointer lst) /* used only with *features* which (sigh) can be circular: (set-cdr! *features* *features*) */
{
  s7_pointer p = lst, slow = lst;
  while (true)
    {
      if (!is_pair(p)) return(false);
      if (sym == car(p)) return(true);
      p = cdr(p);
      if (!is_pair(p)) return(false);
      if (sym == car(p)) return(true);
      p = cdr(p);
      slow = cdr(slow);
      if (p == slow) return(false);
    }
  return(false);
}

static s7_pointer g_require(s7_scheme *sc, s7_pointer args)
{
  #define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\
The symbols refer to the argument to \"provide\".  (require lint.scm)"
  /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */

  gc_protect_via_stack(sc, args);
  for (s7_pointer syms = args; is_pair(syms); syms = cdr(syms))
    {
      s7_pointer sym;
      if (is_symbol(car(syms)))
	sym = car(syms);
      else
	if ((is_proper_quote(sc, car(syms))) &&
	    (is_symbol(cadar(syms))))
	  sym = cadar(syms);
	else
	  {
	    unstack_gc_protect(sc);
	    error_nr(sc, sc->wrong_type_arg_symbol,
		     set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(syms)));
	  }
      if (!is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol)))  /* if on *features* it's already loaded */
	{
	 if (sc->is_autoloading)
	   {
	     const s7_pointer func = g_autoloader(sc, set_plist_1(sc, sym));
	     if (is_false(sc, func))
	       {
		 unstack_gc_protect(sc);
		 error_nr(sc, sc->autoload_error_symbol,
			  set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym));
	       }
	     if (hook_has_functions(sc->autoload_hook))
	       s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, func));
	     if (is_string(func))
	       s7_load_with_environment(sc, string_value(func), sc->curlet);
	     else
	       if (is_closure(func))   /* func should be a function of one argument, the current (calling) environment */
		 s7_call(sc, func, set_ulist_1(sc, sc->curlet, sc->nil));
	   }
	 else s7_warn(sc, s7_Warn_Bufsize, "require: can't load %s because (*s7* 'autoloading?) is #f\n", symbol_name(sym));
	}}
  if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* op_error_quit if load failed in scheme in Snd */
  return(sc->T);
}


/* ---------------- provided? ---------------- */
static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args)
{
  #define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list"
  #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol)

  const s7_pointer sym = car(args);
  s7_pointer topf, 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_slot_checked(slot); slot = next_slot(slot))
      if ((slot_symbol(slot) == sc->features_symbol) &&
	  (slot_value(slot) != topf) &&
	  (is_a_feature(sym, slot_value(slot))))
	return(sc->T);
  return(sc->F);
}

bool s7_is_provided(s7_scheme *sc, const char *feature)
{
  return(is_a_feature(make_symbol_with_strlen(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */
}

static bool is_provided_b_7p(s7_scheme *sc, s7_pointer sym)
{
  if (!is_symbol(sym))
    return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]) != sc->F);
  return(is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol)));
}


/* ---------------- provide ---------------- */
static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym)
{
  /* this has to be relative to the curlet: (load file 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, s7_Warn_Bufsize, "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);
	  set_slot_has_setter(slot);
	}
      else
	if ((!is_a_feature(sym, lst)) && (!is_a_feature(sym, slot_value(features))))
	  slot_set_value(features, cons(sc, sym, slot_value(features)));
    }
  return(sym);
}

static s7_pointer g_provide(s7_scheme *sc, s7_pointer args)
{
  #define H_provide "(provide symbol) adds symbol to the *features* list"
  #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol)

  if ((is_immutable(sc->curlet)) &&
      (sc->curlet != sc->nil))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't provide '~S (current environment is immutable)", 52), car(args)));
  return(c_provide(sc, car(args)));
}

void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));}


static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args) /* *features* setter */
{
  const s7_pointer new_features = cadr(args);
  if (is_null(new_features)) return(sc->nil);
  if (!is_pair(new_features))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S (*features* must be a pair)", 54), new_features));
  if (s7_list_length(sc, new_features) <= 0)
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "can't set *features* to an improper or circular list ~S", 55), new_features));
  for (s7_pointer features = new_features; is_pair(features); features = cdr(features))
    if (!is_symbol(car(features)))
      error_nr(sc, sc->wrong_type_arg_symbol,
	       set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S (each feature should be a symbol)", 60), new_features));
  return(new_features);
}

static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* setter */
{
  const s7_pointer new_libraries = cadr(args);
  if (is_null(new_libraries)) return(sc->nil);
  if ((!is_pair(new_libraries)) || (s7_list_length(sc, new_libraries) <= 0))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *libraries* to ~S", 27), new_libraries));
  for (s7_pointer libraries = new_libraries; is_pair(libraries); libraries = cdr(libraries))
    if ((!is_pair(car(libraries))) ||
	(!is_string(caar(libraries))) ||
	(!is_let(cdar(libraries))))
      sole_arg_wrong_type_error_nr(sc, sc->libraries_symbol, car(libraries), wrap_string(sc, "a list of conses of the form (string . let)", 43));
  return(new_libraries);
}


/* -------------------------------- eval-string -------------------------------- */
s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer 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->rootlet));} /* was sc->nil, 11-Oct-25 */

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 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 (Eval_Print) 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); /* #<unused> here is a marker (needed) */
  push_stack(sc, OP_APPLY, list_1(sc, port), proc);
  return(sc->F);
}

static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it"
  #define Q_call_with_input_string sc->pl_sf
  /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */

  const s7_pointer str = car(args), proc = cadr(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->call_with_input_string_symbol, args, sc->type_names[T_STRING], 1));
  if (!is_procedure(proc))
    if_method_exists_return_value(sc, proc, sc->call_with_input_string_symbol, args);
  if (!s7_is_aritable(sc, proc, 1))
    wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc,
			wrap_string(sc, "a procedure of one argument (the port)", 38));
  if ((is_continuation(proc)) || (is_goto(proc)))
    wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, A_Normal_Procedure_String);
  return(call_with_input(sc, open_and_protect_input_string(sc, str), args));
}


/* -------------------------------- call-with-input-file -------------------------------- */
static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument"
  #define Q_call_with_input_file sc->pl_sf

  const s7_pointer str = car(args), proc = cadr(args);
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->call_with_input_file_symbol, args, sc->type_names[T_STRING], 1));
  if (!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, 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, #<eof>, is untyped but should be a thunk"
   *   (with-input-from-string "" (read-line)) -> hangs awaiting stdin input
   * also this can't be split into wifs and wifs_read because we need the runtime value of 'read
   */
  return(with_input(sc, open_and_protect_input_string(sc, str), args));
}


/* -------------------------------- with-input-from-file -------------------------------- */
static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args)
{
  #define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk"
  #define Q_with_input_from_file sc->pl_sf

  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, 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, 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, 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, set_mlist_2(sc, let, sc->value)); /* was list_2 20-Nov-25 */
    }
  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);
}

static void op_call_with_output_string(s7_scheme *sc)
{
  s7_pointer port = s7_open_output_string(sc);
  push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port);
  set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port));
  push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port);
  sc->code = opt2_pair(sc->code);
}


/* -------------------------------- iterators -------------------------------- */
#if s7_Debugging
static s7_pointer titr_let(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line)
{
  if (!is_let(iterator_sequence(iter)))
    {
      fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n",
	      Bold_Text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), Unbold_Text);
      abort();
    }
  return(iter);
}

static s7_pointer titr_pair(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line)
{
  if (!is_pair(iterator_sequence(iter)))
    {
      fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n",
	      Bold_Text, func, line, checked_type_name(sc, type_unchecked(iterator_sequence(iter))), Unbold_Text);
      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);
      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);
      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);
      abort();
    }
  return(iter);
}
#endif


/* -------------------------------- iterator? -------------------------------- */
static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args)
{
  #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator."
  #define Q_is_iterator sc->pl_bt

  s7_pointer iter = car(args);
  if (is_iterator(iter)) return(sc->T);
  /* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */
  check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args);
}

bool s7_is_iterator(s7_pointer obj) {return(is_iterator(obj));}

static bool is_iterator_b_7p(s7_scheme *sc, s7_pointer obj) {return(g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);}


static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer 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 T_Iter_Ok I hope */
  return(iter);
}

static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer unused_iterator) {return(sc->iterator_at_end_value);}

static s7_pointer iterator_quit(s7_scheme *sc, s7_pointer iterator)
{
  iterator_next(iterator) = iterator_finished;
  clear_iter_ok(iterator);
  return(sc->iterator_at_end_value);
}

static s7_pointer let_iterate_uncarried(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer slot = let_iterator_slot(iterator);
  if (!is_slot_checked(slot))
    return(iterator_quit(sc, iterator));
  let_iterator_set_slot(iterator, next_slot(slot));
  return(cons(sc, slot_symbol(slot), slot_value(slot)));
}

static s7_pointer let_iterate_carried(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer result, slot = let_iterator_slot(iterator);
  if (!is_slot_checked(slot))
    return(iterator_quit(sc, iterator));
  let_iterator_set_slot(iterator, next_slot(slot));
  result = iterator_carrier(iterator);
  set_car(result, slot_symbol(slot));
  set_cdr(result, slot_value(slot));
  return(result);
}

static s7_pointer hash_entry_to_cons(s7_scheme *sc, hash_entry_t *entry, s7_pointer p)
{
  if (!p)
    return(cons(sc, hash_entry_key(entry), hash_entry_value(entry)));
  set_car(p, hash_entry_key(entry));
  set_cdr(p, hash_entry_value(entry));
  return(p);
}

static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer table;
  hash_entry_t **elements;
  hash_entry_t *lst = hash_iterator_entry(iterator);

  if (lst)
    {
      hash_iterator_entry(iterator) = hash_entry_next(lst);
      return(hash_entry_to_cons(sc, lst, iterator_carrier(iterator)));
    }
  table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */
  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));
}

static s7_pointer string_iterate(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(chars[(uint8_t)(string_value(iterator_sequence(iter))[iterator_position(iter)++])]);
  return(iterator_quit(sc, iter));
}

static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(small_int(byte_vector(iterator_sequence(iter), iterator_position(iter)++)));
  return(iterator_quit(sc, iter));
}

static s7_pointer float_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(make_real(sc, float_vector(iterator_sequence(iter), iterator_position(iter)++)));
  return(iterator_quit(sc, iter));
}

static s7_pointer float_vector_iterate_carried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    {
      set_real(iterator_carrier(iter), float_vector(iterator_sequence(iter), iterator_position(iter)++));
      return(iterator_carrier(iter));
    }
  clear_mutable_number(iterator_carrier(iter));
  return(iterator_quit(sc, iter));
}

static s7_pointer complex_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++)));
  return(iterator_quit(sc, iter));
}

static s7_pointer complex_vector_iterate_carried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    {
#if WITH_CLANG_PP
      return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++)));
#else
      set_a_bi(iterator_carrier(iter), complex_vector(iterator_sequence(iter), iterator_position(iter)++));
      return(iterator_carrier(iter));
#endif
    }
  clear_mutable_number(iterator_carrier(iter));
  return(iterator_quit(sc, iter));
}

static s7_pointer int_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(make_integer(sc, int_vector(iterator_sequence(iter), iterator_position(iter)++)));
  return(iterator_quit(sc, iter));
}

static s7_pointer int_vector_iterate_carried(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    {
      set_integer(iterator_carrier(iter), int_vector(iterator_sequence(iter), iterator_position(iter)++));
      return(iterator_carrier(iter));
    }
  clear_mutable_integer(iterator_carrier(iter));
  return(iterator_quit(sc, iter));
}

static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer iter)
{
  if (iterator_position(iter) < iterator_length(iter))
    return(vector_element(iterator_sequence(iter), iterator_position(iter)++));
  return(iterator_quit(sc, iter));
}

static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer iter)
{
  /* this can be confusing: below a hash-table is the "function", and a function is the "iterator" only because with-let exports +iterator+=#t -> infinite loop!
       (with-let
         (let ((+iterator+ #t))
           (lambda () #<eof>))    ; this works because a function has an associated let??  with-let first arg should be a let.
         (for-each
          (make-hash-table)       ; (hash-table) -- ((hash-table) ()) is #f (not an error)
             ;(vector 1)          ; error: vector-ref second argument, (), is nil but should be an integer
             ;(vector)            ; error: for-each first argument #() called with 1 argument?
             ;(list)              ; for-each first argument, (), is nil but should be a procedure or something applicable
          (lambda args args)      ; function as iterator because local +iterator+ above is #t, never returns #<eof> (always () because iterator func takes no args)
             ;(lambda (asd) ())   ; error: make-iterator argument, #<lambda (asd)>, is a function but should be a thunk
          ))
   * similarly:
       (with-let
         (let ((+documentation+ "hiho")) (curlet))
         (define (f) 1)                         ; (define (f) "a string" 1) would return doc as "a string"
         (display (documentation f)) (newline)) ; "hiho" -- should we block +documentation+ in with-let?
   */
  s7_pointer result = s7_call(sc, iterator_sequence(iter), sc->nil);
  /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */
  if (result == sc->iterator_at_end_value)
    {
      iterator_next(iter) = iterator_finished;
      clear_iter_ok(iter);
    }
  return(result);
}

static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer iter)
{
  s7_pointer result, p, cur;
  if (iterator_position(iter) >= iterator_length(iter))
    return(iterator_quit(sc, iter));
  p = iterator_sequence(iter);
  cur = iterator_carrier(iter);
  set_car(cur, p);
  set_cadr(cur, wrap_integer(sc, iterator_position(iter))); /* was make_integer 7-May-25, c_object_ref->c_object_getter is c_function in scheme? */
  result = (*(c_object_ref(sc, p)))(sc, cur);
  iterator_position(iter)++;
  if (result == sc->iterator_at_end_value)
    {
      iterator_next(iter) = iterator_finished;
      clear_iter_ok(iter);
    }
  return(result);
}

static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter);
static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer iter)
{
  s7_pointer result;
  if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter));
  result = car(iterator_current(iter));
  iterator_current(iter) = cdr(iterator_current(iter));
  if (iterator_current(iter) == pair_iterator_slow(iter))
    iterator_current(iter) = sc->nil;
  iterator_next(iter) = pair_iterate_1;
  return(result);
}

static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter)
{
  s7_pointer result;
  if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter));
  result = car(iterator_current(iter));
  iterator_current(iter) = cdr(iterator_current(iter));
  if (iterator_current(iter) == pair_iterator_slow(iter))
    iterator_current(iter) = sc->nil;
  else pair_iterator_set_slow(iter, cdr(pair_iterator_slow(iter)));
  iterator_next(iter) = pair_iterate;
  return(result);
}

static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer 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);
}


/* -------------------------------- make-iterator -------------------------------- */
static bool is_iterable_closure(s7_scheme *sc, s7_pointer x)
{
  s7_pointer iter;
  if (!is_thunk(sc, x))
    sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, x, A_Thunk_String);
  iter = funclet_entry(sc, x, sc->local_iterator_symbol);
  return((iter) && (iter != sc->F));
}

static s7_pointer starlet_make_iterator(s7_scheme *sc, s7_pointer iter);
static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj);

s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer 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 #()) -> #<iterator: vector>, so I guess () should also work */
      iterator_length(iter) = 0;
      iterator_next(iter) = iterator_finished;
      clear_iter_ok(iter);
      break;

    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      if (is_iterable_closure(sc, 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;

    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), #<eof> by default.  In some cases, \
the iterator either returns two values in a cons (if the sequence is a hash-table, the cons has the key and value), \
in others the iterator normally returns an s7_cell created for the value (for example, a float-vector stores data as \
doubles, but for each value, the iterator returns an s7 object).  To avoid all this allocation, 'carrier' can be a cons \
or #t; in the latter case s7 chooses an appropriate value."
  #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_pair_symbol))

  /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */
  const s7_pointer seq = car(args);
  const s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL;
  s7_pointer iter = s7_make_iterator(sc, seq);

  if (carrier)
    {
      /* no carrier needed if seq is t_vector, byte_vector, string, c-object, nil or list, else cons for hash/let,
       *   mutable int|float|complex if int|byte|float|complex-vector, but scheme code can't create a mutable number, so use #t as carrier arg.
       */
      if (carrier == sc->T)  /* #t = conjure up an appropriate carrier */
	{
	  switch (type(seq)) /* all types that have carriers use iterator_carrier */
	    {
	    case T_INT_VECTOR:
	      iterator_carrier(iter) = make_mutable_integer(sc, 0);
	      iterator_next(iter) = int_vector_iterate_carried;
	      break;
	    case T_FLOAT_VECTOR:
	      iterator_carrier(iter) = make_mutable_real(sc, 0.0);
	      iterator_next(iter) = float_vector_iterate_carried;
	      break;
	    case T_COMPLEX_VECTOR:
	      iterator_carrier(iter) = make_mutable_complex(sc, 0.0, 0.0);
	      iterator_next(iter) = complex_vector_iterate_carried;
	      break;
	    case T_HASH_TABLE:
	      iterator_carrier(iter) = cons(sc, sc->unused, sc->unused);
	      break;
	    case T_LET:
	      iterator_carrier(iter) = cons(sc, sc->unused, sc->unused);
	      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 ~A, not a hash-table or a let", 84),
				 carrier, seq, object_type_name(sc, seq)));
	  if (seq != sc->rootlet)
	    {
	      iterator_carrier(iter) = carrier;
	      if ((is_let(seq)) && (seq != sc->starlet))
		{
		  const s7_pointer func = find_make_iterator_method(sc, seq, iter); /* mock-hash-table for example */
		  if (func) iter = func;                                      /*   (iterate (make-iterator (mock-hash-table 'b 2) (list #f))) */
		  if (iterator_next(iter) == let_iterate_uncarried)
		    iterator_next(iter) = let_iterate_carried;
		  else
		    if (!iterator_carrier(iter))
		      return(iter); /* don't set has_carrier because GC will segfault upon gc_mark(iterator_carrier(iter)) */
		}
	      set_has_carrier(iter);
	    }}}
  return(iter);
}


/* -------------------------------- iterate -------------------------------- */
static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args)
{
  #define H_iterate "(iterate obj) returns the next element from the iterator obj, or (*s7* 'iterator-at-end-value), #<eof> 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 -------------------------------- */
static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args)
{
  #define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing."
  #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol)
  s7_pointer iter = car(args);
  if (!is_iterator(iter))
    return(sole_arg_method_or_bust(sc, iter, sc->iterator_sequence_symbol, args, sc->type_names[T_ITERATOR]));
  return(iterator_sequence(iter));
}

/* iterator-length and iterator-position run up against the function iterator */


/* -------- cycles -------- */

#define Initial_Shared_Info_Size 8

static int32_t shared_ref(shared_info_t *ci, const s7_pointer p)
{
  /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */
  s7_pointer *objs = ci->objs;
  for (int32_t i = 0; i < ci->top; i++)
    if (objs[i] == p)
      {
	int32_t val = ci->refs[i];
	if (val > 0)
	  ci->refs[i] = -ci->refs[i];
	return(val);
      }
  return(0);
}

static void flip_ref(shared_info_t *ci, const s7_pointer p)
{
  s7_pointer *objs = ci->objs;
  for (int32_t i = 0; i < ci->top; i++)
    if (objs[i] == p)
      {
	ci->refs[i] = -ci->refs[i];
	break;
      }
}

static int32_t peek_shared_ref_1(shared_info_t *ci, const s7_pointer p)
{
  /* returns 0 if not found, otherwise the ref value for p */
  s7_pointer *objs = ci->objs;
  for (int32_t i = 0; i < ci->top; i++)
    if (objs[i] == p)
      return(ci->refs[i]);
  return(0);
}

static int32_t peek_shared_ref(shared_info_t *ci, s7_pointer p)
{
  /* returns 0 if not found, otherwise the ref value for p */
  return((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0);
}

static void enlarge_shared_info(shared_info_t *ci)
{
  ci->size *= 2;
  ci->size2 = ci->size - 2;
  ci->objs = (s7_pointer *)Realloc(ci->objs, ci->size * sizeof(s7_pointer));
  ci->refs = (int32_t *)Realloc(ci->refs, ci->size * sizeof(int32_t));
  ci->defined = (bool *)Realloc(ci->defined, ci->size * sizeof(bool));
  /* this clearing is needed, memclr is not faster */
  for (int32_t i = ci->top; i < ci->size; i++)
    {
      ci->refs[i] = 0;
      ci->objs[i] = NULL;
    }
}

static bool check_collected(s7_pointer top, shared_info_t *ci)
{
  const s7_pointer *objs_end = (s7_pointer *)(ci->objs + ci->top);
  for (s7_pointer *p = ci->objs; p < objs_end; p++)
    if ((*p) == top)
      {
	const int32_t i = (int32_t)(p - ci->objs);
	if (ci->refs[i] == 0)
	  {
	    ci->has_hits = true;
	    ci->refs[i] = ++ci->ref;  /* if found, set the ref number */
	  }
	break;
      }
  set_cyclic(top);
  return(true);
}

static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length);
static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash);

static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length)
{
  s7_int plen;
  bool cyclic = false;

  if (stop_at_print_length)
    {
      plen = sc->print_length;
      if (plen > vector_length(top))
	plen = vector_length(top);
    }
  else plen = vector_length(top);
  for (s7_int i = 0; i < plen; i++)
    {
      const s7_pointer vel = vector_element_unchecked(top, i);   /* "unchecked" because top might be rootlet, I think */
      if ((has_structure(vel)) &&
	  (collect_shared_info(sc, ci, vel, stop_at_print_length)))
	{
	  set_cyclic(vel);
	  cyclic = true;
	  if ((is_c_pointer(vel)) ||
	      (is_iterator(vel)) ||
	      (is_c_object(vel)))
	    check_collected(top, ci);
	}}
  if (cyclic) set_cyclic(top);
  return(cyclic);
}

static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length)
{
  /* look for top in current list.
   * As we collect objects (guaranteed to have structure) we set the collected bit.  If we ever
   *   encounter an object with that bit on, we've seen it before so we have a possible cycle.
   *   Once the collection pass is done, we run through our list, and clear all these bits.
   * stop_at_print_length is only true when called in  load_shared_info in object_out_1 + :readable
   */
  bool top_cyclic;

  if (is_collected_or_shared(top))
    return((!is_shared(top)) && (check_collected(top, ci)));

  /* top not seen before -- add it to the list */
  set_collected(top);
  if (ci->top == ci->size)
    enlarge_shared_info(ci);
  ci->objs[ci->top++] = top;

  top_cyclic = false;
  /* now search the rest of this structure */
  if (is_pair(top))
    {
      s7_pointer p;
      if ((has_structure(car(top))) &&
	  (collect_shared_info(sc, ci, car(top), stop_at_print_length)))
	top_cyclic = true;

      for (p = cdr(top); is_pair(p); p = cdr(p))
	{
	  if (is_collected_or_shared(p))
	    {
	      set_cyclic(top);
	      set_cyclic(p);
	      if (!is_shared(p))
		return(check_collected(p, ci));
	      if (!top_cyclic)
		for (s7_pointer cp = top; cp != p; cp = cdr(cp)) set_shared(cp);
	      return(top_cyclic);
	    }
 	  set_collected(p);
	  if (ci->top == ci->size)
	    enlarge_shared_info(ci);
	  ci->objs[ci->top++] = p;
	  if ((has_structure(car(p))) &&
	      (collect_shared_info(sc, ci, car(p), stop_at_print_length)))
	    top_cyclic = true;
	}
      if ((has_structure(p)) &&
	  (collect_shared_info(sc, ci, p, stop_at_print_length)))
	{
	  set_cyclic(top);
	  return(true);
	}
      if (!top_cyclic)
	for (s7_pointer cp = top; is_pair(cp); cp = cdr(cp)) set_shared(cp);
      else set_cyclic(top);
      return(top_cyclic);
    }
  switch (type(top))
    {
    case T_VECTOR:
      if (collect_vector_info(sc, ci, top, stop_at_print_length))
	top_cyclic = true;
      break;

    case T_ITERATOR:
      if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */
	  (collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length)))
	{
	  if (peek_shared_ref(ci, iterator_sequence(top)) == 0)
	    check_collected(iterator_sequence(top), ci);
	  top_cyclic = true;
	}
      break;

    case T_HASH_TABLE:
      if (hash_table_entries(top) > 0)
	{
	  const s7_int len = (s7_int)hash_table_size(top);
	  hash_entry_t **entries = hash_table_elements(top);
	  const bool keys_safe = hash_keys_not_cyclic(sc, top);
	  for (s7_int i = 0; i < len; i++)
	    for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry))
	      {
		if ((!keys_safe) &&
		    (has_structure(hash_entry_key(entry))) &&
		    (collect_shared_info(sc, ci, hash_entry_key(entry), stop_at_print_length)))
		  top_cyclic = true;
		if ((has_structure(hash_entry_value(entry))) &&
		    (collect_shared_info(sc, ci, hash_entry_value(entry), stop_at_print_length)))
		  {
		    if ((is_c_pointer(hash_entry_value(entry))) ||
			(is_iterator(hash_entry_value(entry))) ||
			(is_c_object(hash_entry_value(entry))))
		      check_collected(top, ci);
		    top_cyclic = true;
		  }}}
      break;

    case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */
      if ((has_structure(slot_value(top))) &&
	  (collect_shared_info(sc, ci, slot_value(top), stop_at_print_length)))
	top_cyclic = true;
      break;

    case T_LET:
      if (top == sc->rootlet)
	{
	  if (collect_vector_info(sc, ci, top, stop_at_print_length))
	    top_cyclic = true;
	}
      else
	for (s7_pointer let = top; let; let = let_outlet(let))
	  for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
	    if ((has_structure(slot_value(slot))) &&
		(collect_shared_info(sc, ci, slot_value(slot), stop_at_print_length)))
	      {
		top_cyclic = true;
		if ((is_c_pointer(slot_value(slot))) ||
		    (is_iterator(slot_value(slot))) ||
		    (is_c_object(slot_value(slot))))
		  check_collected(top, ci);
	      }
      break;

    case T_CLOSURE: case T_CLOSURE_STAR:
      if (collect_shared_info(sc, ci, closure_body(top), stop_at_print_length))
	{
	  if (peek_shared_ref(ci, top) == 0)
	    check_collected(top, ci);
	  top_cyclic = true;
	}
      break;

    case T_C_POINTER:
      if ((has_structure(c_pointer_type(top))) &&
	  (collect_shared_info(sc, ci, c_pointer_type(top), stop_at_print_length)))
	{
	  if (peek_shared_ref(ci, c_pointer_type(top)) == 0)
	    check_collected(c_pointer_type(top), ci);
	  top_cyclic = true;
	}
      if ((has_structure(c_pointer_info(top))) &&
	  (collect_shared_info(sc, ci, c_pointer_info(top), stop_at_print_length)))
	{
	  if (peek_shared_ref(ci, c_pointer_info(top)) == 0)
	    check_collected(c_pointer_info(top), ci);
	  top_cyclic = true;
	}
      break;

    case T_C_OBJECT:
      if ((c_object_to_list(sc, top)) &&
	  (c_object_set(sc, top)) &&
	  (collect_shared_info(sc, ci, (*(c_object_to_list(sc, top)))(sc, set_plist_1(sc, top)), stop_at_print_length)))
	{
	  if (peek_shared_ref(ci, top) == 0)
	    check_collected(top, ci);
	  top_cyclic = true;
	}
      break;
    }
  if (!top_cyclic)
    set_shared(top);
  else set_cyclic(top);
  return(top_cyclic);
}

static shared_info_t *make_shared_info(s7_scheme *sc)
{
  shared_info_t *ci = (shared_info_t *)Calloc(1, sizeof(shared_info_t));
  ci->size = Initial_Shared_Info_Size;
  ci->size2 = ci->size - 2;
  ci->objs = (s7_pointer *)Malloc(ci->size * sizeof(s7_pointer));
  ci->refs = (int32_t *)Calloc(ci->size, sizeof(int32_t));   /* finder expects 0 = unseen previously */
  ci->defined = (bool *)Calloc(ci->size, sizeof(bool));
  ci->cycle_port = sc->F;
  ci->init_port = sc->F;
  return(ci);
}

static void free_shared_info(shared_info_t *ci)
{
  if (ci)
    {
      free(ci->objs);
      free(ci->refs);
      free(ci->defined);
      free(ci);
    }
}

static inline shared_info_t *clear_shared_info(shared_info_t *ci)
{
  if (ci->top > 0)
    {
      memclr((void *)(ci->refs), ci->top * sizeof(int32_t));
      memclr((void *)(ci->defined), ci->top * sizeof(bool));
      for (int32_t i = 0; i < ci->top; i++)
	clear_cyclic_bits(ci->objs[i]); /* Loop_4 is not faster */
      ci->top = 0;
    }
  ci->ref = 0;
  ci->has_hits = false;
  ci->ctr = 0;
  return(ci);
}

static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length, shared_info_t *ci)
{
  /* for the printer, here only if is_structure(top) and top is not sc->rootlet */
  bool no_problem = true;
  s7_int stop_len;

  /* check for simple cases first */
  if (is_pair(top))
    {
      s7_pointer p = top;
      if (stop_at_print_length)
	{
	  s7_pointer slow = top;
	  stop_len = sc->print_length;
	  for (s7_int k = 0; k < stop_len; k += 2)
	    {
	      if (!is_pair(p)) break;
	      if (has_structure(car(p))) {no_problem = false; break;}
	      p = cdr(p);
	      if (!is_pair(p)) break;
	      if (has_structure(car(p))) {no_problem = false; break;}
	      p = cdr(p);
	      slow = cdr(slow);
	      if (p == slow) {no_problem = false; break;}
	    }}
      else
	if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */
	  no_problem = false;
	else
	  for (; is_pair(p); p = cdr(p))
	    if (has_structure(car(p))) {no_problem = false; break;} /* perhaps (and (length > 0 via sequence_is_empty)) or vector typer etc */
      if ((no_problem) &&
	  (!is_null(p)) && (has_structure(p)))
	no_problem = false;
      if (no_problem) return(NULL);
    }
  else
    if (is_t_vector(top)) /* any other vector can't happen */
      {
	stop_len = vector_length(top);
	if ((stop_at_print_length) &&
	    (stop_len > sc->print_length))
	  stop_len = sc->print_length;
	for (s7_int k = 0; k < stop_len; k++)
	  if (has_structure(vector_element(top, k))) {no_problem = false; break;}
	if (no_problem) return(NULL);
      }

    else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */
      if ((is_let(top)) && (top != sc->rootlet))
	{
	  for (s7_pointer let = top; (no_problem) && (let); let = let_outlet(let))
	    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
	      if (has_structure(slot_value(slot))) /* slot_symbol need not be checked? */
		{no_problem = false; break;}
	  if (no_problem) return(NULL);
	}
      else
	if (is_hash_table(top))
	  {
	    hash_entry_t **entries = hash_table_elements(top);
	    const bool keys_safe = hash_keys_not_cyclic(sc, top);
	    if (hash_table_entries(top) == 0) return(NULL);
	    for (s7_int len = (s7_int)hash_table_size(top), i = 0; i < len; i++)
	      for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry))
		if (((!keys_safe) && (has_structure(hash_entry_key(entry)))) || (has_structure(hash_entry_value(entry))))
		  {no_problem = false; break;}
	    if (no_problem) return(NULL);
	  }

  if ((s7_Debugging) && (is_any_vector(top)) && (!is_t_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__);
  clear_shared_info(ci);
  {
    /* collect all pointers associated with top */
    const bool cyclic = collect_shared_info(sc, ci, top, stop_at_print_length);
    s7_pointer *ci_objs = ci->objs;
    int32_t *ci_refs = ci->refs;
    int32_t refs = 0;

    for (int32_t i = 0; i < ci->top; i++)
      clear_collected_and_shared(ci_objs[i]);
    if (!cyclic)
      return(NULL);
    if (!(ci->has_hits))
      return(NULL);

    /* find if any were referenced twice (once for just being there, so twice=shared)
     *   we know there's at least one such reference because has_hits is true.
     */
    for (int32_t i = 0; i < ci->top; i++)
      if (ci_refs[i] > 0)
	{
	  set_collected(ci_objs[i]);
	  if (i == refs)
	    refs++;
	  else
	    {
	      ci_objs[refs] = ci_objs[i];
	      ci_refs[refs++] = ci_refs[i];
	      ci_refs[i] = 0;
	      ci_objs[i] = NULL;
	    }}
    ci->top = refs;
    return(ci);
  }
}


/* -------------------------------- cyclic-sequences -------------------------------- */
static s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj)
{
  if (has_structure(obj))
    {
      shared_info_t *ci;
      if (has_active_methods(sc, obj))
	{
	  s7_pointer func = find_method_with_let(sc, obj, sc->cyclic_sequences_symbol);
	  if (func != sc->undefined)
	    return(s7_apply_function(sc, func, set_mlist_1(sc, obj)));
	}
      ci = (sc->object_out_locked) ? sc->circle_info : load_shared_info(sc, obj, false, sc->circle_info); /* false=don't stop at print length (vectors etc) */
      if (ci)
	{
	  check_free_heap_size(sc, ci->top);
	  begin_temp(sc->y, sc->nil);
	  for (int32_t i = 0; i < ci->top; i++)
	    sc->y = cons_unchecked(sc, ci->objs[i], sc->y);
	  return_with_end_temp(sc->y);
	}}
  return(sc->nil);
}

static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args)
{
  #define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic."
  #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T)
  return(cyclic_sequences_p_p(sc, car(args)));
}


/* -------------------------------- object->port (display format etc) -------------------------------- */
static int32_t circular_list_entries(s7_pointer lst)
{
  int32_t i = 1;
  for (s7_pointer p = cdr(lst); ; i++, p = cdr(p))
    {
      int32_t j = 0;
      for (s7_pointer y = lst; j < i; y = cdr(y), j++)
	if (p == y)
	  return(i);
    }
}

static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci);
#define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \
  do {								      \
    s7_pointer _V_ = Vr;						\
    if ((Ci) && (has_structure(_V_)))					\
      object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \
    else object_to_port(Sc, _V_, Port, Use_Write, Ci);			\
  } while (0)

#define Num_Display_Functions 256
static void (*display_functions[Num_Display_Functions])(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci);
#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[type_unchecked(Obj)])(Sc, Obj, Port, Use_Write, Ci)

static bool string_needs_slashification(const uint8_t *str, s7_int len)
{
  /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */
  for (const uint8_t *p = str, *pend = (const uint8_t *)(str + len); p < pend; p++)
    if (slashify_table[*p])
      return(true);
  return(false);
}

#define In_Quotes true
#define Not_In_Quotes false

static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char *p, s7_int len, bool quoted)
{
  const uint8_t *pcur, *pend, *pstart = NULL;
  if (len == 0)
    {
      if (quoted)
	port_write_string(port)(sc, "\"\"", 2, port);
      return;
    }
  pend = (const uint8_t *)(p + len);

  /* what about the trailing nulls? Guile writes them out (as does s7 currently)
   *    but that is not ideal.  I'd like to use ~S for error messages, so that
   *    strings are clearly identified via the double-quotes, but this way of
   *    writing them is ugly:
   *      (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00"
   *    but it would be misleading to omit them because:
   *      (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc"
   * also it is problematic to use sc->print_length here (rather than a separate string-print-length) because
   *    it is normally (say) 12 which truncates just about every string.  In CL, *print-length*
   *    does not affect strings, symbols, or bit-vectors.  But if the string is enormous,
   *    this function can bring us to a complete halt.  string-print-length (as a *s7* field) is
   *    also problematic -- it does not behave as expected in many cases if it is limited to this
   *    function and string_to_port below, and if set too low, disables the repl.
   */
  if (quoted) port_write_character(port)(sc, '"', port);
  for (pcur = (const uint8_t *)p; pcur < pend; pcur++)
    if (slashify_table[*pcur])
      {
	if (pstart) pstart++; else pstart = (const uint8_t *)p;
	if (pstart != pcur)
	  {
	    port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port);
	    pstart = pcur;
	  }
	port_write_character(port)(sc, '\\', port);
	switch (*pcur)
	  {
	  case '"':   port_write_character(port)(sc, '"', port);   break;
	  case '\\':  port_write_character(port)(sc, '\\', port);  break;
	  case '\'':  port_write_character(port)(sc, '\'', port);  break;
	  case '\t':  port_write_character(port)(sc, 't', port);   break;
	  case '\r':  port_write_character(port)(sc, 'r', port);   break;
          case '\n':  port_write_character(port)(sc, 'n', port);   break; /* added 17-Sep-25 for r7rs */
	  case '\b':  port_write_character(port)(sc, 'b', port);   break;
	  case '\f':  port_write_character(port)(sc, 'f', port);   break;
	  case '\?':  port_write_character(port)(sc, '?', port);   break;
	  case 'x':   port_write_character(port)(sc, 'x', port);   break;
	  default:
	    {
	      char buf[5];
	      s7_int n = (s7_int)(*pcur);
	      buf[0] = 'x';
	      buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16];
	      buf[2] = dignum[n % 16];
	      buf[3] = ';';
	      buf[4] = '\0';
	      port_write_string(port)(sc, buf, 4, port);
	    }
	    break;
	  }}
  if (!pstart)
    port_write_string(port)(sc, (const char *)p, len, port);
  else
    {
      pstart++;
      if (pstart != pcur)
	port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port);
    }
  if (quoted) port_write_character(port)(sc, '"', port);
}

static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if ((obj == sc->standard_output) || (obj == sc->standard_error))
    port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
  else
    if (use_write == p_Readable)
      {
	if (port_is_closed(obj))
	  port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port);
	else
	  if (is_string_port(obj))
	    {
	      port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port);
	      if (port_position(obj) > 0)
		{
		  port_write_string(port)(sc, " (display ", 10, port);
		  slashify_string_to_port(sc, port, (const char *)port_data(obj), port_position(obj), In_Quotes);
		  port_write_string(port)(sc, " p)", 3, port);
		}
	      port_write_string(port)(sc, " p)", 3, port);
	    }
	  else
	    if (is_file_port(obj))
	      {
		#define Cat_Bufsize 256
		char str[Cat_Bufsize];
		int32_t nlen;
		str[0] = '\0';
		nlen = (int32_t)catstrs(str, Cat_Bufsize, "(open-output-file \"", port_filename(obj), "\" \"a\")", (char *)NULL);
		port_write_string(port)(sc, str, nlen, port);
	      }
	    else port_write_string(port)(sc, "#<output-function-port>", 23, port);
      }
    else
      {
	if (is_string_port(obj))
	  port_write_string(port)(sc, "#<output-string-port", 20, port);
	else
	  if (is_file_port(obj))
	    port_write_string(port)(sc, "#<output-file-port", 18, port);
	  else port_write_string(port)(sc, "#<output-function-port", 22, port);
	if (port_is_closed(obj))
	  port_write_string(port)(sc, ":closed>", 8, port);
	else port_write_character(port)(sc, '>', port);
      }
}

static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (obj == sc->standard_input)
    port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
  else
    if (use_write == p_Readable)
      {
	if (port_is_closed(obj))
	  port_write_string(port)(sc, "(call-with-input-string \"\" (lambda (p) p))", 42, port);
	else
	  if (is_function_port(obj))
	    port_write_string(port)(sc, "#<input-function-port>", 22, port);
	  else
	    if (is_file_port(obj))
	      {
		#define P_Bufsize 256
		char str[P_Bufsize];
		int32_t nlen;
		str[0] = '\0';
		nlen = (int32_t)catstrs(str, P_Bufsize, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL);
		port_write_string(port)(sc, str, nlen, port);
	      }
	    else
	      {
		const s7_int data_len = port_data_size(obj) - port_position(obj);
		if (data_len > 100)
		  {
		    const char *filename = (const char *)s7_port_filename(sc, obj);
		    if (filename)
		      {
                        #define Do_Str_Len 1024
			char do_str[Do_Str_Len];
			int32_t len;
			do_str[0] = '\0';
			if (port_position(obj) > 0)
			  {
			    len = (int32_t)catstrs(do_str, Do_Str_Len, "(let ((port (open-input-file \"", filename, "\")))", (char *)NULL);
			    port_write_string(port)(sc, do_str, len, port);
			    do_str[0] = '\0';
			    len = (int32_t)catstrs(do_str, Do_Str_Len, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ",
						   pos_int_to_str_direct(sc, port_position(obj) - 1),
						   ") port)))", (char *)NULL);
			  }
			else len = (int32_t)catstrs(do_str, Do_Str_Len, "(open-input-file \"", filename, "\")", (char *)NULL);
			port_write_string(port)(sc, do_str, len, port);
			return;
		      }}
		port_write_string(port)(sc, "(open-input-string ", 19, port);
		/* not port_write_string here because there might be embedded double-quotes */
		slashify_string_to_port(sc, port, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), In_Quotes);
		port_write_character(port)(sc, ')', port);
	      }}
    else
      {
	if (is_string_port(obj))
	  port_write_string(port)(sc, "#<input-string-port", 19, port);
	else
	  if (is_file_port(obj))
	    port_write_string(port)(sc, "#<input-file-port", 17, port);
	  else port_write_string(port)(sc, "#<input-function-port", 21, port);
	if (port_filename(obj))
	  {
	    port_write_character(port)(sc, ' ', port);
	    if (use_write != p_Display) port_write_character(port)(sc, '"', port);
	    port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
	    if (use_write != p_Display) port_write_character(port)(sc, '"', port);
	  }
	if (port_is_closed(obj))
	  port_write_string(port)(sc, " :closed>", 9, port);
	else port_write_character(port)(sc, '>', port);
      }
}

static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj)
{
  uint8_t *pend;
  char *str = symbol_name(obj); /* not const for make_atom */

  if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ','))
    return(true);
  if (is_number(make_atom(sc, str, 10, No_Symbols, Without_Overflow_Error)))
    return(true);

  pend = (uint8_t *)(str + symbol_name_length(obj));
  for (uint8_t *p = (uint8_t *)str; p < pend; p++)
    if (symbol_slashify_table[*p])
      return(true);
  set_clean_symbol(obj);
  return(false);
}

static /* inline */ void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  /* I think this is the only place we print a symbol's name */
  if ((!is_clean_symbol(obj)) &&
      (symbol_needs_slashification(sc, obj)))
    {
      /* this can't work in general if use_write == p_Readable:
       *    (define f (apply lambda (list () (list 'let (list (list (symbol "a b") 3)) (symbol "a b"))))) ; (f) -> 3
       *  prints "readably" as "(lambda () (let (((symbol \"a b\") 3)) (symbol \"a b\")))"
       *  so, 30-May-24 added (*s7* 'symbol-printer).
       */
      if (is_any_procedure(sc->symbol_printer)) /* we see p_Write here */
	{
	  const s7_pointer printer = sc->symbol_printer;
	  s7_pointer result;
	  sc->symbol_printer = sc->F; /* avoid infinite recursion */
	  result = s7_call(sc, printer, set_plist_1(sc, obj));
	  if (!is_string(result))
	    error_nr(sc, sc->wrong_type_arg_symbol,
		     set_elist_2(sc, wrap_string(sc, "(*s7* 'symbol-printer) should return a string: ~S", 49), result));
	  /* if we restore symbol-printer before the error, and the printer function stupidly returned the bad symbol, infinite loop */
	  sc->symbol_printer = printer;
	  port_write_string(port)(sc, string_value(result), string_length(result), port);
	}
      else
	{
	  port_write_string(port)(sc, "(symbol \"", 9, port);
	  slashify_string_to_port(sc, port, symbol_name(obj), symbol_name_length(obj), Not_In_Quotes);
	  port_write_string(port)(sc, "\")", 2, port);
	}}
  else
    {
      char c = '\0';
      if ((use_write == p_Readable) || (use_write == p_Code))
	{
	  if (!is_keyword(obj)) c = '\'';
	}
      else if ((use_write == p_Key) && (!is_keyword(obj))) c = ':';
      if (is_string_port(port))
	{
	  const s7_int new_len = port_position(port) + symbol_name_length(obj) + ((c) ? 1 : 0);
	  if (new_len >= port_data_size(port))
	    resize_port_data(sc, port, new_len * 2);
	  if (c) port_data(port)[port_position(port)++] = c;
	  memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj));
	  port_position(port) = new_len;
	}
      else
	{
	  if (c) port_write_character(port)(sc, c, port);
	  port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port);
	}}
}

static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_pointer vect, char *str, int32_t str_len, int32_t cur_dim)
{
  s7_int size = vector_dimension(vect, cur_dim);
  s7_int ind = index % size;
  if (cur_dim > 0)
    multivector_indices_to_string(sc, (index - ind) / size, vect, str, str_len, cur_dim - 1);
  catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind), (char *)NULL);
  return(str);
}

#define not_p_display(Choice) ((Choice == p_Display) ? p_Write : Choice)

static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer port,
				     int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last,
				     use_write_t use_write, shared_info_t *ci)
{
  if (use_write != p_Readable)
    {
      if (*last)
	port_write_string(port)(sc, " (", 2, port);
      else port_write_character(port)(sc, '(', port);
      (*last) = false;
    }
  for (int32_t i = 0; i < vector_dimension(vec, dimension); i++)
    if (dimension == (dimensions - 1))
      {
	if (flat_ref < out_len)
	  {
	    object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, not_p_display(use_write), ci);
	    if (use_write == p_Readable)
	      port_write_string(port)(sc, ") ", 2, port);
	    flat_ref++;
	  }
	else
	  {
	    port_write_string(port)(sc, "...)", 4, port);
	    return(flat_ref);
	  }
	if ((use_write != p_Readable) &&
	    (i < (vector_dimension(vec, dimension) - 1)))
	  port_write_character(port)(sc, ' ', port);
      }
    else
      if (flat_ref < out_len)
	flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, not_p_display(use_write), ci);
      else
	{
	  port_write_string(port)(sc, "...)", 4, port);
	  return(flat_ref);
	}
  if (use_write != p_Readable)
    port_write_character(port)(sc, ')', port);
  (*last) = true;
  return(flat_ref);
}

static int32_t multivector_to_port(s7_scheme *sc, s7_pointer vec, s7_pointer port,
				   int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions,
				   use_write_t use_write, shared_info_t *ci)
{
  bool last = false;
  return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci));
}

#define Out_Bufsize 128

static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port)
{
  const char *vtyp = "";
  if (is_float_vector(vect))
    vtyp = "float-";
  else
    if (is_int_vector(vect))
      vtyp = "int-";
    else
      if (is_byte_vector(vect))
	vtyp = "byte-";
      else
	if (is_complex_vector(vect))
	  vtyp = "complex-";

  if (vector_rank(vect) == 1)
    {
      const s7_int vlen = vector_length(vect);
      char buf[Out_Bufsize];
      const int32_t plen = (int32_t)catstrs_direct(buf, "(make-", vtyp, "vector ", integer_to_string_no_length(sc, vlen), " ", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
    }
  else
    {
      char buf[Out_Bufsize];
      s7_int dim;
      int32_t plen = (int32_t)catstrs_direct(buf, "(make-", vtyp, "vector '(", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      for (dim = 0; dim < vector_ndims(vect) - 1; dim++)
	{
	  plen = (int32_t)catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL);
	  port_write_string(port)(sc, buf, plen, port);
	}
      plen = (int32_t)catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), ") ", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
    }
}

static void write_vector_dimensions(s7_scheme *sc, s7_pointer vect, s7_pointer port)
{
  char buf[Out_Bufsize];
  s7_int dim, plen;
  port_write_string(port)(sc, " '(", 3, port);
  for (dim = 0; dim < vector_ndims(vect) - 1; dim++)
    {
      plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
    }
  plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), "))", (const char *)NULL);
  port_write_string(port)(sc, buf, plen, port);
}

static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port);

static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  s7_int i, len = vector_length(vect), plen;
  bool too_long = false;
  #define Vp_Bufsize 2048
  char buf[Vp_Bufsize]; /* 128 is too small -- this is the list of indices with a few minor flourishes */

  if (len == 0)
    {
      if (vector_rank(vect) > 1)
	{
	  plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)NULL);
	  port_write_string(port)(sc, buf, plen, port);
	}
      else port_write_string(port)(sc, "#()", 3, port);
      return;
    }
  if (use_write != p_Readable)
    {
      if (sc->print_length == 0)
	{
	  if (vector_rank(vect) > 1)
	    {
	      plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  else port_write_string(port)(sc, "#(...)", 6, port);
	  return;
	}
      if (len > sc->print_length)
	{
	  too_long = true;
	  len = sc->print_length;
	}}
  if ((!ci) &&
      (len > 1000))
    {
      const s7_int vlen = vector_length(vect);
      s7_pointer *els = vector_elements(vect);
      const s7_pointer p0 = els[0];
      for (i = 1; i < vlen; i++)
	if (els[i] != p0)
	  break;
      if (i == vlen)
	{
	  make_vector_to_port(sc, vect, port);
	  object_to_port(sc, p0, port, use_write, NULL);
	  if (is_typed_vector(vect))
	    {
	      port_write_character(port)(sc, ' ', port);
	      port_write_vector_typer(sc, vect, port);
	    }
	  port_write_character(port)(sc, ')', port);
	  return;
	}}
  check_stack_size(sc);
  gc_protect_via_stack(sc, vect);
  if (use_write == p_Readable)
    {
      int32_t vref;
      if ((ci) &&
	  (is_cyclic(vect)) &&
	  ((vref = peek_shared_ref(ci, vect)) != 0))
	{
	  s7_pointer *els = vector_elements(vect);
	  if (vref < 0) vref = -vref;
	  if ((ci->defined[vref]) || (port == ci->cycle_port))
	    {
	      plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, vref), ">", (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	      unstack_gc_protect(sc);
	      return;
	    }

	  if (is_typed_vector(vect))
	    port_write_string(port)(sc, "(let ((<v> ", 11, port);
	  if (vector_rank(vect) > 1)
	    port_write_string(port)(sc, "(subvector ", 11, port);

	  port_write_string(port)(sc, "(vector", 7, port); /* top level let */
	  for (i = 0; i < len; i++)
	    if (has_structure(els[i]))
	      {
		int32_t eref = peek_shared_ref(ci, els[i]);
		port_write_string(port)(sc, " #f", 3, port);
		if (eref != 0)
		  {
		    if (eref < 0) eref = -eref;
		    if (vector_rank(vect) > 1)
		      {
			const s7_int dimension = vector_rank(vect) - 1;
			const int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16);
			block_t *b = callocate(sc, str_len);
			char *indices = (char *)block_data(b);
			multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */
			plen = catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, vref), ">",
					      indices, ") <", pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL);
			port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port);
			liberate(sc, b);
		      }
		    else
		      {
			size_t len1 = catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string(sc, i, &plen), ") <",
						     pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL);
			port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port);
		      }}
		else
		  {
		    if (vector_rank(vect) > 1)
		      {
			const s7_int dimension = vector_rank(vect) - 1;
			const int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16);
			block_t *b = callocate(sc, str_len);
			char *indices = (char *)block_data(b);
			buf[0] = '\0';
			multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */
			plen = catstrs(buf, Vp_Bufsize, "  (set! (<", pos_int_to_str_direct(sc, vref), ">", indices, ") ", (char *)NULL);
			port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port);
			liberate(sc, b);
		      }
		    else
		      {
			size_t len1 = catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string_no_length(sc, i), ") ", (const char *)NULL);
			port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port);
		      }
		    object_to_port_with_circle_check(sc, els[i], ci->cycle_port, p_Readable, ci);
		    port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
		  }}
	    else
	      {
		port_write_character(port)(sc, ' ', port);
		object_to_port_with_circle_check(sc, els[i], port, p_Readable, ci);
	      }
	  port_write_character(port)(sc, ')', port);
	  if (vector_rank(vect) > 1)
	    {
	      plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	      write_vector_dimensions(sc, vect, port);
	    }
	  if (is_typed_vector(vect))
	    {
	      port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port);
	      port_write_vector_typer(sc, vect, port);
	      port_write_string(port)(sc, ") <v>)", 6, port);
	    }}
      else
	{
	  if (is_typed_vector(vect))
	    port_write_string(port)(sc, "(let ((<v> ", 11, port);
	  /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let ((<v> (vector 'a 'a 'a))) (set! (vector-typer <v>) symbol?) <v>)" */

	  if (vector_rank(vect) > 1)
	    port_write_string(port)(sc, "(subvector ", 11, port);
	  if (is_immutable_vector(vect))
	    port_write_string(port)(sc, "(immutable! ", 12, port);

	  port_write_string(port)(sc, "(vector", 7, port);
	  for (i = 0; i < len; i++)
	    {
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, vector_element(vect, i), port, p_Readable, ci);
	    }

	  if (is_immutable_vector(vect))
	    port_write_string(port)(sc, "))", 2, port);
	  else port_write_character(port)(sc, ')', port);

	  if (vector_rank(vect) > 1)          /* subvector above */
	    {
	      plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	      write_vector_dimensions(sc, vect, port);
	    }
	  if (is_typed_vector(vect))
	    {
	      port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port);
	      port_write_vector_typer(sc, vect, port);
	      port_write_string(port)(sc, ") <v>)", 6, port);
	    }}}
  else /* not readable write */
    {
      if (vector_rank(vect) > 1) /* if rank>1, ndims exists */
	{
	  plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
	  port_write_string(port)(sc, buf, plen, port);
	  multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), use_write, ci);
	}
      else
	{
	  port_write_string(port)(sc, "#(", 2, port);
	  for (i = 0; i < len - 1; i++)
	    {
	      object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci);
	      port_write_character(port)(sc, ' ', port);
	    }
	  object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci);

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);
	}}
  unstack_gc_protect(sc);
}

static s7_int print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write)
{
  const s7_int len = vector_length(vect);
  const char *vtype = "r"; /* "const" here for g++ */

  if (is_int_vector(vect)) vtype = "i";
  else if (is_complex_vector(vect)) vtype = "c";
  else if (is_byte_vector(vect)) vtype = "u";
  if (len == 0)
    {
      char buf[Out_Bufsize];
      s7_int plen;
      if (vector_rank(vect) > 1)
	plen = (s7_int)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL);
      else plen = (s7_int)catstrs_direct(buf, "#", vtype, "()", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      return(-1);
    }
  if (use_write == p_Readable)
    return(len);
  if (sc->print_length != 0)
    return((len > sc->print_length) ? sc->print_length : len);

  if (vector_rank(vect) > 1)
    {
      char buf[Out_Bufsize];
      s7_int plen = (s7_int)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
    }
  else
    if (is_int_vector(vect))
      port_write_string(port)(sc, "#i(...)", 7, port);
    else
      if (is_float_vector(vect))
	port_write_string(port)(sc, "#r(...)", 7, port);
      else
	if (is_byte_vector(vect))
	  port_write_string(port)(sc, "#u(...)", 7, port);
	else port_write_string(port)(sc, "#c(...)", 7, port);
  return(-1);
}

static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  s7_int plen;
  bool too_long;
  char buf[Out_Bufsize];
  const char *str;
  const s7_int len = print_vector_length(sc, vect, port, use_write);
  if (len < 0) return; /* actually -1, see above -- this means there's nothing more to print */
  too_long = (len < vector_length(vect));

  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (len > 1000)
    {
      s7_int i;
      const s7_int vlen = vector_length(vect);
      const s7_int *els = int_vector_ints(vect);
      s7_int first = els[0];
      for (i = 1; i < vlen; i++)
	if (els[i] != first)
	  break;
      if (i == vlen)
	{
	  make_vector_to_port(sc, vect, port);
	  str = integer_to_string(sc, int_vector(vect, 0), &plen);
	  port_write_string(port)(sc, str, plen, port);
	  if ((use_write == p_Readable) &&
	      (is_immutable_vector(vect)))
	    port_write_string(port)(sc, "))", 2, port);
	  else port_write_character(port)(sc, ')', port);
	  return;
	}}
  if (vector_rank(vect) == 1)
    {
      port_write_string(port)(sc, "#i(", 3, port);
      if (!is_string_port(port))
	{
	  str = integer_to_string(sc, int_vector(vect, 0), &plen);
	  port_write_string(port)(sc, str, plen, port);
	  for (s7_int i = 1; i < len; i++)
	    {
	      plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	    }}
      else
	{
	  s7_int new_len = port_position(port);
	  s7_int next_len = port_data_size(port) - 128;
	  uint8_t *dbuf = port_data(port);
	  if (new_len >= next_len)
	    {
	      resize_port_data(sc, port, port_data_size(port) * 2);
	      next_len = port_data_size(port) - 128;
	      dbuf = port_data(port);
	    }
	  str = integer_to_string(sc, int_vector(vect, 0), &plen);
	  memcpy((void *)(dbuf + new_len), (const void *)str, plen);
	  new_len += plen;
	  for (s7_int i = 1; i < len; i++)
	    {
	      if (new_len >= next_len)
		{
		  resize_port_data(sc, port, port_data_size(port) * 2);
		  next_len = port_data_size(port) - 128;
		  dbuf = port_data(port);
		}
	      plen = catstrs_direct((char *)(dbuf + new_len), " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL);
	      new_len += plen;
	    }
	  port_position(port) = new_len;
	}
      if (too_long)
	port_write_string(port)(sc, " ...)", 5, port);
      else port_write_character(port)(sc, ')', port);
    }
  else
    {
      plen = catstrs_direct(buf, "#i", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      gc_protect_via_stack(sc, vect);
      multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_Display, NULL);
      unstack_gc_protect(sc);
    }
  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_character(port)(sc, ')', port);
}

static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  #define Fv_Bufsize 512 /* some floats can take around 312 bytes */
  char buf[Fv_Bufsize];
  s7_int plen;
  bool too_long;
  const s7_double *els = float_vector_floats(vect);
  const s7_int len = print_vector_length(sc, vect, port, use_write);
  if (len < 0) return;  /* vector-length=0 etc */
  too_long = (len < vector_length(vect));

  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (len > 1000)
    {
      s7_int i;
      const s7_int vlen = vector_length(vect);
      const s7_double first = els[0];
      for (i = 1; i < vlen; i++)
	if (els[i] != first)
	  break;
      if (i == vlen)
	{
	  make_vector_to_port(sc, vect, port);
	  plen = snprintf(buf, Fv_Bufsize, "%.*g)", sc->float_format_precision, first);
	  port_write_string(port)(sc, buf, clamp_length(plen, Fv_Bufsize), port);
	  if ((use_write == p_Readable) &&
	      (is_immutable_vector(vect)))
	    port_write_character(port)(sc, ')', port);
	  return;
	}}

  if (vector_rank(vect) == 1)
    {
      port_write_string(port)(sc, "#r(", 3, port);
      plen = snprintf(buf, Fv_Bufsize - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */
      floatify(buf, &plen);
      port_write_string(port)(sc, buf, clamp_length(plen, Fv_Bufsize), port);
      for (s7_int i = 1; i < len; i++)
	{
	  plen = snprintf(buf, Fv_Bufsize - 4, " %.*g", sc->float_format_precision, els[i]);
	  plen--; /* fixup for the initial #\space */
	  floatify((char *)(buf + 1), &plen);
	  port_write_string(port)(sc, buf, clamp_length(plen + 1, Fv_Bufsize), port);
	}
      if (too_long)
	port_write_string(port)(sc, " ...)", 5, port);
      else port_write_character(port)(sc, ')', port);
    }
  else
    {
      plen = catstrs_direct(buf, "#r", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      gc_protect_via_stack(sc, vect);
      multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_Display, NULL);
      unstack_gc_protect(sc);
    }
  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_character(port)(sc, ')', port);
}

static char *complex_to_string_base_10(s7_scheme *sc, s7_complex obj, s7_int width, s7_int precision,
				      char float_choice, s7_int *nlen, use_write_t choice)
{
  char *imag;
  s7_int len = width + precision;
  len = (len > 512) ? (512 + 2 * len) : 1024;
  if (len > sc->num_to_str_size)
    {
      sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len);
      sc->num_to_str_size = len;
    }
  sc->num_to_str[0] = '\0';
  imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, cimag(obj)), 0, precision, float_choice, &len, choice));
  sc->num_to_str[0] = '\0';
  number_to_string_base_10(sc, wrap_real(sc, creal(obj)), 0, precision, float_choice, &len, choice);
  sc->num_to_str[len] = '\0';
  len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL);
  free(imag);
  if (width > len)
    {
      insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */
      (*nlen) = width;
    }
  else (*nlen) = len;
  return(sc->num_to_str);
}

static void complex_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  #define Cv_Bufsize 1024 /* some floats can take around 312 bytes */
  bool too_long;
  const s7_complex *els = complex_vector_complexes(vect);
  s7_int len = print_vector_length(sc, vect, port, use_write);
  if (len < 0) return;  /* vector-length=0 etc */
  too_long = (len < vector_length(vect));

  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (len > 1000)
    {
      s7_int i;
      const s7_int vlen = vector_length(vect);
      const s7_complex first = els[0];
      for (i = 1; i < vlen; i++)
	if (els[i] != first)
	  break;
      if (i == vlen)
	{
	  s7_int plen;
	  char *num = complex_to_string_base_10(sc, first, 0, sc->float_format_precision, 'g', &plen, use_write);
	  make_vector_to_port(sc, vect, port);
	  port_write_string(port)(sc, num, clamp_length(plen, Cv_Bufsize), port);
	  if ((use_write == p_Readable) &&
	      (is_immutable_vector(vect)))
	    port_write_string(port)(sc, "))", 2, port);
	  else port_write_character(port)(sc, ')', port);
	  return;
	}}

  if (vector_rank(vect) == 1)
    {
      s7_int plen;
      char *num = complex_to_string_base_10(sc, els[0], 0, sc->float_format_precision, 'g', &plen, use_write);
      port_write_string(port)(sc, "#c(", 3, port);
      port_write_string(port)(sc, num, clamp_length(plen, Cv_Bufsize), port);
      for (s7_int i = 1; i < len; i++)
	{
	  num = complex_to_string_base_10(sc, els[i], 0, sc->float_format_precision, 'g', &plen, use_write);
	  port_write_character(port)(sc, ' ', port);
	  port_write_string(port)(sc, num, clamp_length(plen, Cv_Bufsize), port);
	}
      if (too_long)
	port_write_string(port)(sc, " ...)", 5, port);
      else port_write_character(port)(sc, ')', port);
    }
  else
    {
      char buf[Cv_Bufsize];
      const s7_int plen = catstrs_direct(buf, "#c", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      gc_protect_via_stack(sc, vect);
      multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_Display, NULL);
      unstack_gc_protect(sc);
    }
  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_character(port)(sc, ')', port);
}

static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  bool too_long;
  const s7_int len = print_vector_length(sc, vect, port, use_write);
  if (len < 0) return;
  too_long = (len < vector_length(vect));

  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (len > 1000)
    {
      s7_int i;
      const s7_int vlen = vector_length(vect);
      const uint8_t *els = byte_vector_bytes(vect);
      uint8_t first = els[0];
      for (i = 1; i < vlen; i++)
	if (els[i] != first)
	  break;
      if (i == vlen)
	{
	  s7_int plen;
	  const char *str; /* const for integer_to_string */
	  make_vector_to_port(sc, vect, port);
	  str = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */
	  port_write_string(port)(sc, str, plen, port);
	  if ((use_write == p_Readable) &&
	      (is_immutable_vector(vect)))
	    port_write_string(port)(sc, "))", 2, port);
	  else port_write_character(port)(sc, ')', port);
	  return;
	}}

  if (vector_rank(vect) == 1)
    {
      s7_int plen;
      const char *str;
      port_write_string(port)(sc, "#u(", 3, port);
      str = integer_to_string(sc, byte_vector(vect, 0), &plen);
      port_write_string(port)(sc, str, plen, port);
      for (s7_int i = 1; i < len; i++)
	{
	  char buf[Out_Bufsize];
	  plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, byte_vector(vect, i)), (const char *)NULL);
	  port_write_string(port)(sc, buf, plen, port);
	}
      if (too_long)
	port_write_string(port)(sc, " ...)", 5, port);
      else port_write_character(port)(sc, ')', port);
    }
  else
    {
      char buf[Out_Bufsize];
      const s7_int plen = catstrs_direct(buf, "#u", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
      port_write_string(port)(sc, buf, plen, port);
      multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), p_Display, NULL);
    }
  if ((use_write == p_Readable) &&
      (is_immutable_vector(vect)))
    port_write_character(port)(sc, ')', port);
}

static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  bool immutable = ((use_write == p_Readable) &&
		    (is_immutable_string(obj)) &&
		    (string_length(obj) > 0));  /* (immutable "") looks dumb */
  if (immutable)
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (string_length(obj) > 0)
    {
      /* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */
      if (string_length(obj) > 1000) /* was 10000 28-Feb-18 */
	{
	  size_t size;
	  char buf[Out_Bufsize];
	  buf[0] = string_value(obj)[0];
	  buf[1] = '\0';
	  size = strspn((const char *)(string_value(obj) + 1), buf); /* if all #\null, this won't work */
	  if (size == (size_t)(string_length(obj) - 1))
	    {
	      const s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))];
	      const int32_t nlen = (int32_t)catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL);
	      port_write_string(port)(sc, buf, nlen, port);
	      port_write_string(port)(sc, character_name(c), character_name_length(c), port);
	      if (immutable)
		port_write_string(port)(sc, "))", 2, port);
	      else port_write_character(port)(sc, ')', port);
	      return;
	    }}
      if (use_write == p_Display)
	port_write_string(port)(sc, string_value(obj), string_length(obj), port);
      else
	if (!string_needs_slashification((const uint8_t *)string_value(obj), string_length(obj)))
	  {
	    port_write_character(port)(sc, '"', port);
	    port_write_string(port)(sc, string_value(obj), string_length(obj), port);
	    port_write_character(port)(sc, '"', port);
	  }
	else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), In_Quotes);
    }
  else
    if (use_write != p_Display)
      port_write_string(port)(sc, "\"\"", 2, port);

  if (immutable)
    port_write_character(port)(sc, ')', port);
}

static s7_int list_length_with_immutable_check(s7_scheme *sc, s7_pointer a, bool *immutable)
{
  s7_pointer slow = a, fast = a;
  for (s7_int i = 0; ; i += 2)
    {
      if (!is_pair(fast)) return((is_null(fast)) ? i : -i);
      if (is_immutable_pair(fast)) *immutable = true;
      fast = cdr(fast);
      if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1));
      if (is_immutable_pair(fast)) *immutable = true;
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow) return(0);
    }
  return(0);
}

static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int true_len, s7_int len, s7_pointer port, shared_info_t *ci, bool immutable)
{
  /* the easier cases: no circles or shared refs to patch up, true_len < 0 if dotted */
  if ((true_len > 0) && (!immutable))
    {
      port_write_string(port)(sc, "list", 4, port);
      for (s7_pointer p = lst; is_pair(p); p = cdr(p))
	{
	  port_write_character(port)(sc, ' ', port);
	  object_to_port_with_circle_check(sc, car(p), port, p_Readable, ci);
	}
      port_write_character(port)(sc, ')', port);
    }
  else
    {
      s7_pointer p;
      s7_int i = 1, mutables = 0;
      bool sent_immutable = false, last_immutable = false;
      if (is_immutable_pair(lst))
	{
	  port_write_string(port)(sc, "immutable! (cons ", 17, port);
	  sent_immutable = true;
	  last_immutable = true;
	}
      else
	{
	  mutables = 1;
	  port_write_string(port)(sc, "cons ", 5, port);
	}
      object_to_port_with_circle_check(sc, car(lst), port, p_Readable, ci);

      for (p = cdr(lst); is_pair(p); p = cdr(p), i++)
	{
	  if (is_immutable_pair(p))
	    {
	      if (!last_immutable)
		{
		  port_write_string(port)(sc, " (", 2, port);
		  simple_list_readable_display(sc, p, true_len - i, len - i, port, ci, true);
		  p = sc->nil;
		  len = i;
		  true_len = 1; /* outer is not dotted */
		  goto Close_Cons;
		}}
	  else
	    {
	      mutables++;
	      last_immutable = false;
	    }
	  port_write_string(port)(sc, " (cons ", 7, port);
	  object_to_port_with_circle_check(sc, car(p), port, p_Readable, ci);
	}
      if (is_null(p))
	port_write_string(port)(sc, " ()", 3, port);
      else
	{
	  port_write_character(port)(sc, ' ', port);
	  object_to_port_with_circle_check(sc, p, port, p_Readable, ci);
	}
    Close_Cons:
      for (s7_int k = (true_len <= 0) ? 1 : 0; k < len; k++)
	port_write_character(port)(sc, ')', port);
      if (sent_immutable)
	{
	  if (mutables > 0)
	    {
	      char *intstr = pos_int_to_str_direct(sc, i - mutables);
	      port_write_character(port)(sc, ' ', port);
	      port_write_string(port)(sc, intstr, strlen(intstr), port);
	    }
	  port_write_character(port)(sc, ')', port);
	}}
}

static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  s7_int len;
  bool immutable = false;
  const s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable);
  if (true_len < 0)                    /* a dotted list -- handle cars, then final cdr */
    len = (-true_len + 1);
  else len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */

  if ((use_write == p_Readable) && (ci))
    {
      int32_t href = peek_shared_ref(ci, lst);
      if (href != 0)
	{
	  if (href < 0) href = -href;
	  if ((ci->defined[href]) || (port == ci->cycle_port))
	    {
	      char buf[Out_Bufsize];
	      int32_t plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	      return;
	    }}}
  if ((use_write != p_Readable) &&
      ((car(lst) == sc->quote_function) || (car(lst) == sc->quote_symbol)) &&
      (true_len == 2))
    {
      const bool need_new_ci = ((!ci) && (is_pair(cadr(lst))));
      shared_info_t *new_ci = NULL, *temp_ci = NULL;
      const bool old_locked = sc->object_out_locked;
      /* true_len == 2 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird
       *   or (object->string (apply . `''1)) -> "'quote 1"
       * so (quote x) = 'x but (quote x y z) should be left alone (if evaluated, it's an error)
       * :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evaluable back to its original
       */
      if (car(lst) == sc->quote_symbol)
	port_write_string(port)(sc, "(quote ", 7, port);
      else port_write_character(port)(sc, '\'', port);
      if (need_new_ci)
	{
	  new_ci = make_shared_info(sc);
	  /* clear_shared_info(new_ci); */
	  temp_ci = load_shared_info(sc, cadr(lst), false, new_ci); /* temp_ci can be NULL! false = dont stop at print length */
	}
      else temp_ci = ci;
      if (need_new_ci) sc->object_out_locked = true;
      object_to_port_with_circle_check(sc, cadr(lst), port, p_Write, temp_ci);
      if (need_new_ci)
	{
	  sc->object_out_locked = old_locked;
	  free_shared_info(new_ci);
	}
      if (car(lst) == sc->quote_symbol)
	port_write_character(port)(sc, ')', port);
      return;
    }
#if With_Immutable_Unquote
  if ((car(lst) == sc->unquote_symbol) && (true_len == 2))
    {
      port_write_character(port)(sc, ',', port);
      object_to_port_with_circle_check(sc, cadr(lst), port, p_Write, ci);
      return;
    }
#endif

  if (is_multiple_value(lst))
    port_write_string(port)(sc, "(values ", 8, port);
  else port_write_character(port)(sc, '(', port);

  if (use_write == p_Readable)
    {
      if (!is_cyclic(lst))
	{
	  /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */
	  simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable);
	  return;
	}
      /* see end of file example that is wrong (circular+immutable!+:readable), second arg is ignored etc */
      if (ci)
	{
	  int32_t plen;
	  s7_pointer p, local_port;
	  char buf[Out_Bufsize], lst_name[Out_Bufsize];
	  bool lst_local = false;
	  int32_t lst_ref = peek_shared_ref(ci, lst);
	  if (lst_ref == 0)
	    {
	      for (p = lst; is_pair(p); p = cdr(p))
		if ((has_structure(car(p))) ||
		    ((is_pair(cdr(p))) &&
		     (peek_shared_ref(ci, cdr(p)) != 0)))
		  {
		    lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0';
		    lst_local = true;
		    port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */
		    break;
		  }
	      if (!lst_local)
		{
		  if (has_structure(p))
		    {
		      lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0';
		      lst_local = true;
		      port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */
		    }
		  else
		    {
		      simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable);
		      return;
		    }}}
	  else
	    {
	      if (lst_ref < 0) lst_ref = -lst_ref;
	      catstrs_direct(lst_name, "<", pos_int_to_str_direct(sc, lst_ref), ">", (const char *)NULL);
	      port_write_string(port)(sc, "list", 4, port); /* '(' above */
	    }
	  p = lst;
	  for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++)
	    {
	      if ((has_structure(car(p))) &&
		  (is_cyclic(car(p))))
		port_write_string(port)(sc, " #f", 3, port);
	      else
		{
		  port_write_character(port)(sc, ' ', port);
		  object_to_port_with_circle_check(sc, car(p), port, use_write, ci);
		}
	      if ((is_pair(cdr(p))) &&
		  (peek_shared_ref(ci, cdr(p)) != 0))
		break;
	    }

	  if (lst_local)
	    port_write_string(port)(sc, "))) ", 4, port);
	  else port_write_character(port)(sc, ')', port);

	  /* fill in the cyclic entries */
	  local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(p . 1) (signature (int-vector))) :readable) */
	  p = lst;
	  for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++)
	    {
	      int32_t lref;
	      if ((has_structure(car(p))) &&
		  (is_cyclic(car(p))))
		{
		  if (i == 0)
		    plen = (int32_t)catstrs_direct(buf, "  (set-car! ", lst_name, " ", (const char *)NULL);
		  else plen = (int32_t)catstrs_direct(buf, "  (set! (", lst_name, " ", pos_int_to_str_direct(sc, i), ") ", (const char *)NULL);
		  port_write_string(local_port)(sc, buf, plen, local_port);
		  lref = peek_shared_ref(ci, car(p));
		  if (lref == 0)
		    object_to_port_with_circle_check(sc, car(p), local_port, use_write, ci);
		  else
		    {
		      if (lref < 0) lref = -lref;
		      plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL);
		      port_write_string(local_port)(sc, buf, plen, local_port);
		    }
		  port_write_string(local_port)(sc, ") ", 2, local_port);
		}
	      if ((is_pair(cdr(p))) &&
		  ((lref = peek_shared_ref(ci, cdr(p))) != 0))
		{
		  if (lref < 0) lref = -lref;
		  if (i == 0)
		    plen = (int32_t)catstrs_direct(buf, (lst_local) ? "    " : "  ",
						   "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL);
		  else
		    if (i == 1)
		      plen = (int32_t)catstrs_direct(buf, (lst_local) ? "    " : "  ",
						     "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL);
		    else plen = (int32_t)catstrs_direct(buf, (lst_local) ? "    " : "  ",
							"(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct_1(sc, i),
							") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL);
		  port_write_string(local_port)(sc, buf, plen, local_port);
		  break;
		}}
	  if (true_len < 0) /* dotted list */
	    {
	      s7_pointer end_p;
	      for (end_p = lst; is_pair(end_p); end_p = cdr(end_p)); /* or maybe faster, start at p? */
	      /* we can't depend on the loops above to set p to the last element because they sometimes break out */
	      if (true_len == -1) /* cons cell */
		plen = (int32_t)catstrs_direct(buf, (lst_local) ? "    " : "  ", "(set-cdr! ", lst_name, " ", (const char *)NULL);
	      else
		if (true_len == -2)
		  plen = (int32_t)catstrs_direct(buf, (lst_local) ? "    " : "  ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL);
		else plen = (int32_t)catstrs_direct(buf, "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct(sc, len - 2), ") ", (const char *)NULL);
	      port_write_string(local_port)(sc, buf, plen, local_port);
	      object_to_port_with_circle_check(sc, end_p, local_port, use_write, ci);
	      port_write_string(local_port)(sc, ") ", 2, local_port);
	    }
	  if (lst_local)
	    port_write_string(local_port)(sc, "    <L>)", 8, local_port);
	}
      else simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable);
    }
  else /* not :readable */
    {
      const s7_int plen = (len > sc->print_length) ? sc->print_length : len;
      if (plen <= 0)
	{
	  port_write_string(port)(sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */
	  return;
	}
      if (ci)
	{
	  s7_pointer p;
	  s7_int i;
	  for (p = lst, i = 0; (is_pair(p)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, p) == 0)); i++, p = cdr(p))
	    {
	      ci->ctr++;
	      if (ci->ctr > sc->print_length)
		{
		  port_write_string(port)(sc, " ...)", 5, port);
		  return;
		}
	      object_to_port_with_circle_check(sc, car(p), port, not_p_display(use_write), ci);
	      if (i < (len - 1))
		port_write_character(port)(sc, ' ', port);
	    }
	  if (is_not_null(p))
	    {
	      if (plen < len)
		port_write_string(port)(sc, " ...", 4, port);
	      else
		{
		  if ((true_len == 0) &&
		      (i == len))
		    port_write_string(port)(sc, " . ", 3, port);
		  else port_write_string(port)(sc, ". ", 2, port);
		  object_to_port_with_circle_check(sc, p, port, not_p_display(use_write), ci);
		}}
	  port_write_character(port)(sc, ')', port);
	}
      else
	{
	  s7_pointer p = lst;
	  const s7_int len1 = plen - 1;
	  if (is_string_port(port))
	    {
	      for (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p))
		{
		  object_to_port(sc, car(p), port, not_p_display(use_write), ci);
		  if (port_position(port) >= sc->objstr_max_len)
		    return;
		  if (port_position(port) >= port_data_size(port))
		    resize_port_data(sc, port, port_data_size(port) * 2);
		  port_data(port)[port_position(port)++] = (uint8_t)' ';
		}}
	  else
	    for (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p))
	      {
		object_to_port(sc, car(p), port, not_p_display(use_write), ci);  /* lst free here if unprotected */
		port_write_character(port)(sc, ' ', port);
	      }
	  if (is_pair(p))
	    {
	      object_to_port(sc, car(p), port, not_p_display(use_write), ci);
	      p = cdr(p);
	    }
	  if (is_not_null(p))
	    {
	      if (plen < len)
		port_write_string(port)(sc, " ...", 4, port);
	      else
		{
		  port_write_string(port)(sc, ". ", 2, port);
		  object_to_port(sc, p, port, not_p_display(use_write), ci);
		}}
	  port_write_character(port)(sc, ')', port);
	}}
}

static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let);
static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht);

static s7_pointer find_typer(s7_scheme *sc, s7_pointer typer)
{
  s7_pointer sym = find_closure(sc, typer, closure_let(typer));
  if (!is_symbol(sym))
    sym = find_closure(sc, typer, sc->curlet);
  return(sym);
}

static const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer)
{
  if (is_c_function(typer)) return(c_function_name(typer));
  if (is_boolean(typer)) return("#t");
#if s7_Debugging /* I don't think this happens anymore */
  if (typer == sc->unused)
    {
      fprintf(stderr, "%s[%d]: hash typer is #<unused>\n", __func__, __LINE__);
      return("#<unused>"); /* mapper can be sc->unused briefly -- where? */
    }
#endif
  {
    s7_pointer sym = find_typer(sc, typer);
    return((is_symbol(sym)) ? symbol_name(sym) : NULL); /* see below in hash_table_procedures_to_port */
  }
}

static void hash_typers_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port)
{
  if ((is_typed_hash_table(hash)) && /* || (is_pair(hash_table_procedures(hash)))) */
      ((!is_boolean(hash_table_key_typer(hash))) || (!is_boolean(hash_table_value_typer(hash)))))
    {
      const char *typer = hash_table_typer_name(sc, hash_table_key_typer(hash));
      port_write_string(port)(sc, " (cons ", 7, port);
      port_write_string(port)(sc, typer, safe_strlen(typer), port);
      port_write_character(port)(sc, ' ', port);
      typer = hash_table_typer_name(sc, hash_table_value_typer(hash));
      port_write_string(port)(sc, typer, safe_strlen(typer), port);
      port_write_string(port)(sc, "))", 2, port);
    }
  else port_write_character(port)(sc, ')', port);
}

static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool closed, shared_info_t *ci)
{
  const char *typer = hash_table_checker_name(sc, hash);
  if ((closed) && (is_immutable_hash_table(hash)))
    port_write_string(port)(sc, "(immutable! ", 12, port);

  if (typer[0] == '#') /* #f */
    {
      if (is_pair(hash_table_procedures(hash)))
	{
	  s7_int nlen = 0;
	  const char *str = (const char *)integer_to_string(sc, hash_table_size(hash), &nlen);
	  const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash));
	  const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash));
	  if (is_weak_hash_table(hash))
	    port_write_string(port)(sc, "(make-weak-hash-table ", 22, port);
	  else port_write_string(port)(sc, "(make-hash-table ", 17, port);
	  port_write_string(port)(sc, str, nlen, port);
	  if ((checker) && (mapper))
	    {
	      if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash))))
		port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */
	      else
		{
		  port_write_string(port)(sc, " (cons ", 7, port);
		  port_write_string(port)(sc, checker, safe_strlen(checker), port);
		  port_write_character(port)(sc, ' ', port);
		  port_write_string(port)(sc, mapper, safe_strlen(mapper), port);
		  port_write_character(port)(sc, ')', port);
		}}
	  else
	    if ((is_any_closure(hash_table_procedures_checker(hash))) ||
		(is_any_closure(hash_table_procedures_mapper(hash))))
	      {
		port_write_string(port)(sc, " (cons ", 7, port);
		if (is_any_closure(hash_table_procedures_checker(hash)))
		  object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, p_Readable, ci);
		else port_write_string(port)(sc, checker, safe_strlen(checker), port);
		port_write_character(port)(sc, ' ', port);
		if (is_any_closure(hash_table_procedures_mapper(hash)))
		  object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, p_Readable, ci);
		else port_write_string(port)(sc, mapper, safe_strlen(mapper), port);
		port_write_character(port)(sc, ')', port);
	      }
	    else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */
	  hash_typers_to_port(sc, hash, port);
	}
      else
	if (is_weak_hash_table(hash))
	  port_write_string(port)(sc, "(weak-hash-table)", 17, port);
	else port_write_string(port)(sc, "(hash-table)", 12, port);
    }
  else
    {
      s7_int nlen = 0;
      const char *str = integer_to_string(sc, hash_table_size(hash), &nlen);
      if (is_weak_hash_table(hash))
	port_write_string(port)(sc, "(make-weak-hash-table ", 22, port);
      else port_write_string(port)(sc, "(make-hash-table ", 17, port);
      port_write_string(port)(sc, str, nlen, port);
      port_write_character(port)(sc, ' ', port);
      port_write_string(port)(sc, typer, safe_strlen(typer), port);
      hash_typers_to_port(sc, hash, port);
    }
  if (is_immutable_hash_table(hash))
    port_write_character(port)(sc, ')', port);
}

static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  s7_int gc_iter, len = hash_table_entries(hash);
  bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false;
  s7_pointer iterator;
  int32_t href = -1;

  if (len == 0)
    {
      if (use_write == p_Readable)
	hash_table_procedures_to_port(sc, hash, port, true, ci);
      else
	{
	  if (is_weak_hash_table(hash))
	    port_write_string(port)(sc, "(weak-hash-table)", 17, port);
	  else port_write_string(port)(sc, "(hash-table)", 12, port);
	}
      return;
    }

  if (use_write != p_Readable)
    {
      const s7_int plen = sc->print_length;
      if (plen <= 0)
	{
	  port_write_string(port)(sc, "(hash-table ...)", 16, port);
	  return;
	}
      if (len > plen)
	{
	  too_long = true;
	  len = plen;
	}}

  if ((use_write == p_Readable) &&
      (ci))
    {
      href = peek_shared_ref(ci, hash);
      if (href != 0)
	{
	  if (href < 0) href = -href;
	  if ((ci->defined[href]) || (port == ci->cycle_port))
	    {
	      char buf[Out_Bufsize];
	      int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	      return;
	    }}}

  iterator = s7_make_iterator(sc, hash);
  gc_iter = gc_protect_1(sc, iterator);
  iterator_carrier(iterator) = cons_unchecked(sc, sc->unused, sc->unused);
  set_has_carrier(iterator);
  hash_cyclic = ((ci) && (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0));

  if (use_write == p_Readable)
    {
      if ((is_typed_hash_table(hash)) || /* (is_pair(hash_table_procedures(hash))) || */ (hash_chosen(hash)))
	{
	  port_write_string(port)(sc, "(let ((<h> ", 11, port);
	  letd = true;
	}
      else
	if ((is_immutable_hash_table(hash)) && (!hash_cyclic))
	  {
	    port_write_string(port)(sc, "(immutable! ", 12, port);
	    immut = true;
	  }}

  if ((use_write == p_Readable) &&
      (hash_cyclic))
    {
      if (href < 0) href = -href;
      if ((!is_typed_hash_table(hash)) && /* (!is_pair(hash_table_procedures(hash))) && */ (!hash_chosen(hash)))
	{
	  if (is_weak_hash_table(hash))
	    port_write_string(port)(sc, "(weak-hash-table", 16, port);
	  else port_write_string(port)(sc, "(hash-table", 11, port); /* top level let */
	}
      else
	{
	  hash_table_procedures_to_port(sc, hash, port, true, ci);
	  port_write_character(port)(sc, ')', port);
	}

      /* output here is deferred via ci->cycle_port until later in cyclic_out */
      for (s7_int i = 0; i < len; i++)
	{
	  const s7_pointer key_val = hash_table_iterate(sc, iterator);
	  if (key_val == sc->iterator_at_end_value) break; /* key_val can be #<eof> if hash is a weak-hash-table, and a GC happens during this loop */
	  {
	    const s7_pointer key = car(key_val);
	    const s7_pointer val = cdr(key_val);
	    char buf[Out_Bufsize];
	    int32_t eref = peek_shared_ref(ci, val);
	    int32_t kref = peek_shared_ref(ci, key);
	    int32_t plen = catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, href), "> ", (const char *)NULL);
	    port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port);
	    if (kref != 0)
	      {
		if (kref < 0) kref = -kref;
		plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, kref), ">", (const char *)NULL);
		port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port);
	      }
	    else object_to_port(sc, key, ci->cycle_port, p_Readable, ci);
	    if (eref != 0)
	      {
		if (eref < 0) eref = -eref;
		plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, eref), ">) ", (const char *)NULL);
		port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port);
	      }
	    else
	      {
		port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
		object_to_port_with_circle_check(sc, val, ci->cycle_port, p_Readable, ci);
		port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
	      }}}}
  else
    {
      if (((!is_typed_hash_table(hash)) && /* (!is_pair(hash_table_procedures(hash))) && */ (!hash_chosen(hash))) || (use_write != p_Readable))
	{
	  if (is_weak_hash_table(hash))
	    port_write_string(port)(sc, "(weak-hash-table", 16, port);
	  else port_write_string(port)(sc, "(hash-table", 11, port);
	}
      else
	{
	  hash_table_procedures_to_port(sc, hash, port, true, ci);
	  port_write_character(port)(sc, ')', port);
	  port_write_string(port)(sc, ") (copy (hash-table", 19, port);
	  copied = true;
	}
      for (s7_int i = 0; i < len; i++)
	{
	  const s7_pointer key_val = hash_table_iterate(sc, iterator);
	  if (key_val == sc->iterator_at_end_value) break; /* key_val can be #<eof> if hash is a weak-hash-table, and a GC happens during this loop */
	  port_write_character(port)(sc, ' ', port);
	  if ((use_write != p_Readable) && (use_write != p_Code) && (is_normal_symbol(car(key_val))))
	    port_write_character(port)(sc, '\'', port);
	  object_to_port_with_circle_check(sc, car(key_val), port, not_p_display(use_write), ci);
	  port_write_character(port)(sc, ' ', port);
	  object_to_port_with_circle_check(sc, cdr(key_val), port, not_p_display(use_write), ci);
	}
      if (use_write != p_Readable)
	{
	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);
	}}

  if (use_write == p_Readable)
    {
      if (copied)
	{
	  if (!letd)
	    {
	      char buf[Out_Bufsize];
	      int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL);
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  else port_write_string(port)(sc, ") <h>))", 7, port);
	}
      else
	if (letd)
	  port_write_string(port)(sc, ") <h>)", 6, port);
	else port_write_character(port)(sc, ')', port);

      if ((is_immutable_hash_table(hash)) && (!hash_cyclic) && (!is_typed_hash_table(hash)))
	port_write_character(port)(sc, ')', port);

      if ((!immut) && (is_immutable_hash_table(hash)) && (!hash_cyclic))
	port_write_string(port)(sc, ") (immutable! <h>))", 19, port);
    }
  s7_gc_unprotect_at(sc, gc_iter);
  iterator_carrier(iterator) = sc->nil;
}

#define Inlet_Style false
#define Let_Style true

static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) /* bindings = inlet or let */
{
  bool first_time = true;
  for (; is_slot_checked(slot); slot = next_slot(slot))
    {
      if (bindings)
	{
	  if (first_time)
	    {
	      port_write_character(port)(sc, '(', port);
	      first_time = false;
	    }
	  else port_write_string(port)(sc, " (", 2, port);
	}
      else port_write_character(port)(sc, ' ', port);
      symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? p_Display : p_Key, NULL);  /* (object->string (inlet (symbol "(\")") 1) :readable) */
      port_write_character(port)(sc, ' ', port);
      object_to_port_with_circle_check(sc, slot_value(slot), port, p_Readable, ci);
      if (bindings) port_write_character(port)(sc, ')', port);
    }
}

static void slot_list_to_port_with_cycle(s7_scheme *sc, s7_pointer obj, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings)
{
  bool first_time = true;
  for (; is_slot_checked(slot); slot = next_slot(slot))
    {
      const s7_pointer sym = slot_symbol(slot), val = slot_value(slot);
      if (bindings)
	{
	  if (first_time)
	    {
	      port_write_character(port)(sc, '(', port);
	      first_time = false;
	    }
	  else port_write_string(port)(sc, " (", 2, port);
	}
      else port_write_character(port)(sc, ' ', port);
      symbol_to_port(sc, sym, port, (bindings) ? p_Display : p_Key, NULL);
      if (has_structure(val))
	{
	  char buf[Out_Bufsize];
	  int32_t symref;
	  int32_t len = catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL);
	  port_write_string(port)(sc, " #f", 3, port);
	  port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
	  symbol_to_port(sc, sym, ci->cycle_port, p_Key, NULL);

	  symref = peek_shared_ref(ci, val);
	  if (symref != 0)
	    {
	      if (symref < 0) symref = -symref;
	      len = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, symref), ">) ", (const char *)NULL);
	      port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
	    }
	  else
	    {
	      port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
	      object_to_port_with_circle_check(sc, val, ci->cycle_port, p_Readable, ci);
	      port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
	    }}
      else
	{
	  port_write_character(port)(sc, ' ', port);
	  object_to_port_with_circle_check(sc, val, port, p_Readable, ci);
	}
      if (bindings) port_write_character(port)(sc, ')', port);
      if (is_immutable(obj))
	{
	  char buf[Out_Bufsize];
	  int32_t len = catstrs_direct(buf, "  (immutable! <", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), ">) ", (const char *)NULL);
	  port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
	}}
}

static bool let_has_setter(s7_pointer obj)
{
  for (s7_pointer slot = let_slots(obj); is_slot_checked(slot); slot = next_slot(slot))
    if ((slot_has_setter(slot)) || (is_immutable_slot(slot)))
      return(true);
  return(false);
}

static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
{
  bool spaced_out = false;
  for (s7_pointer slot = let_slots(obj); is_slot_checked(slot); slot = next_slot(slot))
    if (slot_has_setter(slot))
      {
	if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true;
	port_write_string(port)(sc, "(set! (setter '", 15, port);
	symbol_to_port(sc, slot_symbol(slot), port, p_Display, NULL);
	port_write_string(port)(sc, ") ", 2, port);
	object_to_port_with_circle_check(sc, slot_setter(slot), port, p_Readable, ci);
	port_write_character(port)(sc, ')', port);
      }
  return(spaced_out);
}

static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, bool spaced_out)
{
  for (s7_pointer slot = let_slots(obj); is_slot_checked(slot); slot = next_slot(slot))
    if (is_immutable_slot(slot))
      {
	if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true;
	port_write_string(port)(sc, "(immutable! '", 13, port);
	symbol_to_port(sc, slot_symbol(slot), port, p_Display, NULL);
	port_write_character(port)(sc, ')', port);
      }
}

static void slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  /* the slot symbol might need (symbol...) in which case we don't want the preceding quote */
  symbol_to_port(sc, slot_symbol(obj), port, p_Readable, NULL);
  port_write_character(port)(sc, ' ', port);
  object_to_port_with_circle_check(sc, slot_value(obj), port, not_p_display(use_write), ci);  /* was use_write, (format #f "~A" (inlet 'a "a")) -> "(inlet 'a \"a\")" */
}

static void internal_slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  /* here we're displaying a slot in the debugger -- T_SLOT objects are not directly accessible in scheme */
  port_write_string(port)(sc, "#<slot: ", 8, port);
  symbol_to_port(sc, slot_symbol(obj), port, p_Display, NULL);
  port_write_character(port)(sc, ' ', port);
  object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci);
  port_write_character(port)(sc, '>', port);
}

static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  /* if outer let points to (say) method list, the object needs to specialize object->string itself */
  if ((!sc->short_print) && (has_active_methods(sc, obj))) /* short_print 14-Dec-24 from stacktrace (see below) */
    {
      const s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol);
      if (print_func != sc->undefined)
	{
	  s7_pointer str;
	  /* what needs to be protected here? for one, the function might not return a string! see fx_c_4a and t903 example */
	  clear_has_methods(obj);
	  if ((use_write == p_Write) || (use_write == p_Code))
	    str = s7_apply_function(sc, print_func, set_plist_1(sc, obj));
	  else str = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == p_Display) ? sc->F : sc->readable_keyword));
	  set_has_methods(obj);
	  if ((is_string(str)) &&
	      (string_length(str) > 0))
	    port_write_string(port)(sc, string_value(str), string_length(str), port);
	  return;
	}}
  if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;}
  if (obj == sc->starlet) {port_write_string(port)(sc, "*s7*", 4, port);      return;}
  /* if (is_unlet(obj))   {port_write_string(port)(sc, "(unlet)", 7, port);   return;} */ /* this is the let created by (unlet), not sc->unlet_entries */
  if (sc->short_print)    {port_write_string(port)(sc, "#<let>", 6, port);    return;}

  /* circles can happen here: (let ((b #f)) (set! b (curlet)) (curlet)): #1=#<let 'b #1#> */
  if (use_write == p_Readable)
    {
      int32_t lref;
      if ((ci) &&
	  (is_cyclic(obj)) &&
	  ((lref = peek_shared_ref(ci, obj)) != 0))
	{
	  if (lref < 0) lref = -lref;
	  if ((ci->defined[lref]) || (port == ci->cycle_port))
	    {
	      char buf[Out_Bufsize];
	      int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL);
	      port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
	      return;
	    }
	  if (let_outlet(obj) != sc->rootlet)
	    {
	      char buf[Out_Bufsize];
	      int32_t len = (int32_t)catstrs_direct(buf, "  (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL);
	      port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
	      let_to_port(sc, let_outlet(obj), ci->cycle_port, use_write, ci);
	      port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port);
	    }
	  if (is_openlet(obj))
	    port_write_string(port)(sc, "(openlet ", 9, port);
	  /* not immutable here because we'll need to set the let fields below, then declare it immutable */
	  if (let_has_setter(obj))           /* both explicit setters and immutable slots */
	    {
	      port_write_string(port)(sc, "(let (", 6, port);
	      slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, Let_Style);
	      port_write_string(port)(sc, ") ", 2, port);
	      immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci));
	      port_write_string(port)(sc, " (curlet))", 10, port);
	    }
	  else
	    {
	      port_write_string(port)(sc, "(inlet", 6, port);
	      slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, Inlet_Style);
	      port_write_character(port)(sc, ')', port);
	    }
	  if (is_openlet(obj))
	    port_write_character(port)(sc, ')', port);
	}
      else
	{
	  if (is_openlet(obj))
	    port_write_string(port)(sc, "(openlet ", 9, port);
	  if (is_immutable_let(obj))
	    port_write_string(port)(sc, "(immutable! ", 12, port);

	  /* this ignores outlet -- but is that a problem? */
	  /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */
	  if (let_has_setter(obj))
	    {
	      port_write_string(port)(sc, "(let (", 6, port);
	      slot_list_to_port(sc, let_slots(obj), port, ci, Let_Style);
	      port_write_string(port)(sc, ") ", 2, port);
	      immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci));
	      /* perhaps set outlet here?? */
	      port_write_string(port)(sc, " (curlet))", 10, port);
	    }
	  else
	    {
	      if (let_outlet(obj) != sc->rootlet)
		{
		  int32_t ref;
		  port_write_string(port)(sc, "(sublet ", 8, port);
		  if ((ci) && ((ref = peek_shared_ref(ci, let_outlet(obj))) < 0))
		    {
		      char buf[Out_Bufsize];
		      int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL);
		      port_write_string(port)(sc, buf, len, port);
		    }
		  else
		    {
		      s7_pointer name = let_ref_p_pp(sc, obj, sc->class_name_symbol);
		      if (is_symbol(name))
			symbol_to_port(sc, name, port, p_Display, NULL);
		      else let_to_port(sc, let_outlet(obj), port, use_write, ci);
		    }}
	      else port_write_string(port)(sc, "(inlet", 6, port);
	      slot_list_to_port(sc, let_slots(obj), port, ci, Inlet_Style);
	      port_write_character(port)(sc, ')', port);
	    }
	  if (is_immutable_let(obj))
	    port_write_character(port)(sc, ')', port);
	  if (is_openlet(obj))
	    port_write_character(port)(sc, ')', port);
	}}
  else /* not readable write */
    {
      s7_pointer slot = let_slots(obj);
      port_write_string(port)(sc, "(inlet", 6, port);
      for (int32_t i = 1; is_slot_checked(slot); i++, slot = next_slot(slot))
	{
	  port_write_character(port)(sc, ' ', port);
	  slot_to_port(sc, slot, port, use_write, ci);
	  if ((is_slot_checked(next_slot(slot))) && (i == sc->print_length))
	    {
	      port_write_string(port)(sc, " ...", 4, port);
	      break;
	    }}
      port_write_character(port)(sc, ')', port);
    }
}

static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  const s7_pointer body = closure_body(obj), parlist = closure_pars(obj);
  /* this doesn't handle recursive macros well -- we need letrec or the equivalent as in write_closure_readably */
  /*   (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) (object->string m2 :readable)) */

  port_write_string(port)(sc, (is_either_macro(obj)) ? "(macro" : "(bacro", 6, port);
  if ((is_macro_star(obj)) || (is_bacro_star(obj)))
    port_write_character(port)(sc, '*', port);
  if (is_symbol(parlist))
    {
      port_write_character(port)(sc, ' ', port);
      port_write_string(port)(sc, symbol_name(parlist), symbol_name_length(parlist), port);
      port_write_character(port)(sc, ' ', port);
    }
  else
    if (is_pair(parlist))
      {
	s7_pointer pars;
	port_write_string(port)(sc, " (", 2, port);
	for (pars = parlist; is_pair(pars); pars = cdr(pars))
	  {
	    object_to_port(sc, car(pars), port, p_Write, NULL);
	    if (is_pair(cdr(pars)))
	      port_write_character(port)(sc, ' ', port);
	  }
	if (!is_null(pars))
	  {
	    port_write_string(port)(sc, " . ", 3, port);
	    object_to_port(sc, pars, port, p_Write, NULL);
	  }
	port_write_string(port)(sc, ") ", 2, port);
      }
    else port_write_string(port)(sc, " () ", 4, port);

  for (s7_pointer expr = body; is_pair(expr); expr = cdr(expr))
    object_to_port(sc, car(expr), port, p_Write, NULL);
  port_write_character(port)(sc, ')', port);
}


static s7_pointer match_symbol(const s7_pointer symbol, s7_pointer let)
{
  for (s7_pointer le = let; le; le = let_outlet(le))
    for (s7_pointer slot = let_slots(le); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_symbol(slot) == symbol)
	return(slot);
  return(NULL);
}

static bool slot_memq(const s7_pointer symbol, s7_pointer symbols)
{
  for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms))
    if (slot_symbol(car(syms)) == symbol)
      return(true);
  return(false);
}

static bool arg_memq(const s7_pointer symbol, s7_pointer args)
{
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    if ((car(p) == symbol) ||
	((is_pair(car(p))) &&
	 (caar(p) == symbol)))
      return(true);
  return(false);
}

static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer let, s7_pointer args, s7_int gc_loc)
{
  if ((!arg_memq(T_Sym(sym), args)) &&
      (!slot_memq(sym, gc_protected_at(sc, gc_loc))))
    {
      s7_pointer slot = match_symbol(sym, let);
      if (slot)
	gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc));
    }
}

static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer let, s7_pointer args, s7_int gc_loc) /* currently called only in write_closure_readably */
{
  if (is_unquoted_pair(sc, body))
    {
      collect_locals(sc, car(body), let, args, gc_loc);
      collect_locals(sc, cdr(body), let, args, gc_loc);
    }
  else
    if (is_symbol(body))
      collect_symbol(sc, body, let, args, gc_loc);
}

static void collect_specials(s7_scheme *sc, s7_pointer let, s7_pointer args, s7_int gc_loc)
{
  collect_symbol(sc, sc->local_signature_symbol, let, args, gc_loc);
  collect_symbol(sc, sc->local_setter_symbol, let, args, gc_loc);
  collect_symbol(sc, sc->local_documentation_symbol, let, args, gc_loc);
  collect_symbol(sc, sc->local_iterator_symbol, let, args, gc_loc);
}

static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let)
{
  for (s7_pointer let = current_let; let; let = let_outlet(let))
    {
      if ((is_funclet(let)) || (is_maclet(let)))
	{
	  const s7_pointer sym = funclet_function(let);
	  const s7_pointer func = s7_symbol_local_value(sc, sym, let);
	  if (func == closure)
	    return(sym);
	}
      for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
	if (slot_value(slot) == closure)
	  return(slot_symbol(slot));
    }
  if ((is_any_macro(closure)) && /* can't be a c_macro here */
      (has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */
    return(pair_macro(closure_body(closure)));
  return(sc->nil);
}

static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port)
{
  const s7_pointer sym = find_closure(sc, closure, closure_let(closure));
  if (is_symbol(sym))
    {
      port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port);
      return;
    }
  switch (type(closure))
    {
    case T_CLOSURE:      port_write_string(port)(sc, "#<lambda ", 9, port);   break;
    case T_CLOSURE_STAR: port_write_string(port)(sc, "#<lambda* ", 10, port); break;
    case T_BACRO:        port_write_string(port)(sc, "#<bacro ", 8, port);    break;
    case T_BACRO_STAR:   port_write_string(port)(sc, "#<bacro* ", 9, port);   break;

    case T_MACRO:
      if (is_expansion(closure))
	port_write_string(port)(sc, "#<expansion ", 12, port);
      else port_write_string(port)(sc, "#<macro ", 8, port);
      break;

    case T_MACRO_STAR:
      if (is_expansion(closure))
	port_write_string(port)(sc, "#<expansion* ", 13, port);
      else port_write_string(port)(sc, "#<macro* ", 9, port);
      break;
    }

  if (is_null(closure_pars(closure)))
    port_write_string(port)(sc, "()>", 3, port);
  else
    {
      s7_pointer pars = closure_pars(closure);
      if (is_symbol(pars))
	{
	  port_write_string(port)(sc, symbol_name(pars), symbol_name_length(pars), port);
	  port_write_character(port)(sc, '>', port);    /* (lambda a a) -> #<lambda a> */
	}
      else
	{
	  s7_pointer sym = car(pars);
	  if (is_pair(sym)) sym = car(sym);
	  port_write_character(port)(sc, '(', port);
	  port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port);
	  if (!is_null(cdr(pars)))
	    {
	      s7_pointer par;
	      port_write_character(port)(sc, ' ', port);
	      if (is_pair(cdr(pars)))
		{
		  par = cadr(pars);
		  if (is_pair(par))
		    par = car(par);
		  else
		    if (par == sc->rest_keyword)
		      {
			port_write_string(port)(sc, ":rest ", 6, port);
			pars = cdr(pars);
			par = cadr(pars);
			if (is_pair(par)) par = car(par);
		      }}
	      else
		{
		  port_write_string(port)(sc, ". ", 2, port);
		  par = cdr(pars);
		}
	      port_write_string(port)(sc, symbol_name(par), symbol_name_length(par), port);
	      if ((is_pair(cdr(pars))) &&
		  (!is_null(cddr(pars))))
		port_write_string(port)(sc, " ...", 4, port);
	    }
	  port_write_string(port)(sc, ")>", 2, port);
	}}
}

static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure)
{
  /* this is used by the error handlers to get the current function name */
  const s7_pointer sym = find_closure(sc, closure, sc->curlet);
  if (is_symbol(sym))
    return(sym);
  if (is_pair(current_code(sc)))
    return(current_code(sc));
  return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */
}

static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  s7_pointer p = cdr(a), tp;
  gc_protect_via_stack(sc, b);
  if (is_null(p))
    tp = cons(sc, car(a), b);
  else
    {
      s7_pointer np;
      tp = list_1(sc, car(a));
      set_gc_protected2(sc, tp);
      for (np = tp; is_pair(p); p = cdr(p), np = cdr(np))
	set_cdr(np, list_1(sc, car(p)));
      set_cdr(np, b);
    }
  unstack_gc_protect(sc);
  return(tp);
}

static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port)
{
  const s7_int old_print_length = sc->print_length;

  if (type(obj) == T_CLOSURE_STAR)
    port_write_string(port)(sc, "(lambda* ", 9, port);
  else port_write_string(port)(sc, "(lambda ", 8, port);

  if ((is_pair(arglist)) &&
      (allows_other_keys(arglist)))
    {
      sc->temp7 = (is_null(cdr(arglist))) ? set_plist_2(sc, car(arglist), sc->allow_other_keys_keyword) :
	          ((is_null(cddr(arglist))) ? set_plist_3(sc, car(arglist), cadr(arglist), sc->allow_other_keys_keyword) :
	                                      pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword)));
      object_to_port(sc, sc->temp7, port, p_Write, NULL);
      sc->temp7 = sc->unused;
    }
  else object_to_port(sc, arglist, port, p_Write, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */

  sc->print_length = 1048576;
  for (s7_pointer p = body; is_pair(p); p = cdr(p))
    {
      port_write_character(port)(sc, ' ', port);
      object_to_port(sc, car(p), port, p_Write, NULL);
    }
  port_write_character(port)(sc, ')', port);
  sc->print_length = old_print_length;
}

static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
{
  const s7_pointer body = closure_body(obj);
  s7_pointer parlist = closure_pars(obj);
  s7_pointer pe, local_slots, setter = NULL, obj_slot = NULL;
  s7_int gc_loc;
  bool sent_let = false, sent_letrec = false;

  if (sc->safety > No_Safety)
    {
      if (tree_is_cyclic(sc, body))
	{
	  port_write_string(port)(sc, "#<write_closure_readably: body is cyclic>", 41, port); /* not s7_error here! */
	  return;
	}
      if ((!ci) && (is_pair(parlist)))
	{ /* (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) */
	  shared_info_t *new_ci = make_shared_info(sc);
	  clear_shared_info(new_ci);
	  if (collect_shared_info(sc, new_ci, parlist, false))
	    {
	      free_shared_info(new_ci);
	      port_write_string(port)(sc, "#<write_closure_readably: parameter list is cyclic>", 51, port); /* not s7_error here! */
	      return;
	    }
	  free_shared_info(new_ci);
	}}
  if (is_symbol(parlist)) parlist = set_dlist_1(sc, parlist);
  pe = closure_let(obj);

  gc_loc = gc_protect_1(sc, sc->nil);
  collect_locals(sc, body, pe, parlist, gc_loc);   /* collect locals used only here (and below) */
  collect_specials(sc, pe, parlist, gc_loc);

  if (s7_is_dilambda(obj))
    {
      setter = closure_setter(obj);
      if (has_closure_let(setter))                 /* collect args etc so need the parameter list */
	{
	  s7_pointer setter_parlist = closure_pars(setter);
	  if (is_symbol(setter_parlist)) setter_parlist = set_dlist_1(sc, setter_parlist);
	  collect_locals(sc, closure_body(setter), pe, setter_parlist, gc_loc);
	}}

  local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */
  if (!is_null(local_slots))
    {
      /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), local_slots: ('f f) */
      /* but we can't handle it below because that leads to an infinite loop */
      for (s7_pointer slots = local_slots; is_pair(slots); slots = cdr(slots))
	{
	  const s7_pointer slot = car(slots);
	  if ((!is_any_closure(slot_value(slot))) &&    /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */
	      ((!has_structure(slot_value(slot))) ||    /* see s7test example, vector has closure that refers to vector */
	       (slot_symbol(slot) == sc->local_signature_symbol)))
	    {
	      if (!sent_let)
		{
		  port_write_string(port)(sc, "(let (", 6, port);
		  sent_let = true;
		}
	      port_write_character(port)(sc, '(', port);
	      port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port);
	      port_write_character(port)(sc, ' ', port);
	      /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */
	      object_to_port(sc, slot_value(slot), port, p_Readable, NULL);
	      if (is_null(cdr(slots)))
		port_write_character(port)(sc, ')', port);
	      else port_write_string(port)(sc, ") ", 2, port);
	    }}
      if (sent_let) port_write_string(port)(sc, ") ", 2, port);
    }

  /* now we need to know if obj is in the closure_let via letrec, and if so, send out letrec+obj name+def below, then close it with obj-name??
   *  the two cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f (lambda () f)))...) which needs the letrec
   */
  if (!is_null(local_slots))
    for (s7_pointer slots = local_slots; is_pair(slots); slots = cdr(slots))
      {
	const s7_pointer slot = car(slots);
	if ((is_any_closure(slot_value(slot))) &&
	    (slot_value(slot) == obj))
	  {
	    port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */
	    sent_letrec = true;
	    port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port);
	    port_write_character(port)(sc, ' ', port);
	    obj_slot = slot;
	    break;
	  }}

  if (setter)
    port_write_string(port)(sc, "(dilambda ", 10, port);
  write_closure_readably_1(sc, obj, closure_pars(obj), body, port);
  if (setter)
    {
      port_write_character(port)(sc, ' ', port);
      if (has_closure_let(setter))
	write_closure_readably_1(sc, setter, closure_pars(setter), closure_body(setter), port);
      else object_to_port_with_circle_check(sc, setter, port, p_Readable, ci);
      port_write_character(port)(sc, ')', port);
    }
  if (sent_letrec)
    {
      port_write_string(port)(sc, ")) ", 3, port);
      port_write_string(port)(sc, symbol_name(slot_symbol(obj_slot)), symbol_name_length(slot_symbol(obj_slot)), port);
      port_write_character(port)(sc, ')', port);
    }
  if (sent_let)
    port_write_character(port)(sc, ')', port);
  s7_gc_unprotect_at(sc, gc_loc);
}

static void iterator_hash_table_to_port(s7_scheme *sc, s7_pointer port, s7_pointer table)
{
  if (is_weak_hash_table(table))
    port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port);
  else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port);
}

static void iterator_to_port(s7_scheme *sc, s7_pointer iter, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  if (use_write == p_Readable)
    {
      if (iterator_is_at_end(iter))
	{
	  switch (type(iterator_sequence(iter)))
	    {
	    case T_NIL:
	    case T_PAIR:           port_write_string(port)(sc, "(make-iterator ())", 18, port);	     break;
	    case T_STRING:         port_write_string(port)(sc, "(make-iterator \"\")", 18, port);    break;
	    case T_BYTE_VECTOR:    port_write_string(port)(sc, "(make-iterator #u())", 20, port);    break;
	    case T_VECTOR:         port_write_string(port)(sc, "(make-iterator #())", 19, port);     break;
	    case T_INT_VECTOR:	   port_write_string(port)(sc, "(make-iterator #i())", 20, port);    break;
	    case T_FLOAT_VECTOR:   port_write_string(port)(sc, "(make-iterator #r())", 20, port);    break;
	    case T_COMPLEX_VECTOR: port_write_string(port)(sc, "(make-iterator #c())", 20, port);    break;
	    case T_LET:	           port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break;
	    case T_HASH_TABLE:     iterator_hash_table_to_port(sc, port, iterator_sequence(iter));   break;
	    default:
	      port_write_string(port)(sc, "(make-iterator ())", 18, port);
	      break; /* c-object?? function? */
	    }}
      else
	{
	  const s7_pointer seq = iterator_sequence(iter);
	  int32_t iter_ref;
	  if ((ci) &&
	      (is_cyclic(iter)) &&
	      ((iter_ref = peek_shared_ref(ci, iter)) != 0))
	    {
	      /* basically the same as c_pointer_to_port */
	      if (!is_cyclic_set(iter))
		{
		  int32_t nlen;
		  char buf[Out_Bufsize];
		  if (iter_ref < 0) iter_ref = -iter_ref;

		  if (ci->init_port == sc->F)
		    {
		      ci->init_port = s7_open_output_string(sc);
		      ci->init_loc = gc_protect_1(sc, ci->init_port);
		    }
		  port_write_string(port)(sc, "#f", 2, port);
		  nlen = (int32_t)catstrs_direct(buf, "  (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL);
		  port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port);

		  flip_ref(ci, seq);
		  object_to_port_with_circle_check(sc, seq, ci->init_port, use_write, ci);
		  flip_ref(ci, seq);

		  port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port);
		  set_cyclic_set(iter);
		  return;
		}}

	  if (is_string(seq))
	    {
	      const s7_int len = string_length(seq) - iterator_position(iter);
	      if (len == 0)
		port_write_string(port)(sc, "(make-iterator \"\")", 18, port);
	      else
		{
		  const char *iter_str = (const char *)(string_value(seq) + iterator_position(iter));
		  port_write_string(port)(sc, "(make-iterator \"", 16, port);
		  if (!string_needs_slashification((const uint8_t *)iter_str, len))
		    port_write_string(port)(sc, iter_str, len, port);
		  else slashify_string_to_port(sc, port, iter_str, len, Not_In_Quotes);
		  port_write_string(port)(sc, "\")", 2, port);
		}}
	  else
	    {
	      if (is_pair(seq))
		{
		  port_write_string(port)(sc, "(make-iterator ", 15, port);
		  object_to_port_with_circle_check(sc, iterator_current(iter), port, use_write, ci);
		  port_write_character(port)(sc, ')', port);
		}
	      else
		{
		  if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->starlet))
		    {
		      port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port);
		      object_to_port_with_circle_check(sc, seq, port, use_write, ci);
		      port_write_string(port)(sc, "))) ", 4, port);
		      for (s7_pointer slot = let_slots(seq); slot != let_iterator_slot(iter); slot = next_slot(slot))
			port_write_string(port)(sc, "(iter) ", 7, port);
		      port_write_string(port)(sc, "iter)", 5, port);
		    }
		  else
		    {
		      if (iterator_position(iter) > 0)
			port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port);
		      else port_write_string(port)(sc, "(make-iterator ", 15, port);
		      object_to_port_with_circle_check(sc, seq, port, use_write, ci);
		      if (iterator_position(iter) > 0)
			{
			  if (iterator_position(iter) == 1)
			    port_write_string(port)(sc, "))) (iter) iter)", 16, port);
			  else
			    {
			      char str[128];
			      int32_t nlen = (int32_t)catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ",
								     pos_int_to_str_direct(sc, iterator_position(iter)),
								     ") iter) (iter)))", (const char *)NULL);
			      port_write_string(port)(sc, str, nlen, port);
			    }}
		      else port_write_character(port)(sc, ')', port);
		    }}}}}
  else
    {
      const char *str;
      if ((is_hash_table(iterator_sequence(iter))) && (is_weak_hash_table(iterator_sequence(iter))))
	str = "weak-hash-table";
      else
	if (iterator_sequence(iter) == sc->starlet)
	  str = "*s7*";
	else str = type_name(sc, iterator_sequence(iter), No_Article);
      port_write_string(port)(sc, "#<iterator: ", 12, port);
      port_write_string(port)(sc, str, safe_strlen(str), port);
      port_write_character(port)(sc, '>', port);
    }
}

static void c_pointer_to_port(s7_scheme *sc, s7_pointer cptr, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  #define Cp_Bufsize 128
  char buf[Cp_Bufsize];
  int32_t nlen;
  if (use_write == p_Readable)
    {
      int32_t ref;
      if ((ci) &&
	  (is_cyclic(cptr)) &&
	  ((ref = peek_shared_ref(ci, cptr)) != 0))
	{
	  port_write_string(port)(sc, "#f", 2, port);
	  if (!is_cyclic_set(cptr))
	    {
	      if (ci->init_port == sc->F)
		{
		  ci->init_port = s7_open_output_string(sc);
		  ci->init_loc = gc_protect_1(sc, ci->init_port);
		}
	      nlen = snprintf(buf, Cp_Bufsize, "  (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(cptr));
	      port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port);

	      if ((c_pointer_type(cptr) != sc->F) ||
		  (c_pointer_info(cptr) != sc->F))
		{
		  flip_ref(ci, c_pointer_type(cptr));

		  port_write_character(ci->init_port)(sc, ' ', ci->init_port);
		  object_to_port_with_circle_check(sc, c_pointer_type(cptr), ci->init_port, use_write, ci);

		  flip_ref(ci, c_pointer_type(cptr));
		  flip_ref(ci, c_pointer_info(cptr));

		  port_write_character(ci->init_port)(sc, ' ', ci->init_port);
		  object_to_port_with_circle_check(sc, c_pointer_info(cptr), ci->init_port, use_write, ci);

		  flip_ref(ci, c_pointer_info(cptr));
		}
	      port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port);
	      set_cyclic_set(cptr);
	    }}
      else
	{
	  nlen = snprintf(buf, Cp_Bufsize, "(c-pointer %" p64, (intptr_t)c_pointer(cptr));
	  port_write_string(port)(sc, buf, clamp_length(nlen, Cp_Bufsize), port);
	  if ((c_pointer_type(cptr) != sc->F) ||
	      (c_pointer_info(cptr) != sc->F))
	    {
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, c_pointer_type(cptr), port, use_write, ci);
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, c_pointer_info(cptr), port, use_write, ci);
	    }
	  port_write_character(port)(sc, ')', port);
	}}
  else
    {
      if ((is_symbol(c_pointer_type(cptr))) &&
	  (symbol_name_length(c_pointer_type(cptr)) < (Cp_Bufsize / 2)))
	nlen = snprintf(buf, Cp_Bufsize, "#<%s %p>", symbol_name(c_pointer_type(cptr)), c_pointer(cptr));
      else nlen = snprintf(buf, Cp_Bufsize, "#<c_pointer %p>", c_pointer(cptr));
      port_write_string(port)(sc, buf, clamp_length(nlen, Cp_Bufsize), port);
    }
}

static void random_state_to_port(s7_scheme *sc, s7_pointer rs, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  #define B_Bufsize 128
  char buf[B_Bufsize];
  int32_t nlen;
#if With_Gmp
  if (use_write == p_Readable)
    nlen = snprintf(buf, B_Bufsize, "#<bignum random-state>");
  else nlen = snprintf(buf, B_Bufsize, "#<random-state %p>", rs);
#else
  if (use_write == p_Readable)
    nlen = snprintf(buf, B_Bufsize, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(rs), random_carry(rs));
  else nlen = snprintf(buf, B_Bufsize, "#<random-state %" PRIu64 " %" PRIu64 ">", random_seed(rs), random_carry(rs));
#endif
  port_write_string(port)(sc, buf, clamp_length(nlen, B_Bufsize), port);
}

static void display_fallback(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
#if s7_Debugging
  print_debugging_state(sc, obj, port);
#else
  if (is_free(obj))
    port_write_string(port)(sc, "<free cell!>", 12, port);
  else port_write_string(port)(sc, "<unknown object!>", 17, port);
#endif
}

static void unique_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
}

static void undefined_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if ((obj != sc->undefined) && (use_write == p_Readable))
    {
      port_write_string(port)(sc, "(with-input-from-string \"", 25, port);
      port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port);
      port_write_string(port)(sc, "\" read)", 7, port);
    }
  else port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port);
}

static void eof_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (use_write == p_Readable)
    port_write_string(port)(sc, "(begin #<eof>)", 14, port);
  else port_write_string(port)(sc, eof_name(obj), eof_name_length(obj), port);
}

static void counter_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  port_write_string(port)(sc, "#<counter>", 10, port);
}

static void integer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  /* killer overhead here; breaking it into named/unnamed funcs helps only slightly -- still ridiculous overhead according to callgrind */
  const s7_int num = integer(obj);
  if ((num < 10) && (num >= 0))
    {
      static const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"};
      if (is_string_port(port))
	{
	  if (port_position(port) + 1 < port_data_size(port))
	    {
	      memcpy((void *)(port_data(port) + port_position(port)), (void *)ones[num], 1);
	      port_position(port) += 1;
	    }
	  else string_write_string_resized(sc, ones[num], 1, port);
	}
      else port_write_string(port)(sc, ones[num], 1, port);
    }
  else
    {
      s7_int nlen = 0;
      const char *str = integer_to_string(sc, integer(obj), &nlen);
      port_write_string(port)(sc, str, nlen, port);
    }
}

static void number_to_port(s7_scheme *sc, s7_pointer num, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  s7_int nlen = 0;
  char *str = number_to_string_base_10(sc, num, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */
  port_write_string(port)(sc, str, nlen, port);
}

#if With_Gmp
static void big_number_to_port(s7_scheme *sc, s7_pointer num, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  s7_int nlen = 0;
  block_t *str = big_number_to_string_with_radix(sc, num, Base_10, 0, &nlen, use_write);
  port_write_string(port)(sc, (char *)block_data(str), nlen, port);
  liberate(sc, str);
}
#endif

static void syntax_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  if (is_initial_value(obj))
    port_write_string(port)(sc, "#_", 2, port);
  port_display(port)(sc, symbol_name(syntax_symbol(obj)), port);
}

static void character_to_port(s7_scheme *sc, s7_pointer c, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (use_write == p_Display)
    port_write_character(port)(sc, character(c), port);
  else port_write_string(port)(sc, character_name(c), character_name_length(c), port);
}

static void closure_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  if (has_active_methods(sc, func))
    {
      /* look for object->string method else fallback on ordinary case.
       * can't use recursion on closure_let here because then the fallback name is #<let>.
       * this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1))))
       *   calls object->string on the closure whose closure_let is the mock-c-pointer;
       *   it has an object->string method that clears mock-c-pointers and tries again...
       *   so, display methods need to use coverlet/openlet.
       */
      const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol);
      if (print_func != sc->undefined)
	{
	  s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func));
	  if (string_length(str) > 0)
	    port_write_string(port)(sc, string_value(str), string_length(str), port);
	  return;
	}}
  if (use_write == p_Readable)
    write_closure_readably(sc, func, port, ci);
  else write_closure_name(sc, func, port);
}

static void macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (has_active_methods(sc, func))
    {
      const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol);
      if (print_func != sc->undefined)
	{
	  const s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func));
	  if (string_length(str) > 0)
	    port_write_string(port)(sc, string_value(str), string_length(str), port);
	  return;
	}}
  if (use_write == p_Readable)
    write_macro_readably(sc, func, port);
  else write_closure_name(sc, func, port);
}

static void c_function_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{                                                          /* includes c_function_star, so c_function_symbol can't be used */
  const s7_int len = c_function_name_length(func);

  if (is_string_port(port)) /* expand port_write_string -> string_write_string, 15 in tauto */
    {
      if (len > 0)
	{
	  if (port_position(port) + len + 2 < port_data_size(port))
	    {
	      if (is_initial_value(func))
		port_write_string(port)(sc, "#_", 2, port);
	      memcpy((void *)(port_data(port) + port_position(port)), (const void *)c_function_name(func), len);
	      port_position(port) += len;
	    }
	  else string_write_string_resized(sc, c_function_name(func), len, port);
	}
      else port_write_string(port)(sc, "#<c-function>", 13, port);
    }
  else
    if (len > 0)
      {
	if (is_initial_value(func))
	  port_write_string(port)(sc, "#_", 2, port);
	port_write_string(port)(sc, c_function_name(func), len, port);
      }
    else port_write_string(port)(sc, "#<c-function>", 13, port);
}

static void c_macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  if (c_macro_name_length(func) > 0)
    {
      if (is_initial_value(func))
	port_write_string(port)(sc, "#_", 2, port);
      port_write_string(port)(sc, c_macro_name(func), c_macro_name_length(func), port);
    }
  else port_write_string(port)(sc, "#<c-macro>", 10, port);
}

/* (eval-string (object->string (call-with-exit (lambda (go) go)) :readable)) should at least be readable if use_write == p_Readable,
 *   but the normal form "#<goto go>" gives a read-error due to the embedded space.  So if :readable, we return "#<goto::go>" which
 *   isn't going to do "the right thing", but at least it doesn't raise a read-error.
 */

static void continuation_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (is_symbol(continuation_name(obj)))
    {
      port_write_string(port)(sc, "#<continuation", 14, port);
      port_write_string(port)(sc, (use_write == p_Readable) ? "::" : " ", (use_write == p_Readable) ? 2 : 1, port);
      symbol_to_port(sc, continuation_name(obj), port, p_Display, NULL);
      port_write_character(port)(sc, '>', port);
    }
  else port_write_string(port)(sc, "#<continuation>", 15, port);
}

static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
{
  if (is_symbol(call_exit_name(obj)))
    {
      port_write_string(port)(sc, "#<goto", 6, port);
      port_write_string(port)(sc, (use_write == p_Readable) ? "::" : " ", (use_write == p_Readable) ? 2 : 1, port);
      symbol_to_port(sc, call_exit_name(obj), port, p_Display, NULL);
      port_write_character(port)(sc, '>', port);
    }
  else port_write_string(port)(sc, "#<goto>", 7, port);
}

static void catch_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  port_write_string(port)(sc, "#<catch: ", 9, port);
  object_to_port(sc, catch_tag(obj), port, use_write, ci);
  port_write_character(port)(sc, '>', port);
}

static void dynamic_wind_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */
  port_write_string(port)(sc, "#<dynamic-wind>", 15, port);
}

static void c_object_name_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  port_write_string(port)(sc, string_value(c_object_scheme_name(sc, obj)), string_length(c_object_scheme_name(sc, obj)), port);
}

static void c_object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
#if !Disable_Deprecated
  if (c_object_print(sc, obj))
    {
      const char *str = ((*(c_object_print(sc, obj)))(sc, c_object_value(obj)));
      port_display(port)(sc, str, port);
      free((void *)str);
      return;
    }
#endif
  if (c_object_to_string(sc, obj)) /* plist here and below can clobber args if Eval_Print */
    {
      set_mlist_2(sc, obj, (use_write == p_Readable) ? sc->readable_keyword : ((use_write == p_Write) ? sc->T : sc->F));
      port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, sc->mlist_2)), port);
    }
  else
    {
      if ((use_write == p_Readable) &&
	  (c_object_to_list(sc, obj)) &&  /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */
	  (c_object_set(sc, obj)))
	{
	  int32_t href;
	  const s7_pointer old_w = sc->w;
	  const s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj)));
	  sc->w = obj_list;
	  if ((ci) &&
	      (is_cyclic(obj)) &&
	      ((href = peek_shared_ref(ci, obj)) != 0))
	    {
	      s7_pointer p = obj_list;
	      if (href < 0) href = -href;
	      if ((ci->defined[href]) || (port == ci->cycle_port))
		{
		  char buf[Out_Bufsize];
		  int32_t nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL);
		  port_write_string(port)(sc, buf, nlen, port);
		  return;
		}
	      port_write_character(port)(sc, '(', port);
	      c_object_name_to_port(sc, obj, port);
	      for (int32_t i = 0; is_pair(p); i++, p = cdr(p))
		{
		  s7_pointer val = car(p);
		  if (has_structure(val))
		    {
		      char buf[Out_Bufsize];
		      int32_t symref;
		      int32_t len = (int32_t)catstrs_direct(buf, "  (set! (<", pos_int_to_str_direct(sc, href), "> ", pos_int_to_str_direct_1(sc, i), ") ", (const char *)NULL);
		      port_write_string(port)(sc, " #f", 3, port);
		      port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
		      symref = peek_shared_ref(ci, val);
		      if (symref != 0)
			{
			  if (symref < 0) symref = -symref;
			  len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, symref), ">)\n", (const char *)NULL);
			  port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port);
			}
		      else
			{
			  object_to_port_with_circle_check(sc, val, ci->cycle_port, p_Readable, ci);
			  port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port);
			}}
		  else
		    {
		      port_write_character(port)(sc, ' ', port);
		      object_to_port_with_circle_check(sc, val, port, p_Readable, ci);
		    }}}
	  else
	    {
	      port_write_character(port)(sc, '(', port);
	      c_object_name_to_port(sc, obj, port);
	      for (s7_pointer p = obj_list; is_pair(p); p = cdr(p))
		{
		  s7_pointer val = car(p);
		  port_write_character(port)(sc, ' ', port);
		  object_to_port_with_circle_check(sc, val, port, p_Readable, ci);
		}}
	  port_write_character(port)(sc, ')', port);
	  sc->w = old_w;
	}
      else
	{
	  char buf[Out_Bufsize];
	  int32_t nlen;
	  port_write_string(port)(sc, "#<", 2, port);
	  c_object_name_to_port(sc, obj, port);
	  nlen = snprintf(buf, Out_Bufsize, " %p>", obj);
	  port_write_string(port)(sc, buf, clamp_length(nlen, Out_Bufsize), port);
	}}
}

static void stack_to_port(s7_scheme *sc, const s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
{
  if (obj == sc->stack)
    port_write_string(port)(sc, "#<current stack>", 16, port);
  else port_write_string(port)(sc, "#<stack>", 8, port);
}

static void init_display_functions(void)
{
  for (int32_t i = 0; i < Num_Display_Functions; i++) display_functions[i] = display_fallback;
  display_functions[T_BACRO] =           macro_to_port;
  display_functions[T_BACRO_STAR] =      macro_to_port;
#if With_Gmp
  display_functions[T_BIG_COMPLEX] =     big_number_to_port;
  display_functions[T_BIG_INTEGER] =     big_number_to_port;
  display_functions[T_BIG_RATIO] =       big_number_to_port;
  display_functions[T_BIG_REAL] =        big_number_to_port;
#endif
  display_functions[T_BOOLEAN] =         unique_to_port;
  display_functions[T_BYTE_VECTOR] =     byte_vector_to_port;
  display_functions[T_CATCH] =           catch_to_port;
  display_functions[T_CHARACTER] =       character_to_port;
  display_functions[T_CLOSURE] =         closure_to_port;
  display_functions[T_CLOSURE_STAR] =    closure_to_port;
  display_functions[T_COMPLEX] =         number_to_port;
  display_functions[T_COMPLEX_VECTOR] =  complex_vector_to_port;
  display_functions[T_CONTINUATION] =    continuation_to_port;
  display_functions[T_COUNTER] =         counter_to_port;
  display_functions[T_C_FUNCTION] =      c_function_to_port;
  display_functions[T_C_FUNCTION_STAR] = c_function_to_port;
  display_functions[T_C_MACRO] =         c_macro_to_port;
  display_functions[T_C_OBJECT] =        c_object_to_port;
  display_functions[T_C_POINTER] =       c_pointer_to_port;
  display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port;
  display_functions[T_DYNAMIC_WIND] =    dynamic_wind_to_port;
  display_functions[T_EOF] =             eof_to_port;
  display_functions[T_FLOAT_VECTOR] =    float_vector_to_port;
  display_functions[T_GOTO] =            goto_to_port;
  display_functions[T_HASH_TABLE] =      hash_table_to_port;
  display_functions[T_INPUT_PORT] =      input_port_to_port;
  display_functions[T_INTEGER] =         integer_to_port;
  display_functions[T_INT_VECTOR] =      int_vector_to_port;
  display_functions[T_ITERATOR] =        iterator_to_port;
  display_functions[T_LET] =             let_to_port;
  display_functions[T_MACRO] =           macro_to_port;
  display_functions[T_MACRO_STAR] =      macro_to_port;
  display_functions[T_NIL] =             unique_to_port;
  display_functions[T_OUTPUT_PORT] =     output_port_to_port;
  display_functions[T_PAIR] =            pair_to_port;
  display_functions[T_RANDOM_STATE] =    random_state_to_port;
  display_functions[T_RATIO] =           number_to_port;
  display_functions[T_REAL] =            number_to_port;
  display_functions[T_SLOT] =            internal_slot_to_port;
  display_functions[T_STACK] =           stack_to_port;
  display_functions[T_STRING] =          string_to_port;
  display_functions[T_SYMBOL] =          symbol_to_port;
  display_functions[T_SYNTAX] =          syntax_to_port;
  display_functions[T_UNDEFINED] =       undefined_to_port;
  display_functions[T_UNSPECIFIED] =     unique_to_port;
  display_functions[T_UNUSED] =          unique_to_port;
  display_functions[T_VECTOR] =          vector_to_port;
}

static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
{
  const int32_t ref = (is_collected(obj)) ? shared_ref(ci, obj) : 0;
  if (ref == 0)
    object_to_port(sc, obj, port, use_write, ci);
  else
    {
      char buf[32];
      int32_t nlen;
      if (ref > 0)
	{
	  if (use_write == p_Readable)
	    {
	      if (ci->defined[ref])
		{
		  flip_ref(ci, obj);
		  nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, ref), ">", (const char *)NULL);
		  port_write_string(port)(sc, buf, nlen, port);
		  return;
		}
	      object_to_port(sc, obj, port, p_Readable, ci);
	    }
	  else
	    { /* "normal" printout involving #n= and #n# */
	      s7_int len = 0;
	      char *p = pos_int_to_str(sc, (s7_int)ref, &len, '=');
	      *--p = '#';
	      port_write_string(port)(sc, p, len, port);
	      object_to_port(sc, obj, port, not_p_display(use_write), ci);
	    }}
      else
	if (use_write == p_Readable)
	  {
	    nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL);
	    port_write_string(port)(sc, buf, nlen, port);
	  }
	else
	  {
	    s7_int len = 0;
	    char *p = pos_int_to_str(sc, (s7_int)(-ref), &len, '#');
	    *--p = '#';
	    port_write_string(port)(sc, p, len, port);
	  }}
}

static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
{
  ci->cycle_port = s7_open_output_string(sc);
  ci->cycle_loc = gc_protect_1(sc, ci->cycle_port);

  port_write_string(port)(sc, "(let (", 6, port);
  for (int32_t i = 0; i < ci->top; i++)
    {
      int32_t len;
      char buf[Out_Bufsize];
      int32_t ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */
      if (ref < 0) {ref = -ref; flip_ref(ci, ci->objs[i]);}
      len = (int32_t)catstrs_direct(buf, (i == 0) ? "(<" : "\n      (<", pos_int_to_str_direct(sc, ref), "> ", (const char *)NULL);
      port_write_string(port)(sc, buf, len, port);
      ci->defined[ref] = false;
      object_to_port_with_circle_check(sc, ci->objs[i], port, p_Readable, ci);
      port_write_character(port)(sc, ')', port);
      ci->defined[ref] = true;
      if (peek_shared_ref(ci, ci->objs[i]) > 0) flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */
    }
  port_write_string(port)(sc, ")\n", 2, port);

  if (ci->init_port != sc->F)
    {
      port_write_string(port)(sc, (const char *)(port_data(ci->init_port)), port_position(ci->init_port), port);
      s7_close_output_port(sc, ci->init_port);
      s7_gc_unprotect_at(sc, ci->init_loc);
      ci->init_port = sc->F;
    }

  if (port_position(ci->cycle_port) > 0)     /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */
    port_write_string(port)(sc, (const char *)(port_data(ci->cycle_port)), port_position(ci->cycle_port), port);
  s7_close_output_port(sc, ci->cycle_port);
  s7_gc_unprotect_at(sc, ci->cycle_loc);
  ci->cycle_port = sc->F;

  if ((is_immutable(obj)) && (!is_let(obj)))
    port_write_string(port)(sc, "  (immutable! ", 14, port);
  else port_write_string(port)(sc, "  ", 2, port);
  {
    const int32_t ref = peek_shared_ref(ci, obj);
    if (ref == 0)
      object_to_port_with_circle_check(sc, obj, port, p_Readable, ci);
    else
      {
	char buf[Out_Bufsize];
	const int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, (ref < 0) ? -ref : ref), ">", (const char *)NULL);
	port_write_string(port)(sc, buf, len, port);
      }}

  if ((is_immutable(obj)) && (!is_let(obj)))
    port_write_string(port)(sc, "))\n", 3, port);
  else port_write_string(port)(sc, ")\n", 2, port);
  return(obj);
}

static void object_out_1(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice)
{
  if (sc->object_out_locked)
    object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, sc->circle_info);
  else
    {
      shared_info_t *ci = load_shared_info(sc, T_Pos(obj), choice != p_Readable, sc->circle_info);
      if (ci)
	{
	  sc->object_out_locked = true;
	  if (choice == p_Readable)
	    cyclic_out(sc, obj, strport, ci);
	  else object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, ci);
	  sc->object_out_locked = false;
	}
      else object_to_port(sc, obj, strport, choice, NULL);
    }
}

static inline s7_pointer object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice)
{
  if ((has_structure(obj)) && (obj != sc->rootlet))
    object_out_1(sc, obj, strport, choice);
  else object_to_port(sc, obj, strport, choice, NULL);
  return(obj);
}

static s7_pointer new_format_port(s7_scheme *sc)
{
  const s7_int len = Format_Port_Length;
  block_t *block = mallocate(sc, len);
  block_t *b = mallocate_port(sc);
  const s7_pointer port = alloc_pointer(sc);
  set_full_type(port, T_OUTPUT_PORT);
  port_block(port) = b;
  port_port(port) = (port_t *)block_data(b);
  set_is_string_port(port);
  port_set_closed(port, false);
  port_data_size(port) = len;
  port_next(port) = NULL;
  port_data(port) = (uint8_t *)(block_data(block));
  port_data_block(port) = block;
  port_data(port)[0] = '\0';
  port_position(port) = 0;
  port_needs_free(port) = false;
  port_port(port)->pf = &output_string_functions;
#if s7_Debugging
  sc->format_ports_allocated++;
#endif
  return(port);
}

static inline s7_pointer open_format_port(s7_scheme *sc)
{
  const s7_pointer port = sc->format_ports;
  if (!port) return(new_format_port(sc));
  sc->format_ports = (s7_pointer)(port_next(port));
  port_position(port) = 0;
  port_data(port)[0] = '\0';
  return(port);
}

static void close_format_port(s7_scheme *sc, s7_pointer port)
{
  port_next(port) = (struct block_t *)(sc->format_ports);
  sc->format_ports = port;
}

char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj)
{
  char *str;
  s7_pointer strport;
  s7_int len;

  Track(sc);
  if ((sc->safety > No_Safety) &&
      (!s7_is_valid(sc, obj)))
    s7_warn(sc, s7_Warn_Bufsize, "the second argument to %s (the object): %p, is not an s7 object\n", __func__, obj);

  strport = open_format_port(sc);
  object_out(sc, T_Pos(obj), strport, p_Write);
  len = port_position(strport);
  if ((s7_Debugging) && (len == 0)) fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__);
  /* if (len == 0) {close_format_port(sc, strport); return(NULL);} */ /* probably never happens */
  str = (char *)Malloc(len + 1);
  memcpy((void *)str, (void *)port_data(strport), len);
  str[len] = '\0';
  close_format_port(sc, strport);
  return(str);
}

static inline void restore_format_port(s7_scheme *sc, s7_pointer strport)
{
  block_t *block = inline_mallocate(sc, Format_Port_Length);
  port_data(strport) = (uint8_t *)(block_data(block));
  port_data_block(strport) = block;
  port_data(strport)[0] = '\0';
  port_position(strport) = 0;
  port_data_size(strport) = Format_Port_Length;
  port_needs_free(strport) = false;
  close_format_port(sc, strport);
}


/* -------------------------------- object->string -------------------------------- */
s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */
{
  if ((sc->safety > No_Safety) &&
      (!s7_is_valid(sc, obj)))
    s7_warn(sc, s7_Warn_Bufsize, "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);
    object_out(sc, obj, strport, (use_write) ? p_Write : p_Display);
    if (port_position(strport) >= port_data_size(strport))
      result = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport));
    else result = block_to_string(sc, port_data_block(strport), port_position(strport));
    restore_format_port(sc, strport);
    return(result);
  }
}

static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_object_to_string "(object->string obj (write #t) (max-len (*s7* 'most-positive-fixnum))) returns a string representation of obj."
  #define Q_object_to_string s7_make_signature(sc, 4, \
                               sc->is_string_symbol, sc->T, \
                               s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol)
  use_write_t choice;
  const s7_pointer obj = car(args);
  s7_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 */

  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;
    object_out(sc, obj, strport, choice);
    sc->objstr_max_len = s7_Int64_Max;
    out_len = port_position(strport);

    if ((pending_max >= 0) &&
	(out_len > pending_max))
      {
	if (choice == p_Readable)  /* (object->string #r(1 2 3) :readable 4) */
	  {
	    close_format_port(sc, strport);
	    sc->has_openlets = old_openlets;
	    out_of_range_error_nr(sc, sc->object_to_string_symbol, Int_Three, wrap_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31));
	  }
	out_len = pending_max;
	if (out_len < 3)
	  {
	    close_format_port(sc, strport);
	    sc->has_openlets = old_openlets;
	    return(make_string_with_length(sc, "...", 3));
	  }
	for (s7_int i = out_len - 3; i < out_len; i++)
	  port_data(strport)[i] = (uint8_t)'.';
      }
    {
      s7_pointer result;
      if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */
	result = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len);
      else result = block_to_string(sc, port_data_block(strport), out_len);
      restore_format_port(sc, strport);
      sc->has_openlets = old_openlets;
      return(result);
    }}
}


/* -------------------------------- newline -------------------------------- */
void s7_newline(s7_scheme *sc, s7_pointer port)
{
  if (port != sc->F)
    port_write_character(port)(sc, (uint8_t)'\n', port);
}

#define newline_char chars[(uint8_t)'\n']

static s7_pointer g_newline(s7_scheme *sc, s7_pointer args)
{
  #define H_newline "(newline (port (current-output-port))) writes a carriage return to the port"
  #define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))

  const s7_pointer port = (is_pair(args)) ? car(args) : current_output_port(sc);
  if (!is_output_port(port))
    {
      if (port == sc->F) return(newline_char);
      if_method_exists_return_value(sc, port, sc->newline_symbol, args);
      sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, An_Output_Port_Or_F_String); /* 0 -> "zeroth" */
    }
  if (port_is_closed(port))
    sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, An_Open_Output_Port_String);
  s7_newline(sc, port);
  return(newline_char);  /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */
}

static s7_pointer newline_p(s7_scheme *sc)
{
  s7_newline(sc, current_output_port(sc));
  return(newline_char);
}

static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port)
{
  if (!is_output_port(port))
    {
      if (port == sc->F) return(newline_char);
      return(method_or_bust_p(sc, port, sc->newline_symbol, An_Output_Port_String));
    }
  s7_newline(sc, port);
  return(newline_char);
}


/* -------------------------------- write -------------------------------- */
s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  if (port != sc->F)
    {
      if (port_is_closed(port))
	wrong_type_error_nr(sc, sc->write_symbol, 2, port, An_Open_Output_Port_String);
      object_out(sc, obj, port, p_Write);
    }
  return(obj);
}

static s7_pointer write_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port)
{
  if (!is_output_port(port))
    {
      if (port == sc->F) return(x);
      if_method_exists_return_value(sc, port, sc->write_symbol, set_mlist_2(sc, x, port));
      wrong_type_error_nr(sc, sc->write_symbol, 2, port, An_Output_Port_Or_F_String);
    }
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->write_symbol, 2, port, An_Open_Output_Port_String);
  return(object_out(sc, x, port, p_Write));
}

static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
{
  #define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port"
  #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  if_method_exists_return_value(sc, car(args), sc->write_symbol, args);
  return(write_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}

static s7_pointer write_p_p(s7_scheme *sc, s7_pointer x)
{
  return((current_output_port(sc) == sc->F) ? x : object_out(sc, x, current_output_port(sc), p_Write));
}

static s7_pointer g_write_2(s7_scheme *sc, s7_pointer args) {return(write_p_pp(sc, car(args), cadr(args)));}

static s7_pointer write_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2) /* not check_for_substring_temp(sc, expr) here -- write returns arg so can be immutable if substring_uncopied */
    return((caddr(expr) == sc->F) ? sc->display_f : sc->write_2);
  return(func);
}


/* -------------------------------- display -------------------------------- */
s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  if (port != sc->F)
    {
      if (port_is_closed(port))
	wrong_type_error_nr(sc, sc->display_symbol, 2, port, An_Open_Output_Port_String);
      object_out(sc, obj, port, p_Display);
    }
  return(obj);
}

static s7_pointer display_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port)
{
  if (!is_output_port(port))
    {
      if (port == sc->F) return(x);
      if_method_exists_return_value(sc, port, sc->display_symbol, set_mlist_2(sc, x, port));
      wrong_type_error_nr(sc, sc->display_symbol, 2, port, An_Output_Port_Or_F_String);
    }
  if (port_is_closed(port))
    wrong_type_error_nr(sc, sc->display_symbol, 2, port, An_Open_Output_Port_String);
  if_method_exists_return_value(sc, x, sc->display_symbol, set_plist_2(sc, x, port));
  return(object_out(sc, x, port, p_Display));
}

static s7_pointer g_display(s7_scheme *sc, s7_pointer args)
{ /* infinite loop: (display (openlet (inlet 'display display))) -- not specific to display of course */
  #define H_display "(display obj (port (current-output-port))) prints obj"
  #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
  return(display_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}

static s7_pointer g_display_2(s7_scheme *sc, s7_pointer args) {return(display_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_display_f(s7_scheme *unused_sc, s7_pointer args) {return(car(args));}

static s7_pointer display_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */
    return((caddr(expr) == sc->F) ? sc->display_f : sc->display_2);
  return(func);
}

static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x)
{
  if (current_output_port(sc) == sc->F) return(x);
  if_method_exists_return_value(sc, x, sc->display_symbol, set_plist_1(sc, x));
  return(object_out(sc, x, current_output_port(sc), p_Display));
}

/* display may not be following the spec: (display '("a" #\b)): ("a" #\b), whereas Guile says (a b), in s7 write here == display, Guile write == s7 write */


/* -------------------------------- call-with-output-string -------------------------------- */
static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output"
  #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))

  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);     /* #<unused> here is a marker (needed) */
    push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */
    push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
  }
  return(sc->F);
}


/* -------------------------------- call-with-output-file -------------------------------- */
static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument"
  #define Q_call_with_output_file sc->pl_sf

  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); /* #<unused> here is a marker (needed) */
    push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
  }
  return(sc->F);
}


/* -------------------------------- with-output-to-string -------------------------------- */
static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, \
calls thunk, then returns the collected output"
  #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))

  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));
	}
      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);
}


/* -------------------------------- format -------------------------------- */
static s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer tp;
  if (!is_pair(lst)) return(sc->nil); /* avoiding this check saves no time */
  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);
}

static no_return void format_error_nr(s7_scheme *sc, const char *ur_msg, s7_int msg_len, const char *str, s7_pointer ur_args, format_data_t *fdat)
{
  s7_pointer err_list;
  const s7_pointer ctrl_str = (fdat->orig_str) ? fdat->orig_str : wrap_string(sc, str, safe_strlen(str));
  const s7_pointer args = (is_elist(ur_args)) ? copy_proper_list(sc, ur_args) : ur_args;
  const s7_pointer msg = wrap_string(sc, ur_msg, msg_len);
  if (fdat->loc == 0)
    {
      if (is_pair(args))
	err_list = set_elist_4(sc, Format_String_1, ctrl_str, args, msg);                                 /* "~S ~{~S~^ ~}: ~A" */
      else err_list = set_elist_3(sc, Format_String_2, ctrl_str, msg);                                    /* "~S: ~A" */
    }
  else
    if (is_pair(args))
      err_list = set_elist_5(sc, Format_String_3, ctrl_str, args, wrap_integer(sc, fdat->loc + 20), msg); /* "~S ~{~S~^ ~}~&~NT^: ~A" */
    else err_list = set_elist_4(sc, Format_String_4, ctrl_str, wrap_integer(sc, fdat->loc + 20), msg);    /* "~S~&~NT^: ~A" */
  if (fdat->port)
    {
      close_format_port(sc, fdat->port);
      fdat->port = NULL;
    }
  error_nr(sc, sc->format_error_symbol, err_list);
}

static void format_append_char(s7_scheme *sc, char c, s7_pointer port)
{
  port_write_character(port)(sc, c, port);
  sc->format_column++;
}

static void format_append_newline(s7_scheme *sc, s7_pointer port)
{
  port_write_character(port)(sc, '\n', port);
  sc->format_column = 0;
}

static void format_append_string(s7_scheme *sc, format_data_t *fdat, const char *str, s7_int len, s7_pointer port)
{
  port_write_string(port)(sc, str, len, port);
  fdat->loc += len;
  sc->format_column += len;
}

static void format_append_chars(s7_scheme *sc, format_data_t *fdat, char pad, s7_int chrs, s7_pointer port)
{
  if (is_string_port(port))
    {
      if ((port_position(port) + chrs) < port_data_size(port))
	{
	  local_memset((char *)port_data(port) + port_position(port), pad, chrs); /* unaligned */
	  port_position(port) += chrs;
	}
      else
	{
	  const s7_int new_len = port_position(port) + chrs;
	  resize_port_data(sc, port, new_len * 2);
	  local_memset((char *)port_data(port) + port_position(port), pad, chrs); /* unaligned */
	  port_position(port) = new_len;
	}
      fdat->loc += chrs;
      sc->format_column += chrs;
    }
  else
    {
      block_t *b = mallocate(sc, chrs + 1);
      char *str = (char *)block_data(b);
      local_memset((void *)str, pad, chrs);
      str[chrs] = '\0';
      format_append_string(sc, fdat, str, chrs, port);
      liberate(sc, b);
    }
}

static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str)
{
  /* we know that str[*cur_i] is a digit */
  s7_int i, new_int = 0;
  for (i = *cur_i; i < str_len - 1; i++)
    {
      int32_t dig = digits[(uint8_t)str[i]];
      if (dig < 10)
	{
#if Have_Overflow_Checks
	  if ((multiply_overflow(new_int, 10, &new_int)) ||
	      (add_overflow(new_int, dig, &new_int)))
	    break;
#else
	  new_int = dig + (new_int * 10);
#endif
	}
      else break;
    }
  *cur_i = i;
  return(new_int);
}

static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_int width, s7_int precision, char float_choice, char pad, s7_pointer port)
{
  if (width < 0) width = 0;
  /* precision choice depends on float_choice if it's -1 */
  if (precision < 0)
    {
      if ((float_choice == 'e') ||
	  (float_choice == 'f') ||
	  (float_choice == 'g'))
	precision = 6;
      else
	{
	  int32_t typ = type(car(fdat->args)); /* in the "int" cases, precision depends on the arg type */
	  precision = ((typ == T_INTEGER) || (typ == T_RATIO)) ? 0 : 6;
	}}
  /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */

  if (pad != ' ')
    {
      char *tmp, *padtmp;
      block_t *b = NULL;
      s7_int nlen = 0;
#if !With_Gmp
      if (radix == Base_10)
	tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, p_Write);
      else
#endif
	{
	  b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen);
	  tmp = (char *)block_data(b);
	}
      padtmp = tmp;
      while (*padtmp == ' ') (*(padtmp++)) = pad;
      format_append_string(sc, fdat, tmp, nlen, port);
      if (b) liberate(sc, b);
    }
  else
    {
      char *tmp;
      block_t *b = NULL;
      s7_int nlen = 0;
#if !With_Gmp
      if (radix == Base_10)
	tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, p_Write);
      else
#endif
	{
	  b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen);
	  tmp = (char *)block_data(b);
	}
      format_append_string(sc, fdat, tmp, nlen, port);
      if (b) liberate(sc, b);
    }
  fdat->args = cdr(fdat->args);
  fdat->ctr++;
}

static const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"};
static const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5};

static void format_ordinal_number(s7_scheme *sc, format_data_t *fdat, s7_pointer port)
{
  s7_int num = s7_integer_clamped_if_gmp(sc, car(fdat->args));
  if (num < 11)
    format_append_string(sc, fdat, ordinal[num], ordinal_length[num], port);
  else
    {
      s7_int nlen = 0;
      const char *tmp = integer_to_string(sc, num, &nlen);
      format_append_string(sc, fdat, tmp, nlen, port);
      num = num % 100;
      if ((num >= 11) && (num <= 13))
	format_append_string(sc, fdat, "th", 2, port);
      else
	{
	  num = num % 10;
	  if (num == 1) format_append_string(sc, fdat, "st", 2, port);
	  else
	    if (num == 2) format_append_string(sc, fdat, "nd", 2, port);
	    else
	      if (num == 3) format_append_string(sc, fdat, "rd", 2, port);
	      else format_append_string(sc, fdat, "th", 2, port);
	}}
  fdat->args = cdr(fdat->args);
  fdat->ctr++;
}

static s7_int format_nesting(const char *str, s7_int start, s7_int end)   /* start=i, end=str_len-1, assume ~{...~} */
{
  for (s7_int k = start + 2, nesting = 1; k < end; k++)
    if (str[k] == '~')
      {
	if (str[k + 1] == '}')
	  {
	    nesting--;
	    if (nesting == 0)
	      return(k - start - 1);
	  }
	else
	  if (str[k + 1] == '{')
	    nesting++;
      }
  return(-1);
}

static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer port)
{
  s7_pointer func;
  const s7_pointer obj = car(fdat->args);
  char ctrl_str[3];

  if ((!has_active_methods(sc, obj)) ||
      ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
    return(false);

  ctrl_str[0] = '~';
  ctrl_str[1] = str[0];
  ctrl_str[2] = '\0';

  if (port == obj)    /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */
    s7_apply_function(sc, func, set_plist_3(sc, port, wrap_string(sc, ctrl_str, 2), wrap_string(sc, "#<format port>", 14)));
  else s7_apply_function(sc, func, set_plist_3(sc, port, wrap_string(sc, ctrl_str, 2), obj));

  fdat->args = cdr(fdat->args);
  fdat->ctr++;
  return(true);
}

static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer args)
{
  if (is_null(fdat->args))          /* (format #f "~nT") */
    format_error_nr(sc, "~N: missing argument", 20, str, args, fdat);
  if (!s7_is_integer(car(fdat->args)))
    format_error_nr(sc, "~N: integer argument required", 29, str, args, fdat);
  {
    const s7_int n = s7_integer_clamped_if_gmp(sc, car(fdat->args));
    if (n < 0)
      format_error_nr(sc, "~N value is negative?", 21, str, args, fdat);
    if (n > sc->max_string_length)
      { /* desperation -- we need some string that will stay around long enough to be reported */
	int bytes = snprintf(sc->strbuf, sc->strbuf_size, "~N value is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length);
	format_error_nr(sc, sc->strbuf, bytes, str, args, fdat);
      }
    fdat->args = cdr(fdat->args);    /* I don't think fdat->ctr should be incremented here -- it's for (*s7* 'print-length) etc */
    return(n);
  }
}

static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, format_data_t *fdat, s7_int *i)
{
  s7_int old_i = *i;
  const s7_int width = format_read_integer(i, str_len, str);
  if (width < 0)
    {
      if (str[old_i - 1] != ',') /* need branches here, not if-expr because format_error creates the permanent string */
	format_error_nr(sc, "width is negative?", 18, str, fdat->args, fdat);
      format_error_nr(sc, "precision is negative?", 22, str, fdat->args, fdat);
    }
  if (width > sc->max_string_length)
    {
      int bytes;
      if (str[old_i - 1] != ',')
	bytes = snprintf(sc->strbuf, sc->strbuf_size, "width is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length);
      else bytes = snprintf(sc->strbuf, sc->strbuf_size, "precision is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length);
      format_error_nr(sc, sc->strbuf, bytes, str, fdat->args, fdat);
    }
  return(width);
}

static format_data_t *make_fdat(s7_scheme *sc)
{
  format_data_t *fdat = (format_data_t *)Calloc(1, sizeof(format_data_t)); /* not Malloc here! */
  fdat->curly_arg = sc->nil;
  return(fdat);
}

static format_data_t *open_format_data(s7_scheme *sc)
{
  format_data_t *fdat;
  sc->format_depth++;
  if (sc->format_depth >= sc->num_fdats)
    {
      int32_t new_num_fdats = sc->format_depth * 2;
      sc->fdats = (format_data_t **)Realloc(sc->fdats, sizeof(format_data_t *) * new_num_fdats);
      for (int32_t k = sc->num_fdats; k < new_num_fdats; k++) sc->fdats[k] = make_fdat(sc);
      sc->num_fdats = new_num_fdats;
    }
  fdat = sc->fdats[sc->format_depth];
#if 1
  if (fdat->port) /* happens a lot in tform */
    {
      close_format_port(sc, fdat->port);
      fdat->port = NULL;
    }
#endif
#if 0
  /* can happen but requires a lot of effort and is never repeatable! only fdat->curly_arg is GC protected?  */
  if (fdat->strport)
    {
      close_format_port(sc, fdat->strport);
      fdat->strport = NULL;
    }
#endif
  fdat->loc = 0;
  fdat->curly_arg = sc->nil;
  return(fdat);
}

#if With_Gmp
static bool is_one_or_big_one(s7_scheme *sc, s7_pointer num)
{
  if (!is_big_number(num)) return(is_one(num));
  if (is_t_big_integer(num)) return(mpz_cmp_ui(big_integer(num), 1) == 0);
  if (is_t_big_real(num)) return(mpfr_cmp_d(big_real(num), 1.0) == 0);
  return(false);
}
#else
#define is_one_or_big_one(Sc, Num) is_one(Num)
#endif

static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj);

#define With_Result true
#define Without_Result false
#define Columnized true
#define Not_Columnized false

static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args,
				   s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str)
{
  s7_int i, str_len;
  format_data_t *fdat;
  s7_pointer deferred_port;
  if (len <= 0)
    {
      str_len = safe_strlen(str);
      if (str_len == 0)
	{
	  if (is_pair(args))
	    error_nr(sc, sc->format_error_symbol,
		     set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args));
	  return(nil_string);
	}}
  else str_len = len;

  fdat = open_format_data(sc);
  fdat->args = args;
  fdat->orig_str = orig_str;

  if (with_result)
    {
      deferred_port = port;
      port = open_format_port(sc);
      fdat->port = port;
    }
  else deferred_port = sc->F;

  for (i = 0; i < str_len - 1; i++)
    {
      if ((uint8_t)(str[i]) == (uint8_t)'~')
	{
	  use_write_t use_write;
	  switch (str[i + 1])
	    {
	    case '%':                           /* -------- newline -------- */
	      /* sbcl apparently accepts numeric args here (including 0); use ~NC in s7: (format #f "~NC" 3 #\newline) */
	      if ((port_data(port)) &&
		  (port_position(port) < port_data_size(port)))
		{
		  port_data(port)[port_position(port)++] = '\n';
		  sc->format_column = 0;
		}
	      else format_append_newline(sc, port);
	      i++;
	      break;

	    case '&':                           /* -------- conditional newline -------- */
	      /* this only works if all output goes through format -- display/write for example do not update format_column */
	      if (sc->format_column > 0)
		format_append_newline(sc, port);
	      i++;
	      break;

	    case '~':                           /* -------- tilde -------- */
	      format_append_char(sc, '~', port);
	      i++;
	      break;

	    case '\n':                          /* -------- trim white-space --------  so (format #f "hiho~\n") -> "hiho"! */
	      for (i = i + 2; i <str_len - 1; i++)
		if (!white_space[(uint8_t)(str[i])])
		  {
		    i--;
		    break;
		  }
	      break;

	    case '*':                           /* -------- ignore arg -------- */
	      i++;
	      if (is_null(fdat->args))          /* (format #f "~*~A") */
		format_error_nr(sc, "can't skip argument!", 20, str, args, fdat);
	      fdat->args = cdr(fdat->args);
	      break;

	    case '|':                           /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */
	      if ((is_pair(fdat->args)) &&
		  (fdat->ctr >= sc->print_length))
		{
		  format_append_string(sc, fdat, " ...", 4, port);
		  fdat->args = sc->nil;
		}
	      /* fall through */

	    case '^':                           /* -------- exit -------- */
	      if (is_null(fdat->args))
		{
		  i = str_len;
		  goto All_Done;
		}
	      i++;
	      break;

	    case '@':                           /* -------- plural, 'y' or 'ies' -------- */
	      i += 2;
	      if ((str[i] != 'P') && (str[i] != 'p'))
		format_error_nr(sc, "unknown '@' directive", 21, str, args, fdat);
	      if (!is_pair(fdat->args))
		format_error_nr(sc, "'@' directive argument missing", 30, str, args, fdat);
	      if (!is_real(car(fdat->args)))        /* CL accepts non numbers here */
		format_error_nr(sc, "'@P' directive argument is not a real number", 44, str, args, fdat);

	      if (!is_one_or_big_one(sc, car(fdat->args)))
		format_append_string(sc, fdat, "ies", 3, port);
	      else format_append_char(sc, 'y', port);

	      fdat->args = cdr(fdat->args);
	      break;

	    case 'P': case 'p':                 /* -------- plural in 's' -------- */
	      if (!is_pair(fdat->args))
		format_error_nr(sc, "'P' directive argument missing", 30, str, args, fdat);
	      if (!is_real(car(fdat->args)))
		format_error_nr(sc, "'P' directive argument is not a real number", 43, str, args, fdat);
	      if (!is_one_or_big_one(sc, car(fdat->args)))
		format_append_char(sc, 's', port);
	      i++;
	      fdat->args = cdr(fdat->args);
	      break;

	    case '{':                           /* -------- iteration -------- */
	      {
		s7_int curly_len;

		if (is_null(fdat->args))
		  format_error_nr(sc, "missing argument", 16, str, args, fdat);

		if ((is_pair(car(fdat->args))) &&               /* any sequence is possible here */
		    (s7_list_length(sc, car(fdat->args)) < 0))  /* (format #f "~{~a~e~}" (cons 1 2)) */
		  /* we can't use !s7_is_proper_list(sc, car(fdat->args)) because cyclic lists are ok here */
		  format_error_nr(sc, "~{ argument is a dotted list", 28, str, args, fdat);

		curly_len = format_nesting(str, i, str_len - 1);

		if (curly_len == -1)
		  format_error_nr(sc, "'{' directive, but no matching '}'", 34, str, args, fdat);
		if (curly_len == 1)
		  format_error_nr(sc, "~{~}' doesn't consume any arguments!", 36, str, args, fdat);

		/* what about cons's here?  I can't see any way to specify the car or cdr of a cons within the format string */
		if (is_not_null(car(fdat->args)))               /* (format #f "~{~A ~}" ()) -> "" */
		  {
		    s7_pointer curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */
		    /* perhaps use an iterator here -- rootlet->list is expensive! */
		    if (is_pair(curly_arg))                    /* (format #f "~{~A ~}" #()) -> "" */
		      {
			char *curly_str = NULL;                /* this is the local (nested) format control string */
			s7_pointer cycle_arg;

			fdat->curly_arg = curly_arg;
			if (curly_len > fdat->curly_len)
			  {
			    if (fdat->curly_str) free(fdat->curly_str);
			    fdat->curly_len = curly_len;
			    fdat->curly_str = (char *)Malloc(curly_len);
			  }
			curly_str = fdat->curly_str;
			memcpy((void *)curly_str, (const void *)(str + i + 2), curly_len - 1);
			curly_str[curly_len - 1] = '\0';

			if ((sc->format_depth < sc->num_fdats - 1) &&
			    (sc->fdats[sc->format_depth + 1]))
			  sc->fdats[sc->format_depth + 1]->ctr = 0;

			/* it's not easy to use an iterator here instead of a list (so object->list isn't needed above),
			 *   because the curly brackets may enclose multiple arguments -- we would need to use
			 *   iterators throughout this function.
			 */
			cycle_arg = curly_arg;
			while (is_pair(curly_arg))
			  {
			    s7_pointer new_arg = sc->nil;
			    format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, Without_Result, columnized, curly_len - 1, NULL);
			    if (curly_arg == new_arg)
			      {
				if (cdr(curly_arg) == curly_arg) break;
				fdat->curly_arg = sc->nil;
				format_error_nr(sc, "'{...}' doesn't consume any arguments!", 38, str, args, fdat);
			      }
			    curly_arg = new_arg;
			    if ((!is_pair(curly_arg)) || (curly_arg == cycle_arg))
			      break;
			    cycle_arg = cdr(cycle_arg);
			    format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, Without_Result, columnized, curly_len - 1, NULL);
			    curly_arg = new_arg;
			  }
			fdat->curly_arg = sc->nil;
		      }
		    else
		      if (!is_null(curly_arg))
			format_error_nr(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat);
		  }
		i += (curly_len + 2); /* jump past the ending '}' too */
		fdat->args = cdr(fdat->args);
		fdat->ctr++;
	      }
	      break;

	    case '}':
	      format_error_nr(sc, "unmatched '}'", 13, str, args, fdat);

	    case '$':
	      use_write = p_Code; /* affects when symbols but not keywords are quoted (symbol_to_port and hash_table_to_port) */
	      goto Objstr;

	    case 'W': case 'w':
	      use_write = p_Readable;
	      goto Objstr;

	    case 'S': case 's':
	      use_write = p_Write;
	      goto Objstr;

	    case 'A': case 'a':
	      use_write = p_Display;
	    Objstr:                        /* object->string */
	      {
		s7_pointer obj;
		if (is_null(fdat->args))
		  format_error_nr(sc, "missing argument", 16, str, args, fdat);
		i++;
		obj = car(fdat->args);
		if ((use_write == p_Readable) ||
		    (!has_active_methods(sc, obj)) ||
		    (!format_method(sc, (const char *)(str + i), fdat, port)))
		  {
		    s7_pointer strport;
		    const bool old_openlets = sc->has_openlets;
		    /* for the column check, we need to know the length of the object->string output */

		    if ((!in_heap(fdat->args)) &&
			(has_active_methods(sc, obj)) &&
			(find_method_with_let(sc, obj, sc->object_to_string_symbol) != sc->undefined))
		      fdat->args = copy_proper_list(sc, fdat->args);
		    /* if format method do we need this copy? (see format_method) */

		    if (columnized)
		      {
			strport = open_format_port(sc);
			fdat->strport = strport;
		      }
		    else strport = port;
		    if (use_write == p_Readable)
		      sc->has_openlets = false;
		    object_out(sc, obj, strport, use_write);
		    if (use_write == p_Readable)
		      sc->has_openlets = old_openlets;
		    if (columnized)
		      {
			if (port_position(strport) >= port_data_size(strport))
			  resize_port_data(sc, strport, port_data_size(strport) * 2);
			port_data(strport)[port_position(strport)] = '\0';
			if (port_position(strport) > 0)
			  format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port);
			close_format_port(sc, strport);
			fdat->strport = NULL;
		      }
		    fdat->args = cdr(fdat->args);
		    fdat->ctr++;
		  }}
	      break;

	      /* -------- numeric args -------- */
	    case ':':
	      i += 2;
	      if ((str[i] != 'D') && (str[i] != 'd'))
		format_error_nr(sc, "unknown ':' directive", 21, str, args, fdat);
	      if (!is_pair(fdat->args))
		format_error_nr(sc, "':D' directive argument missing", 31, str, args, fdat);
	      if (!s7_is_integer(car(fdat->args)))
		format_error_nr(sc, "':D' directive argument is not an integer", 41, str, args, fdat);
	      if (s7_integer_clamped_if_gmp(sc, car(fdat->args)) < 0)
		format_error_nr(sc, "':D' directive argument can't be negative", 41, str, args, fdat);
	      format_ordinal_number(sc, fdat, port);
	      break;

	    case '0': case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9': case ',':
	    case 'N': case 'n':

	    case 'B': case 'b':
	    case 'D': case 'd':
	    case 'E': case 'e':
	    case 'F': case 'f':
	    case 'G': case 'g':
	    case 'O': case 'o':
	    case 'X': case 'x':

	    case 'T': case 't':
	    case 'C': case 'c':
	      {
		s7_int width = -1, precision = -1;
		char pad = ' ';
		i++;                                      /* str[i] == '~' */

		if (digitp((int32_t)(str[i])))
		  width = format_numeric_arg(sc, str, str_len, fdat, &i);
		else
		  if ((str[i] == 'N') || (str[i] == 'n'))
		    {
		      i++;
		      width = format_n_arg(sc, str, fdat, args);
		    }
		if (str[i] == ',')
		  {
		    i++;                                  /* is (format #f "~12,12D" 1) an error?  The precision (or is it the width?) has no use here */
		    if (digitp((int32_t)(str[i])))
		      precision = format_numeric_arg(sc, str, str_len, fdat, &i);
		    else
		      if ((str[i] == 'N') || (str[i] == 'n'))
			{
			  i++;
			  precision = format_n_arg(sc, str, fdat, args);
			}
		      else
			if (str[i] == '\'')              /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
			  {
			    pad = str[i + 1];
			    i += 2;
			    if (i >= str_len)            /* (format #f "~,'") */
			      format_error_nr(sc, "incomplete numeric argument", 27, str, args, fdat);
			  }}  /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */

		switch (str[i])
		  {
		    /* -------- pad to column --------
		     *   are columns numbered from 1 or 0?  there seems to be disagreement about this directive, does "space over to" mean including?
		     */
		  case 'T': case 't':
		    if (width == -1) width = 0;
		    if (precision == -1) precision = 0;
		    if ((width > 0) || (precision > 0))         /* (format #f "a~8Tb") */
		      {
			/* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T."))
			 * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%"))
			 */
			if (precision > 0)
			  {
			    int32_t mult = (int32_t)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */
			    if (mult < 1) mult = 1;
			    width += (precision * mult);
			  }
			width -= (sc->format_column + 1);
			if (width > 0)
			  format_append_chars(sc, fdat, pad, width, port);
		      }
		    break;

		  case 'C': case 'c':
		    {
		      s7_pointer obj;

		      if (is_null(fdat->args))
			format_error_nr(sc, "~~C: missing argument", 21, str, args, fdat);
		      /* the "~~" here and below protects against "~C" being treated as a directive */
		      obj = car(fdat->args);
		      if (!is_character(obj))
			{
			  if (!format_method(sc, (const char *)(str + i), fdat, port)) /* i stepped forward above */
			    format_error_nr(sc, "'C' directive requires a character argument", 43, str, args, fdat);
			}
		      else
			{
			  /* here use_write is false, so we just add the char, not its name */
			  if (width == -1)
			    format_append_char(sc, character(obj), port);
			  else
			    if (width > 0)
			      format_append_chars(sc, fdat, character(obj), width, port);

			  fdat->args = cdr(fdat->args);
			  fdat->ctr++;
			}}
		    break;

		    /* -------- numbers -------- */
		  case 'F': case 'f':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~F: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~F: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'f', pad, port);
		    break;

		  case 'G': case 'g':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~G: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~G: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'g', pad, port);
		    break;

		  case 'E': case 'e':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~E: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~E: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'e', pad, port);
		    break;

		    /* how to handle non-integer arguments in the next 4 cases?  clisp just returns
		     *   the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581:
		     *   "if arg is not an integer, it is printed in ~A format and decimal base")!!
		     *   I think I'll use the type of the number to choose the output format.
		     */
		  case 'D': case 'd':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~D: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			/* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123)))
			 *    port here is a string-port, str has the width/precision data if the caller wants it,
			 *    args is the current arg.  But format_number handles fdat->args and so on, so
			 *    I think I'll pass the format method the current control string (str), the
			 *    current object (car(fdat->args)), and the arglist (args), and assume it will
			 *    return a (scheme) string.
			 */
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~D: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'd', pad, port);
		    break;

		  case 'O': case 'o':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~O: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~O: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 8, width, precision, 'o', pad, port);
		    break;

		  case 'X': case 'x':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~X: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~X: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 16, width, precision, 'x', pad, port);
		    break;

		  case 'B': case 'b':
		    if (is_null(fdat->args))
		      format_error_nr(sc, "~~B: missing argument", 21, str, args, fdat);
		    if (!is_number(car(fdat->args)))
		      {
			if (!format_method(sc, (const char *)(str + i), fdat, port))
			  format_error_nr(sc, "~~B: numeric argument required", 30, str, args, fdat);
		      }
		    else format_number(sc, fdat, 2, width, precision, 'b', pad, port);
		    break;

		  default:
		    if (width > 0)
		      format_error_nr(sc, "unused numeric argument", 23, str, args, fdat);
		    format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat);
		  }}
	      break;

	    default:
	      format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat);
	    }}
      else /* str[i] is not #\~ */
	{
	  const char *p = (char *)strchr((const char *)(str + i + 1), (int)'~');
	  s7_int j = (p) ? p - str : str_len;
	  s7_int new_len = j - i;

	  if ((port_data(port)) &&
	      ((port_position(port) + new_len) < port_data_size(port)))
	    {
	      memcpy((void *)(port_data(port) + port_position(port)), (const void *)(str + i), new_len);
	      port_position(port) += new_len;
	    }
	  else port_write_string(port)(sc, (const char *)(str + i), new_len, port);
	  fdat->loc += new_len;
	  sc->format_column += new_len;
	  i = j - 1;
	}}

 All_Done:
  if (next_arg)
    (*next_arg) = fdat->args;
  else
    if (is_not_null(fdat->args))
      format_error_nr(sc, "too many arguments", 18, str, args, fdat);

  if (i < str_len)
    {
      if (str[i] == '~')
	format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat);
      format_append_char(sc, str[i], port);
    }
  sc->format_depth--;
  if (with_result)
    {
      s7_pointer result;
      if ((is_output_port(deferred_port)) &&
	  (port_position(port) > 0))
	{
	  if (port_position(port) < port_data_size(port))
	    port_data(port)[port_position(port)] = '\0';
	  port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port);
	}
      if (port_position(port) < port_data_size(port))
	{
	  if (port_position(port) == 0)
	    result = nil_string;
	  else
	    {
	      block_t *block = inline_mallocate(sc, Format_Port_Length); /* for format port after turning current format block into a string */
	      result = inline_block_to_string(sc, port_data_block(port), port_position(port));
	      port_data_size(port) = Format_Port_Length;
	      port_data_block(port) = block;
	      port_data(port) = (uint8_t *)(block_data(block));
	      port_data(port)[0] = '\0';
	      port_position(port) = 0;
	    }}
      else result = make_string_with_length(sc, (char *)port_data(port), port_position(port)); /* this can happen (s7test, pos/size=128) */
      close_format_port(sc, port); /* i.e. return it to the fdat free list */
      fdat->port = NULL;
      return(result);
    }
  return(nil_string);
}

static bool is_columnizing(const char *str)  /* look for ~t ~,<int>T ~<int>,<int>t */
{
  const char *p = (const char *)str;
  while (*p)
    {
      if (*p++ == '~') /* this is faster than strchr */
	{
	  char c = *p++;
	  if ((c == 't') || (c == 'T')) return(true);
	  if (!c) return(false);
	  if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N'))
	    {
	      while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++;
	      if ((c == 't') || (c == 'T')) return(true);
	      if (!c) return(false);                       /* ~,1 for example */
	      if (c == ',')
		{
		  c = *p++;
		  while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++;
		  if ((c == 't') || (c == 'T')) return(true);
		  if (!c) return(false);
		}}}}
  return(false);
}

static s7_pointer g_format(s7_scheme *sc, s7_pointer args)
{
  #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \
s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \
no a newline, ~~ = ~, ~<newline> trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \
~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \
~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \
spacing (and spacing character) and precision.  ~{ starts an embedded format directive which is ended by ~}: \n\
\n\
  >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\
  \"dashed: 1-2-3\"\n\
\n\
~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\
~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\
~E: (format #f \"~E\" 100.1) -&gt; \"1.001000e+02\" (%e in C)\n\
~F: (format #f \"~F\" 100.1) -&gt; \"100.100000\"   (%f in C)\n\
~G: (format #f \"~G\" 100.1) -&gt; \"100.1\"        (%g in C)\n\
\n\
If the 'out' argument is not an output port (i.e. #f, #t, or ()), the resultant string is returned.  If it \
is #t, the string is also sent to the current-output-port."

  #define Q_format s7_make_circular_signature(sc, 2, 3, \
                     sc->is_string_symbol, s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T)

  s7_pointer port = car(args);
  if (is_null(port))
    {
      port = current_output_port(sc);          /* () -> (current-output-port) */
      if (port == sc->F)                       /*   otherwise () -> #f so we get a returned string, which is confusing */
	return(nil_string);                    /*   was #f 18-Mar-24 */
    }
  sc->format_column = 0;
  if (!((is_boolean(port)) ||                  /* #f or #t */
	((is_output_port(port)) &&             /* (current-output-port) or call-with-open-file arg, etc */
	 (!port_is_closed(port)))))
    return(method_or_bust(sc, port, sc->format_symbol, args, An_Output_Port_String, 1));
  {
    const s7_pointer str = cadr(args);
    if (!is_string(str))
      return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2));
    return(format_to_port_1(sc, (port == sc->T) ? current_output_port(sc) : port,
			    string_value(str), cddr(args), NULL, !is_output_port(port), Columnized, string_length(str), str));
  }
}

const char *s7_format(s7_scheme *sc, s7_pointer args)
{
  s7_pointer result = g_format(sc, args);
  return((is_string(result)) ? string_value(result) : NULL);
}

static s7_pointer g_format_f(s7_scheme *sc, s7_pointer args)  /* port == #f, there are other args */
{
  const s7_pointer str = cadr(args);
  sc->format_column = 0;
  if (!is_string(str))
    return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2));
  return(format_to_port_1(sc, sc->F, string_value(str), cddr(args), NULL, With_Result, Columnized, string_length(str), str));
}

static s7_pointer g_format_nr(s7_scheme *unused_sc, s7_pointer unused_args)  /* port == #f, in do body, args already evaluated */
{
  return(nil_string);
}

static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port = car(args);
  const s7_pointer str = cadr(args);

  if (port == sc->F)
    return(str);
  if (is_null(port))
    {
      port = current_output_port(sc);
      if (port == sc->F)
	return(nil_string);
    }
  if (port == sc->T)
    {
      if ((current_output_port(sc) != sc->F) && (string_length(str) != 0))
	port_write_string(current_output_port(sc))(sc, string_value(str), string_length(str), current_output_port(sc));
      return(str);
    }
  if ((!is_output_port(port)) ||
      (port_is_closed(port)))
    return(method_or_bust(sc, port, sc->format_symbol, args, A_Format_Port_String, 1));

  if (string_length(str) == 0)
    return(nil_string);

  port_write_string(port)(sc, string_value(str), string_length(str), port);
  return(nil_string);
}

static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer obj = caddr(args);
  s7_pointer func;
  if ((!has_active_methods(sc, obj)) ||
      ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
    return(s7_object_to_string(sc, obj, false));
  return(s7_apply_function(sc, func, set_plist_3(sc, sc->F, cadr(args), obj)));
}

static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port = car(args);
  if (is_null(port))
    {
      port = current_output_port(sc);
      if (port == sc->F)
	return(nil_string);
    }
  if (!((is_boolean(port)) ||
	((is_output_port(port)) &&             /* (current-output-port) or call-with-open-file arg, etc */
	 (!port_is_closed(port)))))
    return(method_or_bust(sc, port, sc->format_symbol, args, A_Format_Port_String, 1));
  {
    const s7_pointer str = cadr(args);
    sc->format_column = 0;
    return(format_to_port_1(sc, (port == sc->T) ? current_output_port(sc) : port,
			    string_value(str), cddr(args), NULL,
			    !is_output_port(port),   /* i.e. is boolean as port so we're returning a string */
			    Not_Columnized,          /* we checked this in advance */
			    string_length(str), str));
  }
}

static s7_pointer format_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args > 1)
    {
      const s7_pointer port = cadr(expr);
      const s7_pointer str_arg = caddr(expr);
      if (is_string(str_arg))
	{
	  if ((args == 2) || (args == 3))
	    {
	      s7_int len;
	      char *orig = string_value(str_arg);
	      const char *p = strchr((const char *)orig, (int)'~');
	      if (!p)
		return((args == 2) ? sc->format_just_control_string : func);

	      len = string_length(str_arg);
	      if ((args == 2) &&
		  (len > 1) &&
		  (orig[len - 1] == '%') &&
		  ((p - orig) == len - 2))
		{
		  orig[len - 2] = '\n';
		  orig[len - 1] = '\0';
		  string_length(str_arg) = len - 1;
		  return(sc->format_just_control_string);
		}
	      if ((args == 3) && /* (format #f "~a" obj) */
		  (port == sc->F) &&
		  (len == 2) &&  /*            "~a"      */
		  (orig[0] == '~') && ((orig[1] == 'A') || (orig[1] == 'a')))
		return(sc->format_as_objstr);
	    }
	  /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */
	  if (!is_columnizing(string_value(str_arg)))
	    return(sc->format_no_column);
	}
      if (port == sc->F) return(sc->format_f);
    }
  return(func);
}


#if With_System_Extras
#include <fcntl.h>

/* -------------------------------- directory? -------------------------------- */
static bool is_directory_b_7p(s7_scheme *sc, s7_pointer p)
{
  if (!is_string(p))
    return(sole_arg_method_or_bust(sc, p, sc->is_directory_symbol, set_mlist_1(sc, p), sc->type_names[T_STRING]));
  if (string_length(p) >= 2)
    {
      block_t *b = expand_filename(sc, p);
      if (b)
	{
	  bool result = is_directory((char *)block_data(b));
	  liberate(sc, b);
	  return(result);
	}}
  return(is_directory(string_value(p)));
}

static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args)
{
  #define H_is_directory "(directory? str) returns #t if str is the name of a directory"
  #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
  return(make_boolean(sc, is_directory_b_7p(sc, car(args))));
}

/* -------------------------------- file-exists? -------------------------------- */
static bool file_probe(const char *arg)
{
#if !MS_Windows
  return(access(arg, F_OK) == 0);
#else
  int32_t fd = open(arg, O_RDONLY, 0);
  if (fd == -1) return(false);
  close(fd);
  return(true);
#endif
}

static bool file_exists_b_7p(s7_scheme *sc, s7_pointer filename)
{
  if (!is_string(filename))
    return(sole_arg_method_or_bust(sc, filename, sc->file_exists_symbol, set_mlist_1(sc, filename), sc->type_names[T_STRING]));
  if (string_length(filename) >= 2)
    {
      block_t *b = expand_filename(sc, filename);
      if (b)
	{
	  bool result = file_probe((char *)block_data(b));
	  liberate(sc, b);
	  return(result);
	}}
  if (is_wrapper(filename))
    {
      bool result;
      char *true_name = copy_string_with_length(string_value(filename), string_length(filename));
      result = file_probe(true_name); /* expansion if any would have happened above */
      free(true_name);
      return(result);
    }
  return(file_probe(string_value(filename)));
}

static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args)
{
  #define H_file_exists "(file-exists? filename) returns #t if the file exists"
  #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
  return(make_boolean(sc, file_exists_b_7p(sc, car(args))));
}

/* -------------------------------- delete-file -------------------------------- */
static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args)
{
  #define H_delete_file "(delete-file filename) deletes the file filename."
  #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)

  const s7_pointer name = car(args);
  if (!is_string(name))
    return(sole_arg_method_or_bust(sc, name, sc->delete_file_symbol, args, sc->type_names[T_STRING]));
  if (string_length(name) > 2)
    {
      block_t *b = expand_filename(sc, name);
      if (b)
	{
	  const s7_int result = unlink((char *)block_data(b));
	  liberate(sc, b);
	  if ((result == -1) && (sc->scheme_version == sc->r7rs_symbol))
	    file_error_nr(sc, "delete-file", strerror(errno), string_value(name));
	  return(make_integer(sc, result));
	}}
  {
    const s7_int result = unlink(string_value(name));
    if ((result == -1) && (sc->scheme_version == sc->r7rs_symbol))
      file_error_nr(sc, "delete-file", strerror(errno), string_value(name));
    return(make_integer(sc, result));
  }
}

/* -------------------------------- system -------------------------------- */
static s7_pointer g_system(s7_scheme *sc, s7_pointer args)
{
  #define H_system "(system command return-string) executes the command.  If the optional second argument is #t, \
system captures the output as a string and returns it."
  #define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol)

#ifdef __EMSCRIPTEN__
  return s7_nil(sc);
#else
  const s7_pointer name = car(args);
  if (!is_string(name))
    return(method_or_bust(sc, name, sc->system_symbol, args, sc->type_names[T_STRING], 2));
  if (is_pair(cdr(args)))
    {
      const s7_pointer return_string = cadr(args);
      if (return_string == sc->T)
	{
          #define Buf_Size 256
	  char buf[Buf_Size];
	  char *str = NULL;
	  int32_t cur_len = 0, full_len = 0;
	  FILE *fd = popen(string_value(name), "r");
	  while (fgets(buf, Buf_Size, fd))
	    {
	      const s7_int buf_len = safe_strlen(buf);
	      if (cur_len + buf_len >= full_len)
		{
		  full_len += Buf_Size * 2;
		  str = (str) ? (char *)Realloc(str, full_len) : (char *)Malloc(full_len);
		}
	      memcpy((void *)(str + cur_len), (void *)buf, buf_len);
	      cur_len += buf_len;
	    }
	  pclose(fd);
	  if (str)
	    {
	      block_t *b = mallocate_block(sc);
	      block_data(b) = (void *)str;
	      block_set_index(b, Top_Block_List);
#if s7_Debugging
	      sc->blocks_mallocated[Top_Block_List]++;
#endif
	      return(block_to_string(sc, b, cur_len));
	    }
	  return(nil_string);
	}
      if (return_string != sc->F)
	wrong_type_error_nr(sc, sc->system_symbol, 2, return_string, sc->type_names[T_BOOLEAN]);
    }
  return(make_integer(sc, system(string_value(name))));
#endif
}

#if !MS_Windows
#include <dirent.h>

/* -------------------------------- directory->list -------------------------------- */
static s7_pointer directory_to_list_1(s7_scheme *sc, const char *dir_name)
{
  DIR *dpos;
  begin_temp(sc->y, sc->nil);
  if ((dpos = opendir(dir_name)))
    {
      struct dirent *dirp;
      while ((dirp = readdir(dpos)))
	sc->y = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->y);
      closedir(dpos);
    }
  return_with_end_temp(sc->y);
}

static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)."
  #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol)   /* can return nil */

  const s7_pointer name = car(args);
  if (!is_string(name))
    return(method_or_bust_p(sc, name, sc->directory_to_list_symbol, sc->type_names[T_STRING]));
  if (string_length(name) >= 2)
    {
      block_t *b = expand_filename(sc, name);
      if (b)
	{
	  s7_pointer result = directory_to_list_1(sc, (char *)block_data(b));
	  liberate(sc, b);
	  return(result);
	}}
  return(directory_to_list_1(sc, string_value(name)));
}

/* -------------------------------- file-mtime -------------------------------- */
static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args)
{
  #define H_file_mtime "(file-mtime file): return the write date of file"
  #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)

  struct stat statbuf;
  int32_t err;
  const s7_pointer name = car(args);

  if (!is_string(name))
    return(sole_arg_method_or_bust(sc, name, sc->file_mtime_symbol, args, sc->type_names[T_STRING]));
  if (string_length(name) >= 2)
    {
      block_t *b = expand_filename(sc, name);
      if (b)
	{
	  err = stat((char *)block_data(b), &statbuf);
	  liberate(sc, b);
	  if (err < 0)
	    file_error_nr(sc, "file-mtime", strerror(errno), string_value(name));
	  return(make_integer(sc, (s7_int)(statbuf.st_mtime)));
	}}
  err = stat(string_value(name), &statbuf);
  if (err < 0)
    file_error_nr(sc, "file-mtime", strerror(errno), string_value(name));
  return(make_integer(sc, (s7_int)(statbuf.st_mtime)));
}
#endif /* !MS_Windows */
#endif /* With_System_Extras */


#if With_r7rs || With_System_Extras
/* -------------------------------- getenv -------------------------------- */
static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args) /* r7rs says #f if no such variable. this used to return "" in that case, 6-May-22 */
{
  #define H_getenv "(getenv var) returns the value of a let variable, or #f if none is found"
  #define Q_getenv s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_string_symbol)
  char *result;
  const s7_pointer name = car(args);
  if (!is_string(name))
    return(sole_arg_method_or_bust(sc, name, sc->getenv_symbol, args, sc->type_names[T_STRING]));
  result = getenv(string_value(name));
  return((result) ? s7_make_string(sc, result) : sc->F);
}
#endif

#if With_r7rs
/* -------------------------------- getenvs -------------------------------- */
extern char **environ;
static s7_pointer g_getenvs(s7_scheme *sc, s7_pointer unused_args)
{
  s7_pointer p = sc->nil;
  for (int32_t i = 0; environ[i]; i++)
    {
      const char *eq = strchr((const char *)environ[i], (int)'=');
      const s7_pointer name = s7_make_string_with_length(sc, environ[i], eq - environ[i]);
      const s7_pointer value = s7_make_string(sc, (char *)(eq + 1));
      p = cons(sc, cons(sc, name, value), p);
    }
  return(p);
}

/* -------------------------------- clock_gettime -------------------------------- */
static s7_pointer g_clock_gettime(s7_scheme *sc, s7_pointer args)
{
#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__))
  struct timespec t0;
  const s7_pointer clock_id = car(args); /* CLOCK_REALTIME probably */
  if (!s7_is_integer(clock_id))
    return(sole_arg_method_or_bust(sc, clock_id, sc->clock_gettime_symbol, args, sc->type_names[T_INTEGER]));
  {
    int res = clock_gettime(integer(clock_id), &t0);
    return(list_3(sc, make_integer(sc, res), make_integer(sc, t0.tv_sec), make_integer(sc, t0.tv_nsec)));
  }
#else
  return(Minus_One);
#endif
}

/* -------------------------------- time -------------------------------- */
static s7_pointer g_time(s7_scheme *sc, s7_pointer args)
{
#if !MS_Windows
  s7_pointer arg = car(args);
  time_t* time_val = (time_t*)s7_c_pointer_with_type(sc, arg, make_symbol(sc, "time_t*", 7), "time", 0); /* 0 = argnum */
  return(make_integer(sc, (s7_int)time(time_val)));
#else
  return(Minus_One);
#endif
}

/* -------------------------------- uname -------------------------------- */
#if !MS_Windows
#include <sys/utsname.h>

static s7_pointer g_uname(s7_scheme *sc, s7_pointer unused_args)
{
  struct utsname buf;
  uname(&buf);
  return(s7_list(sc, 5, s7_make_string(sc, buf.sysname),
		 s7_make_string(sc, buf.machine),
		 s7_make_string(sc, buf.nodename),
		 s7_make_string(sc, buf.version),
		 s7_make_string(sc, buf.release)));
}
#else
static s7_pointer g_uname(s7_scheme *sc, s7_pointer args)
{ /* return a list to be somewhat compatible with the uname-related functions */
  return(s7_list(sc, 5, nil_string, nil_string, nil_string, nil_string, nil_string));
}
#endif

/* -------------------------------- unlink -------------------------------- */
static s7_pointer g_unlink(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer arg = car(args);
  if (!s7_is_string(arg))
    sole_arg_wrong_type_error_nr(sc, sc->unlink_symbol, arg, sc->type_names[T_STRING]);
  return(make_integer(sc, (s7_int)unlink((char*)string_value(arg))));
}

/* -------------------------------- access -------------------------------- */
static s7_pointer g_access(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer path = car(args), mode = cadr(args);
  if (!s7_is_string(path))
    wrong_type_error_nr(sc, sc->access_symbol, 1, path, sc->type_names[T_STRING]);
  if (!s7_is_integer(mode))
    wrong_type_error_nr(sc, sc->access_symbol, 2, mode, sc->type_names[T_INTEGER]);
  return(make_integer(sc, (s7_int)access((char *)string_value(path), (int)integer(mode))));
}
#endif


/* -------------------------------- lists -------------------------------- */
s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  s7_pointer p;
  new_cell(sc, p, T_PAIR | T_Safe_Procedure);
  set_car(p, a);
  set_cdr(p, b);
  return(p);
}

static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  /* apparently slightly faster as a function? */
  s7_pointer p;
  new_cell_unchecked(sc, p, T_PAIR | T_Safe_Procedure);
  set_car(p, a);
  set_cdr(p, b);
  return(p);
}

#if s7_Debugging
static s7_pointer semipermanent_cons_1(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type, const char *func, int line)
#else
static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type)
#endif
{
  s7_pointer p = alloc_pointer(sc);
  set_full_type(p, type | T_Unheap);
  set_car(p, a);
  set_cdr_unchecked(p, b);
#if s7_Debugging
  set_alloc_info(p, func, line);
#endif
  return(p);
}

#if s7_Debugging
#define semipermanent_list(Sc, Len) semipermanent_list_1(Sc, Len, __func__, __LINE__)
static s7_pointer semipermanent_list_1(s7_scheme *sc, s7_int len, const char *func, int line)
#else
static s7_pointer semipermanent_list(s7_scheme *sc, s7_int len)
#endif
{
  s7_pointer p = sc->nil;
#if s7_Debugging
  for (s7_int j = 0; j < len; j++) p = semipermanent_cons_1(sc, sc->unused, p, T_PAIR | T_Immutable, func, line);
#else
  for (s7_int j = 0; j < len; j++) p = semipermanent_cons(sc, sc->unused, p, T_PAIR | T_Immutable);
#endif
  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, s7_Warn_Bufsize, "s7_make_circular_signature got too few entries: %s\n", display(result));
  return(result);
}


bool s7_is_pair(s7_pointer p) {return(is_pair(p));}
static s7_pointer is_pair_p_p(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? sc->T : sc->F);}

s7_pointer s7_car(s7_pointer p) {return(car(p));}
s7_pointer s7_cdr(s7_pointer p) {return(cdr(p));}

s7_pointer s7_cadr(s7_pointer p) {return(cadr(p));}
s7_pointer s7_cddr(s7_pointer p) {return(cddr(p));}
s7_pointer s7_cdar(s7_pointer p) {return(cdar(p));}
s7_pointer s7_caar(s7_pointer p) {return(caar(p));}

s7_pointer s7_caadr(s7_pointer p) {return(caadr(p));}
s7_pointer s7_caddr(s7_pointer p) {return(caddr(p));}
s7_pointer s7_cadar(s7_pointer p) {return(cadar(p));}
s7_pointer s7_caaar(s7_pointer p) {return(caaar(p));}
s7_pointer s7_cdadr(s7_pointer p) {return(cdadr(p));}
s7_pointer s7_cdddr(s7_pointer p) {return(cdddr(p));}
s7_pointer s7_cddar(s7_pointer p) {return(cddar(p));}
s7_pointer s7_cdaar(s7_pointer p) {return(cdaar(p));}

s7_pointer s7_caaadr(s7_pointer p) {return(caaadr(p));}
s7_pointer s7_caaddr(s7_pointer p) {return(caaddr(p));}
s7_pointer s7_caadar(s7_pointer p) {return(caadar(p));}
s7_pointer s7_caaaar(s7_pointer p) {return(caaaar(p));}
s7_pointer s7_cadadr(s7_pointer p) {return(cadadr(p));}
s7_pointer s7_cadddr(s7_pointer p) {return(cadddr(p));}
s7_pointer s7_caddar(s7_pointer p) {return(caddar(p));}
s7_pointer s7_cadaar(s7_pointer p) {return(cadaar(p));}

s7_pointer s7_cdaadr(s7_pointer p) {return(cdaadr(p));}
s7_pointer s7_cdaddr(s7_pointer p) {return(cdaddr(p));}
s7_pointer s7_cdadar(s7_pointer p) {return(cdadar(p));}
s7_pointer s7_cdaaar(s7_pointer p) {return(cdaaar(p));}
s7_pointer s7_cddadr(s7_pointer p) {return(cddadr(p));}
s7_pointer s7_cddddr(s7_pointer p) {return(cddddr(p));}
s7_pointer s7_cdddar(s7_pointer p) {return(cdddar(p));}
s7_pointer s7_cddaar(s7_pointer p) {return(cddaar(p));}

s7_pointer s7_set_car(s7_pointer p, s7_pointer q) {set_car(p, q); return(q);} /* both of these ignore immutable -- should they? */
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;  /* fill unprovided optional args */
}


/* ---------------- tree-leaves ---------------- */
static /* inline */ s7_int tree_len_1(s7_scheme *sc, s7_pointer p)
{
  s7_int sum;
  for (sum = 0; is_pair(p); p = cdr(p))
    {
      s7_pointer cp = car(p);
      if ((!is_pair(cp)) ||
	  (is_quote(sc, car(cp))))
	sum++;
      else
	{
	  do {
	    s7_pointer ccp = car(cp);
	    if ((!is_pair(ccp)) ||
		(is_quote(sc, car(ccp))))
	      sum++;
	    else
	      {
		do {
		  const s7_pointer cccp = car(ccp);
		  if ((!is_pair(cccp)) ||
		      (is_quote(sc, car(cccp))))
		    sum++;
		  else sum += tree_len_1(sc, cccp);
		  ccp = cdr(ccp);
		} while (is_pair(ccp));
		if (!is_null(ccp)) sum++;
	      }
	    cp = cdr(cp);
	    } while (is_pair(cp));
	  if (!is_null(cp)) sum++;
	}}
  return((is_null(p)) ? sum : sum + 1);
}

static inline s7_int tree_len(s7_scheme *sc, s7_pointer tree)
{
  if (is_null(tree))
    return(0);
  if ((!is_pair(tree)) || (is_quote(sc, car(tree))))
    return(1);
  return(tree_len_1(sc, tree));
}

static s7_int tree_leaves_i_7p(s7_scheme *sc, s7_pointer tree)
{
  if (!is_pair(tree))
    {
      if (is_null(tree)) return(0);
      if (!has_active_methods(sc, tree))
	sole_arg_wrong_type_error_nr(sc, sc->tree_leaves_symbol, tree, A_List_String);
      return(integer(find_and_apply_method(sc, tree, sc->tree_leaves_symbol, set_mlist_1(sc, tree))));
    }
  if ((sc->safety > No_Safety) && (tree_is_cyclic(sc, tree)))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree));
  return(tree_len(sc, tree));
}

static s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree)
{
  if (is_list(tree))
    {
      if ((sc->safety > No_Safety) && (tree_is_cyclic(sc, tree)))
	error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree));
      return(make_integer(sc, tree_len(sc, tree)));
    }
  return(method_or_bust_p(sc, tree, sc->tree_leaves_symbol, A_List_String));
}

static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args)
{
  #define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree"
  #define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_list_symbol)
  return(tree_leaves_p_p(sc, car(args)));
}


/* ---------------- tree-memq ---------------- */
static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree)    /* sym need not be a symbol, only lt.scm, inline = 25  */
{
  if (is_quote(sc, car(tree)))
    return((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(tree))) && (sym == cadr(tree)));
  do {
    if (sym == car(tree))
      return(true);
    if (is_pair(car(tree)))
      {
	s7_pointer cp = car(tree);
	if (is_quote(sc, car(cp)))
	  {
	    if ((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(cp))) && (sym == cadr(cp)))
	      return(true);
	  }
	else
	  do {
	      if (sym == car(cp))
		return(true);
	      if ((is_pair(car(cp))) && (tree_memq_1(sc, sym, car(cp))))
		return(true);
	      cp = cdr(cp);
	      if (sym == cp)
		return(true);
	    } while (is_pair(cp));
      }
    tree = cdr(tree);
    if (sym == tree)
      return(true);
  } while (is_pair(tree));
  return(false);
}

bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree)
{
  if (sym == tree) return(true);
  if (!is_pair(tree)) return(false); /* this happens a lot */
  if ((sc->safety > No_Safety) && (tree_is_cyclic(sc, tree)))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-memq: tree is cyclic: ~S", 29), tree));
  return(tree_memq_1(sc, sym, tree));
}

static bool tree_memq_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer tree)
{
  if (!is_list(tree))
    {
      if (!has_active_methods(sc, tree))
	wrong_type_error_nr(sc, sc->tree_memq_symbol, 2, tree, A_List_String);
      return(find_and_apply_method(sc, tree, sc->tree_memq_symbol, set_mlist_2(sc, sym, tree)) != sc->F);
    }
  return(s7_tree_memq(sc, sym, tree));
}

static s7_pointer g_tree_memq(s7_scheme *sc, s7_pointer args)
{
  #define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree."
  #define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_list_symbol)
  return(make_boolean(sc, tree_memq_b_7pp(sc, car(args), cadr(args))));
}

static /* inline */ bool tree_including_quote_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree)    /* sym need not be a symbol */
{
  do {
    if (sym == car(tree))
      return(true);
    if (is_pair(car(tree)))
      {
	s7_pointer cp = car(tree);
	do {
	  if (sym == car(cp)) return(true);
	  if ((is_pair(car(cp))) && (tree_including_quote_memq(sc, sym, car(cp)))) return(true);
	  cp = cdr(cp);
	  if (sym == cp) return(true);
	} while (is_pair(cp));
      }
    tree = cdr(tree);
    if (sym == tree)
      return(true);
  } while (is_pair(tree));
  return(false);
}


/* ---------------- tree-set-memq ---------------- */
static inline bool pair_set_memq(s7_scheme *sc, s7_pointer tree)
{
  while (true)
    {
      const s7_pointer p = car(tree);
      if (is_symbol(p))
	{
	  if (symbol_is_in_small_symbol_set(sc, p))
	    return(true);
	}
      else
	if ((is_unquoted_pair(sc, p)) &&
	    (pair_set_memq(sc, p)))
	  return(true);
      tree = cdr(tree);
      if (!is_pair(tree)) break;
    }
  return((is_symbol(tree)) && (symbol_is_in_small_symbol_set(sc, tree)));
}

static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
{
  bool non_symbols = false;
  if (!is_list(syms))
    {
      if (!has_active_methods(sc, syms))
	wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 1, syms, A_List_String);
      return(find_and_apply_method(sc, syms, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree)) != sc->F);
    }
  if (!is_pair(tree))
    {
      if (is_null(tree)) return(false);
      /* (define (func) (do ((i 0 (+ i 1)) (var #f)) ((= i 1) var) (set! var (tree-set-memq (list) (block))))) (func) */
      if (!has_active_methods(sc, tree))
	wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, A_List_String);
      return(find_and_apply_method(sc, tree, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree)) != sc->F);
    }
  if (is_null(syms)) return(false);
  if (sc->safety > No_Safety)
    {
      if (tree_is_cyclic(sc, syms))
	error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: symbol list is cyclic: ~S", 40), syms));
      if (tree_is_cyclic(sc, tree))
	error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree));
    }
  begin_small_symbol_set(sc);
  for (s7_pointer p = syms; is_pair(p); p = cdr(p))
    if (is_symbol(car(p)))
      add_symbol_to_small_symbol_set(sc, car(p));
    else non_symbols = true;
  {
    bool result = pair_set_memq(sc, tree);
    end_small_symbol_set(sc);
    if (result) return(true);
  }
  if (non_symbols)
    for (s7_pointer p = syms; is_pair(p); p = cdr(p))
      if ((!is_symbol(car(p))) &&
	  (s7_tree_memq(sc, car(p), tree)))
	return(true);
  return(false);
}

static s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
{
  return(make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree)));
}

static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args)
{
  #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree"
  #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_list_symbol, sc->is_list_symbol)
  return(make_boolean(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args))));
}

static s7_pointer tree_set_memq_syms_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
{
  if (!is_pair(tree))
    {
      if (is_null(tree)) return(sc->F);
      if (!has_active_methods(sc, tree))
	wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, A_List_String);
      return(find_and_apply_method(sc, tree, sc->tree_set_memq_symbol, set_mlist_2(sc, syms, tree)));
    }
  if (is_quote(sc, car(tree))) return(sc->F);
  if ((sc->safety > No_Safety) && (tree_is_cyclic(sc, tree)))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree));
  begin_small_symbol_set(sc);
  for (s7_pointer p = syms; is_pair(p); p = cdr(p))
    add_symbol_to_small_symbol_set(sc, car(p));
  {
    bool result = pair_set_memq(sc, tree);
    end_small_symbol_set(sc);
    return(make_boolean(sc, result));
  }
}

static s7_pointer g_tree_set_memq_syms(s7_scheme *sc, s7_pointer args)
{
  return(tree_set_memq_syms_direct(sc, car(args), cadr(args))); /* need other form for pp */
}

static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  if ((is_proper_quote(sc, cadr(expr))) &&   /* not (tree-set-memq (quote) ...) */
      (is_pair(cadadr(expr))))               /*  (tree-set-memq '(...)...) */
    {
      for (s7_pointer p = cadadr(expr); is_pair(p); p = cdr(p))
	if (!is_symbol(car(p)))
	  return(func);
      return(sc->tree_set_memq_syms);
    }
  return(func);
}


/* ---------------- tree-count ---------------- */
static s7_int tree_count(s7_scheme *sc, s7_pointer obj, s7_pointer tree, s7_int count)
{
  if (tree == obj) return(count + 1);
  if ((!is_pair(tree)) || (is_quote(sc, car(tree)))) return(count);
  return(tree_count(sc, obj, cdr(tree), tree_count(sc, obj, car(tree), count)));
}

static inline s7_int tree_count_at_least(s7_scheme *sc, s7_pointer obj, s7_pointer tree, s7_int count, s7_int top) /* lt inline=9 */
{
  if (tree == obj) return(count + 1);
  if ((!is_pair(tree)) || (is_quote(sc, car(tree)))) return(count);
  do {
    count = tree_count_at_least(sc, obj, car(tree), count, top);
    if (count >= top) return(count);
    tree = cdr(tree);
    if (tree == obj) return(count + 1);
  } while (is_pair(tree));
  return(count);
}

static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args)
{
  #define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)"
  #define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->is_list_symbol, sc->is_integer_symbol)
  const s7_pointer obj = car(args), tree = cadr(args);
  s7_pointer count;

  if (!is_pair(tree))
    {
      if ((is_pair(cddr(args))) &&
	  (!s7_is_integer(caddr(args))))
	wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]);
      if (is_null(tree)) return(Int_Zero);
      if (!has_active_methods(sc, tree))
	wrong_type_error_nr(sc, sc->tree_count_symbol, 2, tree, A_List_String);
      return(find_and_apply_method(sc, tree, sc->tree_count_symbol, set_mlist_2(sc, obj, tree)));
    }
  if ((sc->safety > No_Safety) && (tree_is_cyclic(sc, tree)))
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-count: tree is cyclic: ~S", 30), tree));
  if (is_null(cddr(args)))
    return(make_integer(sc, tree_count(sc, obj, tree, 0)));
  count = caddr(args);
  if (!s7_is_integer(count))
    wrong_type_error_nr(sc, sc->tree_count_symbol, 3, count, sc->type_names[T_INTEGER]);
  return(make_integer(sc, tree_count_at_least(sc, obj, tree, 0, s7_integer_clamped_if_gmp(sc, count))));
}


/* -------------------------------- pair? -------------------------------- */
static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args)
{
  #define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)"
  #define Q_is_pair sc->pl_bt
  check_boolean_method(sc, is_pair, sc->is_pair_symbol, args);
}


/* -------------------------------- list? -------------------------------- */
bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));}

static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));}

static s7_pointer g_is_list(s7_scheme *sc, s7_pointer args)
{
  #define H_is_list "(list? obj) returns #t if obj is a pair or null"
  #define Q_is_list sc->pl_bt
  #define is_a_list(P) s7_is_list(sc, P) /* for boolean method below */
  check_boolean_method(sc, is_a_list, sc->is_list_symbol, args);
}

static s7_int proper_list_length(s7_pointer a)
{
  s7_int i = 0;
  for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {};
  return(i);
}

static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer *c)
{
  s7_int i = 0;
  s7_pointer b;
  for (b = a; is_pair(b); i++, b = cdr(b)) {};
  *c = b;
  return(i);
}

s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is dotted, 0 if it's (directly) circular */
{
  s7_pointer slow = a, fast = a;
  for (s7_int i = 0; ; i += 2)
    {
      if (!is_pair(fast)) return((is_null(fast)) ? i : -i);
      fast = cdr(fast);
      if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); /* if unrolled further, it's a lot slower? */
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow)	return(0);
    }
  return(0);
}


/* -------------------------------- proper-list? -------------------------------- */
bool s7_is_proper_list(s7_scheme *sc, s7_pointer lst)
{
  /* #t if () or undotted/non-circular pair */
  s7_pointer slow = lst, fast = lst;
  while (true)
    {
      if (!is_pair(fast))
	return(is_null(fast)); /* else it's an improper list */
      Loop_4(fast = cdr(fast); if (!is_pair(fast)) return(is_null(fast)));
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow) return(false);
    }
  return(true);
}

static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args)
{
  #define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted."
  #define Q_is_proper_list sc->pl_bt
  const s7_pointer obj = car(args);
  s7_pointer func;
  if (!has_active_methods(sc, obj))
    return(make_boolean(sc, s7_is_proper_list(sc, obj)));
  func = find_method_with_let(sc, obj, sc->is_proper_list_symbol);
  if (func == sc->undefined)
    return(make_boolean(sc, s7_is_proper_list(sc, obj)));
  return(s7_apply_function(sc, func, set_mlist_1(sc, obj)));
  /* return(make_boolean(sc, s7_is_proper_list(sc, car(args)))); */
}

static s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, s7_is_proper_list(sc, arg)));}

static bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));}
static bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));}
static bool is_proper_list_3(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))) && (is_null(cdddr(p))));}
static bool is_proper_list_4(s7_scheme *unused_sc, s7_pointer p) {return(proper_list_length(p) == 4);}


/* -------------------------------- make-list -------------------------------- */
static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init)
{
  check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */
  begin_temp(sc->x, sc->nil);
  for (s7_int i = 0; i < len; i++) sc->x = cons_unchecked(sc, init, sc->x);
  return_with_end_temp(sc->x);
}

static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init) /* list inline=10? tmv=-1 (not inlined) */
{
  switch (len)
    {
    case 0: return(sc->nil);
    case 1: return(T_Pair(cons(sc, init, sc->nil)));
    case 2: return(T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil))));
    case 3: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))));
    case 4: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))));
    case 5: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))));
    case 6: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init,
                    cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))));
    case 7: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init,
		    cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))))));
    default: break;
    }
  return(make_big_list(sc, len, init));
}

s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));}

static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init)
{
  s7_int len;
  if (!s7_is_integer(n))
    return(method_or_bust(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), sc->type_names[T_INTEGER], 1));

  len = s7_integer_clamped_if_gmp(sc, n);
#if With_Gmp
  if ((len == 0) && (!is_zero(n)))
    out_of_range_error_nr(sc, sc->make_list_symbol, Int_One, n, wrap_string(sc, "big integer is too big for s7_int", 33));
#endif
  if (len == 0) return(sc->nil);          /* what about (make-list 0 123)? */
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_list_symbol, Int_One, n, It_Is_Negative_String);
  if (len > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-list length argument ~D is greater than (*s7* 'max-list-length), ~D", 72),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length)));
  return(make_list(sc, len, init));
}

static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args)
{
  #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'."
  #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T)
  return(make_list_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F));
}


/* -------------------------------- list-ref -------------------------------- */
s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num)
{
  s7_pointer p = lst;
  for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {}
  if (is_pair(p)) return(car(p));
  return(sc->nil);
}

static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
{
  s7_int index;
  s7_pointer p = lst;

  if (!s7_is_integer(ind))
    return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, sc->type_names[T_INTEGER], 2));
  index = s7_integer_clamped_if_gmp(sc, ind);
  if ((index < 0) || (index > sc->max_list_length)) /* max-list-length check for circular list-ref? */
    out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, ind, (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  if (is_pair(p)) return(car(p));
  if (is_null(p))
    out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, ind, It_Is_Too_Large_String);
  wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, A_Proper_List_String);
  return(NULL);
}

static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices);

static s7_pointer ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer in_obj, s7_pointer args)
{
  if (!is_applicable(in_obj)) /* let implicit_index shuffle syntax and closures */
    error_nr(sc, sc->syntax_error_symbol,
	     set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42),
			 set_ulist_1(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj));
  /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather than the global value as "caller" */
  return(implicit_index(sc, in_obj, cddr(args)));
}

static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list"
  #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol)
  /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */

  const s7_pointer lst = car(args);
  if (!is_pair(lst))
    return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
  {
    const s7_pointer obj = list_ref_1(sc, lst, cadr(args));
    if (is_pair(cddr(args)))
      return(ref_index_checked(sc, global_value(sc->list_ref_symbol), obj, args));
    return(obj);
  }
}

static bool op_implicit_pair_ref_a(s7_scheme *sc)
{
  const 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)
{
  const s7_pointer lst = lookup_checked(sc, car(arg));
  if (!is_pair(lst))
    return(s7_apply_function(sc, lst, set_mlist_1(sc, fx_call(sc, cdr(arg)))));
  return(list_ref_1(sc, lst, fx_call(sc, cdr(arg))));
}

static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices)
{
  if (!is_applicable(in_obj))
    {
      sc->temp9 = indices; /* ulist_1 below is not GC protected */
      error_nr(sc, sc->syntax_error_symbol,
	       set_elist_4(sc, wrap_string(sc, "~$ becomes (apply ~$ ...), but ~$ can't take arguments", 54),
			   set_ulist_1(sc, obj, sc->temp9), in_obj, in_obj));
    }
  return(implicit_index(sc, in_obj, cdr(indices)));
}

static bool op_implicit_pair_ref_aa(s7_scheme *sc)
{
  s7_pointer index;
  const 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)
    {
      const s7_pointer index = caddr(expr);
      if (is_t_integer(index))
	{
	  if (integer(index) == 0) return(sc->list_ref_at_0);
	  if (integer(index) == 1) return(sc->list_ref_at_1);
	  if (integer(index) == 2) return(sc->list_ref_at_2);
	}}
  return(func);
}

static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index) /* inline tlist=34! */
{
  s7_pointer p = lst;
  if (index < 0)
    out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, wrap_integer(sc, index), It_Is_Negative_String);
  if (index > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "list-ref index ~D is too large, (*s7* 'max-list-length) is ~D", 61),
			 wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length)));
  for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p));
  if (!is_pair(p))
    {
      if (is_null(p))
	out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
      wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, A_Proper_List_String);
    }
  return(car(p));
}

static s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer lst, s7_int index)
{
  if (!is_pair(lst))
    wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, sc->type_names[T_PAIR]);
  return(list_ref_p_pi_unchecked(sc, lst, index));
}

static s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer index)
{
  if (!is_pair(lst))
    return(g_list_ref(sc, set_plist_2(sc, lst, index)));
  if (!s7_is_integer(index))
    wrong_type_error_nr(sc, sc->list_ref_symbol, 1, index, sc->type_names[T_INTEGER]);
  return(list_ref_p_pi_unchecked(sc, lst, s7_integer_clamped_if_gmp(sc, index)));
}


/* -------------------------------- list-set! -------------------------------- */
s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val)
{
  s7_pointer p = lst;
  for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {}
  if (is_pair(p))
    set_car(p, T_Ext(val)); /* ignores possible immutable setting -- see also s7_set_car|cdr */
  return(val);
}

static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int32_t arg_num)
{
  #define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val"
  #define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)

  s7_int index;
  s7_pointer p = lst, ind;
  /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */
  if (!is_pair(lst))
    return(method_or_bust(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_PAIR], 1));
  ind = car(args);
  if (!s7_is_integer(ind))
    return(method_or_bust(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_INTEGER], 2));
  index = s7_integer_clamped_if_gmp(sc, ind);

  if (index < 0) /* arg_num used here so can't use list_set_index_check */
    out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, It_Is_Negative_String);
  if (index > sc->max_list_length) /* (list-set! (list 1 2 3) (ash 1 61) 0) */
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_4(sc, wrap_string(sc, "list-set! ~:D argument ~D is too large, (*s7* 'max-list-length) is ~D", 69),
			 wrap_integer(sc, arg_num), ind, wrap_integer(sc, sc->max_list_length)));

  for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  if (!is_pair(p))
    {
      if (is_null(p))
	out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, It_Is_Too_Large_String);
      wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, A_Proper_List_String);
    }

  if (is_null(cddr(args)))
    {
      if (is_immutable_pair(p))
	immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't list-set! '~S (it is immutable)", 37), lst));
      set_car(p, cadr(args));
    }
  else
    {
      if (!s7_is_pair(car(p)))
	wrong_number_of_arguments_error_nr(sc, "too many arguments for list-set!: ~S", 36, args);
      return(g_list_set_1(sc, car(p), cdr(args), arg_num + 1));
    }
  return(cadr(args)); /* args here == cdr(args) of original call */
}

static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) {return(g_list_set_1(sc, car(args), cdr(args), 2));}

static no_return void list_set_index_check_nr(s7_scheme *sc, s7_int index)
{
  if (index < 0)
    out_of_range_error_nr(sc, sc->list_set_symbol, Int_Two, wrap_integer(sc, index), It_Is_Negative_String);
  error_nr(sc, sc->out_of_range_symbol,
	   set_elist_3(sc, wrap_string(sc, "list-set! index ~D is too large, (*s7* 'max-list-length) is ~D", 62),
		       wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length)));
}

static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value)
{
  s7_pointer p = lst;
  if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index);
  for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p));
  if (!is_pair(p))
    {
      if (is_null(p))
	out_of_range_error_nr(sc, sc->list_set_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
      wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, A_Proper_List_String);
    }
  if (is_immutable_pair(p))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't list-set! '~S (it is immutable)", 37), p));
  set_car(p, value);
  return(value);
}

static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value) /* called in t101-12|14... */
{
  if (!is_pair(lst))
    wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, sc->type_names[T_PAIR]);
  return(list_set_p_pip_unchecked(sc, lst, index, value));
}

static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer lst = car(args);
  s7_pointer p = lst;
  s7_int index;
  if (!is_pair(p))
    return(method_or_bust(sc, lst, sc->list_set_symbol, args, sc->type_names[T_PAIR], 1));
  index = s7_integer_clamped_if_gmp(sc, cadr(args));
  if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index);

  for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  if (!is_pair(p))
    {
      if (is_null(p))
	out_of_range_error_nr(sc, sc->list_set_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
      wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, A_Proper_List_String);
    }
  {
    const s7_pointer val = caddr(args);
    if (is_immutable_pair(p))
      immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't list-set! '~S (it is immutable)", 37), p));
    set_car(p, val);
    return(val);
  }
}

static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args == 3) &&
      (s7_is_integer(caddr(expr))) &&
      (s7_integer_clamped_if_gmp(sc, caddr(expr)) >= 0) &&
      (s7_integer_clamped_if_gmp(sc, caddr(expr)) < sc->max_list_length))
    return(sc->list_set_i);
  return(func);
}


/* -------------------------------- list-tail -------------------------------- */
static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
{
  s7_int i, index;
  if (!s7_is_integer(ind))
    return(method_or_bust_pp(sc, ind, sc->list_tail_symbol, lst, ind, sc->type_names[T_INTEGER], 2));
  index = s7_integer_clamped_if_gmp(sc, ind);

  if (!is_list(lst)) /* (list-tail () 0) -> () */
    return(method_or_bust_pp(sc, lst, sc->list_tail_symbol, lst, ind, A_List_String, 1));
  if (index < 0)
    out_of_range_error_nr(sc, sc->list_tail_symbol, Int_Two, wrap_integer(sc, index), It_Is_Negative_String);
  if (index > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "list-tail index ~D is too large, (*s7* 'max-list-length) is ~D", 62),
			 wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length)));

  for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) {}
  if (i < index)
    out_of_range_error_nr(sc, sc->list_tail_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
  return(lst);
}

static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
{
  #define H_list_tail "(list-tail lst i) returns the list from the i-th element on"
  #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */
  return(list_tail_p_pp(sc, car(args), cadr(args)));
}


/* -------------------------------- cons -------------------------------- */
static s7_pointer g_cons(s7_scheme *sc, s7_pointer args)
{
  #define H_cons "(cons a b) returns a pair containing a and b"
  #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T)

  s7_pointer p;
  new_cell(sc, p, T_PAIR | T_Safe_Procedure);
  set_car(p, car(args));
  set_cdr(p, cadr(args));
  return(p);
}

static s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
{
  s7_pointer p;
  new_cell(sc, p, T_PAIR | T_Safe_Procedure);
  set_car(p, p1);
  set_cdr(p, p2);
  return(p);
}

/* PERHAPS: g_cons_checked and cons_p_pp_checked -- if "cons" seen as let var name, global_slot_value(g_cons) = g_cons_checked etc --
 *   would this handle the method cons without slowing down the normal cons?  What about g_vector, g_list?
 */


/* -------- car -------- */

static s7_pointer g_car(s7_scheme *sc, s7_pointer args)
{
  #define H_car "(car pair) returns the first element of the pair"
  #define Q_car sc->pl_p

  const s7_pointer lst = car(args);
  if (is_pair(lst))
    return(car(lst));
  return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, args, sc->type_names[T_PAIR]));
}

static s7_pointer car_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (is_pair(lst))
    return(car(lst));
  return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}

static s7_pointer g_list_ref_at_0(s7_scheme *sc, s7_pointer args)
{
  if (is_pair(car(args))) return(caar(args));
  return(method_or_bust(sc, car(args), sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); /* 1=arg num if error */
}

static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args)
{
  #define H_set_car "(set-car! pair val) sets the pair's first element to val"
  #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)

  const s7_pointer lst = car(args), val = cadr(args);
  if (!is_mutable_pair(lst))
    return(mutable_method_or_bust(sc, lst, sc->set_car_symbol, args, sc->type_names[T_PAIR], 1));
  set_car(lst, val);
  return(val);
}

static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value)
{
  if (!is_mutable_pair(lst))
    return(mutable_method_or_bust(sc, lst, sc->set_car_symbol, set_plist_2(sc, lst, value), sc->type_names[T_PAIR], 1));
  set_car(lst, value);
  return(value);
}

static s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_car(sc, lst, value));}


/* -------- cdr -------- */
static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdr "(cdr pair) returns the second element of the pair"
  #define Q_cdr sc->pl_p

  const s7_pointer lst = car(args);
  if (is_pair(lst))
    return(cdr(lst));
  return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, args, sc->type_names[T_PAIR]));
}

static s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (is_pair(lst))
    return(cdr(lst));
  return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}

static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args)
{
  #define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val"
  #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)

  const s7_pointer lst = car(args);
  if (!is_pair(lst))
    return(method_or_bust_pp(sc, lst, sc->set_cdr_symbol, lst, cadr(args), sc->type_names[T_PAIR], 1));
  if ((is_immutable_pair(lst)) && (cdr(lst) != sc->nil))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set-cdr! '~S (it is immutable)", 36), lst));
  set_cdr(lst, cadr(args));
  /* (define (func) (set-cdr! ((lambda (x) (values x x)) (list-values 1)))) (func) (func) ; hung in fx_c_nc, need both func calls and list-value */
  return(cadr(args));
}

static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value)
{
  if (!is_pair(lst))
    return(method_or_bust_pp(sc, lst, sc->set_cdr_symbol, lst, value, sc->type_names[T_PAIR], 1));
  if ((is_immutable_pair(lst)) && (cdr(lst) != sc->nil))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set-cdr! '~S (it is immutable)", 36), lst));
  set_cdr(lst, value);
  return(value);
}

static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_cdr(sc, lst, value));}


/* -------- caar --------*/
static s7_pointer g_caar(s7_scheme *sc, s7_pointer args)
{
  #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1"
  #define Q_caar sc->pl_p

  const s7_pointer lst = car(args);
  /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, Car_A_List_String);
  return(caar(lst));
}

static s7_pointer caar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(car(lst)))) return(caar(lst));
  if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, Car_A_List_String);
  return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}


/* -------- cadr --------*/
static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2"
  #define Q_cadr sc->pl_p

  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, Cdr_A_List_String);
  return(cadr(lst));
}

static s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(cdr(lst)))) return(cadr(lst));
  if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, Cdr_A_List_String);
  return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}

static s7_pointer g_list_ref_at_1(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
  if (!is_pair(cdr(lst))) out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, cadr(args), It_Is_Too_Large_String);
  return(cadr(lst));
}


/* -------- cdar -------- */
static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)"
  #define Q_cdar sc->pl_p

  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, Car_A_List_String);
  return(cdar(lst));
}

static s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(car(lst)))) return(cdar(lst));
  if (!is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, Car_A_List_String);
  return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}


/* -------- cddr -------- */
static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)"
  #define Q_cddr sc->pl_p

  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, Cdr_A_List_String);
  return(cddr(lst));
}

static s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(cdr(lst)))) return(cddr(lst));
  if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, Cdr_A_List_String);
  return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
}

/* -------- caaar -------- */
static s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, Caar_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, Caar_A_List_String);
  return(caaar(lst));
}

static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args)
{
  #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1"
  #define Q_caaar sc->pl_p
  return(caaar_p_p(sc, car(args)));
}

/* -------- caadr -------- */
static s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(cdr(lst))) && (is_pair(cadr(lst)))) return(caadr(lst));
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, Cdr_A_List_String);
  sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, Cadr_A_List_String);
  return(NULL);
}

static s7_pointer g_caadr(s7_scheme *sc, s7_pointer args)
{
  #define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2"
  #define Q_caadr sc->pl_p
  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, Cadr_A_List_String);
  return(caadr(lst));
}

/* -------- cadar -------- */
static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args)
{
  #define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2"
  #define Q_cadar sc->pl_p

  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, Cdar_A_List_String);
  return(cadar(lst));
}

static s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(car(lst))) && (is_pair(cdar(lst)))) return(cadar(lst));
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, Car_A_List_String);
  sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, Cdar_A_List_String);
  return(NULL);
}

/* -------- cdaar -------- */
static s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, Caar_A_List_String);
  return(cdaar(lst));
}

static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)"
  #define Q_cdaar sc->pl_p
  return(cdaar_p_p(sc, car(args)));
}

/* -------- caddr -------- */
static s7_pointer g_caddr(s7_scheme *sc, s7_pointer args)
{
  #define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3"
  #define Q_caddr sc->pl_p

  const s7_pointer lst = car(args);
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, args, sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, Cddr_A_List_String);
  return(caddr(lst));
}

static s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if ((is_pair(lst)) && (is_pair(cdr(lst))) && (is_pair(cddr(lst)))) return(caddr(lst));
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, Cdr_A_List_String);
  sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, Cddr_A_List_String);
  return(NULL);
}

static s7_pointer g_list_ref_at_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer lst = car(args);
  if (!is_pair(lst))
    return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
  if ((!is_pair(cdr(lst))) || (!is_pair(cddr(lst))))
    out_of_range_error_nr(sc, sc->list_ref_symbol, Int_Two, cadr(args), It_Is_Too_Large_String);
  return(caddr(lst));
}

/* -------- cdddr -------- */
static s7_pointer cdddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, Cddr_A_List_String);
  return(cdddr(lst));
}

static s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)"
  #define Q_cdddr sc->pl_p
  return(cdddr_p_p(sc, car(args)));
}

/* -------- cdadr -------- */
static s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, Cadr_A_List_String);
  return(cdadr(lst));
}

static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)"
  #define Q_cdadr sc->pl_p
  return(cdadr_p_p(sc, car(args)));
}

/* -------- cddar -------- */
static s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, Cdar_A_List_String);
  return(cddar(lst));
}

static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args)
{
  #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)"
  #define Q_cddar sc->pl_p
  return(cddar_p_p(sc, car(args)));
}

/* -------- caaaar -------- */
static s7_pointer caaaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, Caar_A_List_String);
  if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, Caaar_A_List_String);
  return(caaaar(lst));
}

static s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args)
{
  #define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1"
  #define Q_caaaar sc->pl_p
  return(caaaar_p_p(sc, car(args)));
}

/* -------- caaadr -------- */
static s7_pointer caaadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, Cadr_A_List_String);
  if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, Caadr_A_List_String);
  return(caaadr(lst));
}

static s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args)
{
  #define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2"
  #define Q_caaadr sc->pl_p
  return(caaadr_p_p(sc, car(args)));
}

/* -------- caadar -------- */
static s7_pointer caadar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, Cdar_A_List_String);
  if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, Cadar_A_List_String);
  return(caadar(lst));
}

static s7_pointer g_caadar(s7_scheme *sc, s7_pointer args)
{
  #define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
  #define Q_caadar sc->pl_p
  return(caadar_p_p(sc, car(args)));
}

/* -------- cadaar -------- */
static s7_pointer cadaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, Caar_A_List_String);
  if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, Cdaar_A_List_String);
  return(cadaar(lst));
}

static s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2"
  #define Q_cadaar sc->pl_p
  return(cadaar_p_p(sc, car(args)));
}

/* -------- caaddr -------- */

static s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, Cddr_A_List_String);
  if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, Caddr_A_List_String);
  return(caaddr(lst));
}

static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args)
{
  #define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3"
  #define Q_caaddr sc->pl_p
  return(caaddr_p_p(sc, car(args)));
}

/* -------- cadddr -------- */
static s7_pointer cadddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, Cddr_A_List_String);
  if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, Cdddr_A_List_String);
  return(cadddr(lst));
}

static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4"
  #define Q_cadddr sc->pl_p
  return(cadddr_p_p(sc, car(args)));
}

/* -------- cadadr -------- */
static s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, Cadr_A_List_String);
  if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, Cdadr_A_List_String);
  return(cadadr(lst));
}

static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3"
  #define Q_cadadr sc->pl_p
  return(cadadr_p_p(sc, car(args)));
}

/* -------- caddar -------- */
static s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, Cdar_A_List_String);
  if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, Cddar_A_List_String);
  return(caddar(lst));
}

static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args)
{
  #define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3"
  #define Q_caddar sc->pl_p
  return(caddar_p_p(sc, car(args)));
}

/* -------- cdaaar -------- */
static s7_pointer cdaaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, Caar_A_List_String);
  if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, Caaar_A_List_String);
  return(cdaaar(lst));
}

static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)"
  #define Q_cdaaar sc->pl_p
  return(cdaaar_p_p(sc, car(args)));
}

/* -------- cdaadr -------- */
static s7_pointer cdaadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, Cadr_A_List_String);
  if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, Caadr_A_List_String);
  return(cdaadr(lst));
}

static s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)"
  #define Q_cdaadr sc->pl_p
  return(cdaadr_p_p(sc, car(args)));
}

/* -------- cdadar -------- */
static s7_pointer cdadar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, Cdar_A_List_String);
  if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, Cadar_A_List_String);
  return(cdadar(lst));
}

static s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)"
  #define Q_cdadar sc->pl_p
  return(cdadar_p_p(sc, car(args)));
}

/* -------- cddaar -------- */
static s7_pointer cddaar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, Car_A_List_String);
  if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, Caar_A_List_String);
  if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, Cdaar_A_List_String);
  return(cddaar(lst));
}

static s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)"
  #define Q_cddaar sc->pl_p
  return(cddaar_p_p(sc, car(args)));
}

/* -------- cdaddr -------- */
static s7_pointer cdaddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, Cddr_A_List_String);
  if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, Caddr_A_List_String);
  return(cdaddr(lst));
}

static s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)"
  #define Q_cdaddr sc->pl_p
  return(cdaddr_p_p(sc, car(args)));
}

/* -------- cddddr -------- */

static s7_pointer cddddr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, Cddr_A_List_String);
  if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, Cdddr_A_List_String);
  return(cddddr(lst));
}

static s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)"
  #define Q_cddddr sc->pl_p
  return(cddddr_p_p(sc, car(args)));
}

/* -------- cddadr -------- */
static s7_pointer cddadr_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, Cdr_A_List_String);
  if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, Cadr_A_List_String);
  if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, Cdadr_A_List_String);
  return(cddadr(lst));
}

static s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)"
  #define Q_cddadr sc->pl_p
  return(cddadr_p_p(sc, car(args)));
}

/* -------- cdddar -------- */

static s7_pointer cdddar_p_p(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
  if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, Car_A_List_String);
  if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, Cdar_A_List_String);
  if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, Cddar_A_List_String);
  return(cdddar(lst));
}

static s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)"
  #define Q_cdddar sc->pl_p
  return(cdddar_p_p(sc, car(args)));
}


/* -------------------------------- assoc assv assq -------------------------------- */
s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow = lst;
  while (true)
    {
      /* we can blithely take the car of anything, since we're not treating it as an object,
       *   then if we get a bogus match, the following check that caar made sense ought to catch it.
       * if car(#<unspecified>) = #<unspecified> (initialization time), then cdr(nil)->unspec
       *   and subsequent caar(unspec)->unspec so we could forgo half the is_pair checks below.
       *   This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose.
       */
      Loop_8(if ((obj == 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 assq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  return((is_pair(lst)) ? s7_assq(sc, obj, lst) :
	 ((is_null(lst)) ? sc->F :
	  method_or_bust_pp(sc, lst, sc->assq_symbol, obj, lst, An_Association_List_String, 2)));
}

static s7_pointer g_assq(s7_scheme *sc, s7_pointer args)
{
  #define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist"
  #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol)
  return(assq_p_pp(sc, car(args), cadr(args)));
  /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc:
   *  (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error
   */
}

static s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow;
  if (!is_pair(lst))
    {
      if (is_null(lst)) return(sc->F);
      if (sc->scheme_version == sc->s7_symbol)
	return(method_or_bust_pp(sc, lst, sc->assv_symbol, obj, lst, An_Association_List_String, 2));
      return(methods_or_bust_pp(sc, lst, sc->assv_symbol, sc->assq_symbol, obj, lst, An_Association_List_String, 2));
    }
  if (is_simple(obj))
    return(s7_assq(sc, obj, lst));

  slow = lst;
  while (true)
    {
      /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */
      if ((is_pair(car(lst))) && (s7_is_eqv(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      if ((is_pair(car(lst))) && (s7_is_eqv(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      slow = cdr(slow);
      if (slow == lst) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static s7_pointer g_assv(s7_scheme *sc, s7_pointer args)        /* g_assv is called by g_assoc below */
{
  #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist"
  #define Q_assv Q_assq
  return(assv_p_pp(sc, car(args), cadr(args)));
}

s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow;
  if (!is_pair(lst))
    return(sc->F);
  slow = lst;
  while (true)
    {
      if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      slow = cdr(slow);
      if (lst == slow) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow = lst;
  if (is_string(obj))
    {
      while (true)
	{
	  if (is_pair(car(lst)))
	    {
	      const 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)))
	    {
	      const s7_pointer val = caar(lst);
	      if ((val == obj) ||
		  ((is_string(val)) &&
		   (scheme_strings_are_equal(obj, val))))
		return(car(lst));
	    }
	  lst = cdr(lst);
	  if (!is_pair(lst)) return(sc->F);
	  slow = cdr(slow);
	  if (lst == slow) return(sc->F);
	}
      return(sc->F);
    }
  while (true)
    {
      if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst));
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);
      slow = cdr(slow);
      if (lst == slow) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static bool closure_has_two_normal_args(s7_scheme *sc, s7_pointer eq_func) /* sc for is_null */
{
  return((is_closure(eq_func)) &&
	 (is_pair(closure_pars(eq_func))) &&
	 (is_pair(cdr(closure_pars(eq_func)))) && /* not dotted arg list */
	 (is_null(cddr(closure_pars(eq_func)))));  /* arity == 2 */
}

static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args);
static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args);
static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr);

/* a naming experiment, "q_" to match signature "Q_" */
#define q_call(O) O->v[0]

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->not_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);
		}}}

      /* 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));
  }
}

static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer p)
{
  if (!is_pair(p))
    {
      if (is_null(p)) return(sc->F);
      return(method_or_bust(sc, p, sc->assoc_symbol, set_plist_2(sc, obj, p), An_Association_List_String, 2));
    }
  if (!is_pair(car(p))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, p, An_Association_List_String);
  if (is_simple(obj)) return(s7_assq(sc, obj, p));
  return(assoc_1(sc, obj, p));
}

static bool op_assoc_if(s7_scheme *sc)
{
  const s7_pointer orig_args = car(sc->args);
  /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison
   *   (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =)
   */
  if (sc->value != sc->F)            /* previous comparison was not #f -- return (car list) */
    {
      sc->value = car(opt1_fast(orig_args));
      return(true);
    }
  if (!is_pair(cdr(opt1_fast(orig_args))))             /* (assoc 3 '((1 . 2) . 3) =) or nil */
    {
      sc->value = sc->F;
      return(true);
    }
  set_opt1_fast(orig_args, cdr(opt1_fast(orig_args)));  /* cdr down arg list */

  if (sc->cur_op == OP_ASSOC_IF1)
    {
      /* circular list check */
      if (opt1_fast(orig_args) == opt2_slow(orig_args))
	{
	  sc->value = sc->F;
	  return(true);
	}
      set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */
      push_stack_direct(sc, OP_ASSOC_IF);
    }
  else push_stack_direct(sc, OP_ASSOC_IF1);

  if (!is_pair(car(opt1_fast(orig_args))))     /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "assoc: second argument is not an alist: ~S", 42), orig_args));
  /* not sure about this -- we could simply skip the entry both here and in g_assoc
   *   (assoc 1 '((2 . 2) 3)) -> #f
   *   (assoc 1 '((2 . 2) 3) =) -> error currently
   */
  if (needs_copied_args(sc->code))
    sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
  else sc->args = set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
  return(false);
}

static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args == 3) && (is_normal_symbol(cadddr(expr))))
    {
      if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol));
      if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->assv_symbol));
    }
  return(func);
}


/* ---------------- member, memv, memq ---------------- */
s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow = lst;
  while (true)
    {
      Loop_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));
      slow = cdr(slow);
      if (lst == slow) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  return((is_pair(lst)) ? s7_memq(sc, obj, lst) :
	 ((is_null(lst)) ? sc->F : method_or_bust_pp(sc, lst, sc->memq_symbol, obj, lst, A_List_String, 2)));
}

static s7_pointer g_memq(s7_scheme *sc, s7_pointer args)
{
  #define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?"
  #define Q_memq sc->pl_tl

  const s7_pointer obj = car(args), lst = cadr(args);
  if (is_pair(lst))
    return(s7_memq(sc, obj, lst));
  if (is_null(lst))
    return(sc->F);
  return(method_or_bust_pp(sc, lst, sc->memq_symbol, obj, lst, A_List_String, 2));
}

/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end */
/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is */

static s7_pointer g_memq_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer obj = car(args), lst = cadr(args);
  if (obj == car(lst)) return(lst);
  return((obj == cadr(lst)) ? cdr(lst) : sc->F);
}

static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  if (obj == car(lst)) return(lst);
  return((obj == cadr(lst)) ? cdr(lst) : sc->F);
}

static s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  if (obj == car(lst)) return(lst);
  if (obj == cadr(lst)) return(cdr(lst));
  return((obj == caddr(lst)) ? cddr(lst) : sc->F);
}

static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args)
{
  s7_pointer lst = cadr(args);
  const s7_pointer obj = car(args);
  while (true)
    {
      if (obj == car(lst)) return(lst); /* grandma gcc doesn't want me to include the next line here. */
      lst = cdr(lst);
      if (obj == car(lst)) return(lst);
      lst = cdr(lst);
      if (obj == car(lst)) return(lst);
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  while (true)
    {
      Loop_4(if (obj == car(lst)) return(lst); lst = cdr(lst));
      if (!is_pair(lst)) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) {return(memq_4_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args)
{
  /* no circular list check needed in this case */
  const s7_pointer obj = car(args);
  s7_pointer lst = cadr(args);
  while (true) {Loop_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));}
  return(sc->F);
}

static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr)
{
  const s7_pointer lst = caddr(expr);
  if ((is_proper_quote(sc, lst)) &&
      (is_pair(cadr(lst))))
    {
      s7_int len = s7_list_length(sc, cadr(lst));
      if (len > 0)
	{
	  if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */
	    return(sc->memq_2);
	  if ((len % 4) == 0)
	    return(sc->memq_4);
	  return(((len % 3) == 0) ? sc->memq_3 : sc->memq_any);
	}}
  return(func);
}

static bool numbers_are_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  if ((is_big_number(x)) || (is_big_number(y)))
    return(big_numbers_are_eqv(sc, x, y));
  if (type(x) != type(y)) return(false);
#endif
  /* if (type(x) != type(y)) return(false); */   /* (eqv? 1 1.0) -> #f! but assume that we've checked types already */
  /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */
  if (is_t_integer(x)) return(integer(x) == integer(y));
  if (is_t_real(x)) return(real(x) == real(y));  /* NaNs are not equal to anything including themselves */
  if (is_t_ratio(x)) return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y)));
  if (!is_t_complex(x)) return(false);
  return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y)));
}

static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow = lst;
#if !With_Gmp
  uint8_t obj_type = type(obj);
#endif
  while (true)
    {
#if With_Gmp
      Loop_4(if ((is_number(car(lst))) && (numbers_are_eqv(sc, obj, car(lst)))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));
#else
      Loop_4(if ((type(car(lst)) == obj_type) && (numbers_are_eqv(sc, obj, car(lst)))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));
#endif
      slow = cdr(slow);
      if (lst == slow) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer p;
  if (!is_pair(lst))
    {
      if (is_null(lst)) return(sc->F);
      if (sc->scheme_version == sc->s7_symbol)
	return(method_or_bust_pp(sc, lst, sc->memv_symbol, obj, lst, A_List_String, 2));
      return(methods_or_bust_pp(sc, lst, sc->memv_symbol, sc->memq_symbol, obj, lst, A_List_String, 2));
    }
  if (is_simple(obj)) return(s7_memq(sc, obj, lst));
  if (is_number(obj)) return(memv_number(sc, obj, lst));

  p = lst;
  while (true)
    {
      if (s7_is_eqv(sc, obj, car(lst))) return(lst);
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      if (s7_is_eqv(sc, obj, car(lst))) return(lst);
      lst = cdr(lst);
      if (!is_pair(lst)) return(sc->F);

      p = cdr(p);
      if (p == lst) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static s7_pointer g_memv(s7_scheme *sc, s7_pointer args)
{
  #define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?"
  #define Q_memv sc->pl_tl
  return(memv_p_pp(sc, car(args), cadr(args)));
}


s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  for (s7_pointer p = lst; is_pair(p); p = cdr(p))
    if (s7_is_equal(sc, obj, car(p)))
      return(p);
  return(sc->F);
}

static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  s7_pointer slow = lst;
  if (is_string(obj))
    while (true)
      {
	if ((obj == car(lst)) ||
	    ((is_string(car(lst))) &&
	     (scheme_strings_are_equal(obj, car(lst)))))
	  return(lst);
	lst = cdr(lst);
	if (!is_pair(lst)) return(sc->F);

	if ((obj == car(lst)) ||
	    ((is_string(car(lst))) &&
	     (scheme_strings_are_equal(obj, car(lst)))))
	  return(lst);
	lst = cdr(lst);
	if (!is_pair(lst)) return(sc->F);
	slow = cdr(slow);
	if (lst == slow) return(sc->F);
      }
  else
    while (true)
      {
	Loop_4(if (s7_is_equal(sc, obj, car(lst))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F));
	slow = cdr(slow);
	if (lst == slow) return(sc->F);
      }
  return(sc->F);
}

static bool p_to_b(opt_info *p);

static s7_pointer g_member(s7_scheme *sc, s7_pointer args)
{
  #define H_member "(member obj list func) looks for obj in list and returns the list from that point if it is found, otherwise #f. \
member uses equal?  If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
  #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)

  /* this could be extended to accept sequences:
   *    (member #\a "123123abnfc" char=?) -> "abnfc"
   *    (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication
   *    (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table?
   * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t)
   * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil
   *
   * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so.
   */
  s7_pointer lst = cadr(args);
  if ((!is_pair(lst)) && (!is_null(lst)))
    return(method_or_bust(sc, lst, sc->member_symbol, args, A_List_String, 2));

  if (is_pair(cddr(args)))
    {
      const s7_pointer eq_func = caddr(args);
      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];
		  const 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));
      {
	const s7_pointer 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);
  {
    const s7_pointer obj = car(args);
    if (is_simple(obj))
      return(s7_memq(sc, obj, lst));
    /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */
    if (is_number(obj))
      return(memv_number(sc, obj, lst));
    return(member(sc, obj, lst));
  }
}

static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst)
{
  if (is_null(lst)) return(sc->F);
  if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->member_symbol, set_plist_2(sc, obj, lst), A_List_String, 2));
  if (is_simple(obj)) return(s7_memq(sc, obj, lst));
  if (is_number(obj)) return(memv_number(sc, obj, lst));
  return(member(sc, obj, lst));
}

static s7_pointer member_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args == 3) && (is_normal_symbol(cadddr(expr))))
    {
      if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr));
      if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol));
    }
  return(func);
}

static bool op_member_if(s7_scheme *sc)
{
  const s7_pointer orig_args = car(sc->args);
  /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list),
   *   the extra indirection (list (list...)) is needed because call/cc copies arg lists
   * value = result of comparison
   */
  if (sc->value != sc->F)                      /* previous comparison was not #f -- return list */
    {
      sc->value = opt1_fast(orig_args);
      return(true);
    }
  if (!is_pair(cdr(opt1_fast(orig_args))))      /* no more args -- return #f */
    {
      sc->value = sc->F;
      return(true);
    }
  set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */

  if (sc->cur_op == OP_MEMBER_IF1)
    {
      /* circular list check */
      if (opt1_fast(orig_args) == opt2_slow(orig_args))
	{
	  sc->value = sc->F;
	  return(true);
	}
      set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */
      push_stack_direct(sc, OP_MEMBER_IF);
    }
  else push_stack_direct(sc, OP_MEMBER_IF1);

  if (needs_copied_args(sc->code))
    sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
  else sc->args = set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
  return(false);
}


/* -------------------------------- list -------------------------------- */
static s7_pointer g_list(s7_scheme *sc, s7_pointer args)
{
  #define H_list "(list ...) returns its arguments in a list"
  #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T)
  return(copy_proper_list(sc, args));
}

static s7_pointer g_list_0(s7_scheme *sc, s7_pointer unused_args) {return(sc->nil);}
static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args) {return(list_1(sc, car(args)));}
static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args) {return(list_2(sc, car(args), cadr(args)));}
static s7_pointer g_list_3(s7_scheme *sc, s7_pointer args) {return(list_3(sc, car(args), cadr(args), caddr(args)));}
static s7_pointer g_list_4(s7_scheme *sc, s7_pointer args) {s7_pointer p = cddr(args); return(list_4(sc, car(args), cadr(args), car(p), cadr(p)));}

static s7_pointer list_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 0) return(sc->list_0);
  if (args == 1) return(sc->list_1);
  if (args == 2) return(sc->list_2);
  if (args == 3) return(sc->list_3);
  return((args == 4) ? sc->list_4 : func);
}

static s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, sc->value = p1));}
static s7_pointer list_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(list_2(sc, p1, p2));}
static s7_pointer list_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(list_3(sc, p1, p2, p3));}
/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */

static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst)
{
  s7_pointer p = lst;
  for (int32_t i = 1; is_pair(p); p = cdr(p), i++)
    if (!s7_is_valid(sc, car(p)))
      {
	if (i < 11)
	  s7_warn(sc, s7_Warn_Bufsize, "the %s argument to %s: %p, is not an s7 object\n", ordinal[i], caller, car(p));
	else s7_warn(sc, s7_Warn_Bufsize, "%s: argument number %d is not an s7 object: %p\n", caller, i, car(p));
      }
}

s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...)
{
  va_list ap;
  s7_pointer p;
  if (num_values == 0) return(sc->nil);
  begin_temp(sc->v, p = make_list(sc, num_values, sc->unused));
  va_start(ap, num_values);
  for (s7_int i = 0; i < num_values; i++, p = cdr(p))
    set_car(p, va_arg(ap, s7_pointer));
  va_end(ap);
  if (sc->safety > No_Safety)
    check_list_validity(sc, __func__, sc->v);
  return_with_end_temp(sc->v);
}

s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should be NULL terminated */
{
  s7_int i = 0;
  va_list ap;
  s7_pointer p;

  if (num_values == 0) return(sc->nil);
  begin_temp(sc->v, make_list(sc, num_values, sc->unused));
  va_start(ap, num_values);
  for (s7_pointer q = sc->v; i < num_values; i++, q = cdr(q))
    {
      p = va_arg(ap, s7_pointer);
      if (!p)
	{
	  va_end(ap);
	  wrong_number_of_arguments_error_nr(sc, "not enough arguments for s7_list_nl: ~S", 39, sc->v); /* ideally we'd sublist this and append extra below */
	}
      set_car(q, p);
    }
  p = va_arg(ap, s7_pointer);
  va_end(ap);
  if (p) wrong_number_of_arguments_error_nr(sc, "too many arguments for s7_list_nl: ~S", 37, sc->v);

  if (sc->safety > No_Safety)
    check_list_validity(sc, __func__, sc->v);
  return_with_end_temp(sc->v);
}

static s7_pointer safe_list_1(s7_scheme *sc)
{
  if (!safe_list_is_in_use(sc->safe_lists[1]))
    {
      sc->current_safe_list = 1;
      set_safe_list_in_use(sc, sc->safe_lists[1]);
#if s7_Debugging
      sc->safe_list_uses[1]++;
#endif
      return(sc->safe_lists[1]);
    }
  return(cons(sc, sc->unused, sc->nil));
}

static s7_pointer safe_list_2(s7_scheme *sc)
{
  if (!safe_list_is_in_use(sc->safe_lists[2]))
    {
      sc->current_safe_list = 2;
      set_safe_list_in_use(sc, sc->safe_lists[2]);
#if s7_Debugging
      sc->safe_list_uses[2]++;
#endif
      return(sc->safe_lists[2]);
    }
  return(cons_unchecked(sc, sc->unused, list_1(sc, sc->nil)));
}

static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args)
{
  if (num_args < Num_Safe_Lists)
    {
      if (!is_pair(sc->safe_lists[num_args]))
	{
	  sc->safe_lists[num_args] = semipermanent_list(sc, num_args);
#if s7_Debugging
	  set_alloc_info(sc->safe_lists[num_args], __func__, __LINE__);
#endif
	}
      if (!safe_list_is_in_use(sc->safe_lists[num_args]))
	{
	  sc->current_safe_list = num_args;
	  set_safe_list_in_use(sc, sc->safe_lists[num_args]);
#if s7_Debugging
	  sc->safe_list_uses[num_args]++;
#endif
	  return(sc->safe_lists[num_args]);
	}}
  return(make_big_list(sc, num_args, sc->unused));
}

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])) /* this is nearly always successful (i.e. not in use) */
	return(make_list(sc, num_args, sc->unused));
      sc->current_safe_list = num_args;
      set_safe_list_in_use(sc, sc->safe_lists[num_args]);
#if s7_Debugging
      sc->safe_list_uses[num_args]++;
#endif
      return(sc->safe_lists[num_args]);
    }
  return(make_safe_list(sc, num_args));
}

static s7_pointer list_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer tp = sc->nil, np = NULL, pp;
  /* should append retain immutable settings on pairs when copied? */
  /* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */
  gc_protect_via_stack(sc, args);
  for (s7_pointer arglist = args; is_pair(arglist); arglist = cdr(arglist)) /* not dotted */
    {
      const s7_pointer p = car(arglist);
      s7_pointer func;
      if ((has_active_methods(sc, p)) &&
	  ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined))
	{
	  unstack_gc_protect(sc);
	  return(s7_apply_function(sc, func, (is_null(tp)) ? arglist : set_ulist_1(sc, tp, arglist)));
	}
      if (is_null(cdr(arglist)))
	{
	  if (is_null(tp))
	    {
	      /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that */
	      unstack_gc_protect(sc);
	      return(p);
	    }
	  if (is_list(p))
	    set_cdr(np, p);
	  else
	    {
	      s7_int len = sequence_length(sc, p);
	      if (len > 0)
		set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))));
	      else
		if (len < 0)
		  set_cdr(np, p);
	    }
	  sc->temp8 = sc->unused;
	  unstack_gc_protect(sc);
	  return(tp);
	}
      if (!is_sequence(p))
	{
	  unstack_gc_protect(sc);
	  wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, A_Sequence_String);
	}
      if (!sequence_is_empty(sc, p))
	{
	  if (is_pair(p))
	    {
	      if (!s7_is_proper_list(sc, p))
		{
		  sc->temp8 = sc->unused;
		  unstack_gc_protect(sc);
		  wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, A_Proper_List_String);
		}
	      if (is_null(tp))
		{
		  tp = list_1(sc, car(p));
		  np = tp;
		  sc->temp8 = tp; /* GC protect? */
		  pp = cdr(p);
		}
	      else pp = p;
	      for (; is_pair(pp); pp = cdr(pp), np = cdr(np))
		set_cdr(np, list_1(sc, car(pp)));
	    }
	  else
	    {
	      const s7_int len = sequence_length(sc, p);
	      if (len > 0)
		{
		  if (is_null(tp))
		    {
		      tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)));
		      np = tp;
		      sc->temp8 = tp;
		    }
		  else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))));
		  for (; is_pair(cdr(np)); np = cdr(np));
		}
	      else
		if (len < 0)
		  {
		    unstack_gc_protect(sc);
		    wrong_type_error_nr(sc, sc->append_symbol, position_of(arglist, args), p, A_Sequence_String);
		  }}}}
  unstack_gc_protect(sc);
  return(tp);
}

static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  /* tack b onto the end of a without copying either -- 'a' is changed! */
  s7_pointer p;
  if (is_null(a)) return(b);
  p = a;
  while (is_not_null(cdr(p))) p = cdr(p);
  set_cdr(p, b);
  return(a);
}


/* -------------------------------- vectors -------------------------------- */
bool s7_is_vector(s7_pointer p)         {return(is_any_vector(p));}
bool s7_is_float_vector(s7_pointer p)   {return(is_float_vector(p));}
bool s7_is_complex_vector(s7_pointer p) {return(is_complex_vector(p));}
bool s7_is_int_vector(s7_pointer p)     {return(is_int_vector(p));}
bool s7_is_byte_vector(s7_pointer p)    {return(is_byte_vector(p));}

static bool is_byte_vector_b_p(s7_pointer b) {return(is_byte_vector(b));}

s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));}

static s7_pointer t_vector_setter(s7_scheme *unused_sc, s7_pointer vec, s7_int loc, s7_pointer val)
{
  vector_element(vec, loc) = val;
  return(val);
}

static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer vec)
{
  s7_pointer typer_name;
  const s7_pointer 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 const char *typed_vector_typer_name(s7_scheme *sc, s7_pointer vec)
{
  s7_pointer typer = typed_vector_typer(vec);
  return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, vec)));
}

static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port)
{
  const char *setter = make_type_name(sc, typed_vector_typer_name(sc, vect), No_Article);
  port_write_string(port)(sc, setter, safe_strlen(setter), port);
}

static no_return void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s7_pointer val)
{
  const char *descr = typed_vector_typer_name(sc, vec);
  error_nr(sc, sc->wrong_type_arg_symbol,
	   set_elist_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))));
}

static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) /* tstr faster without inline, but tbig slower */
{
  if ((sc->safety >= No_Safety) && /* only use of safety == -1 */
      (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) == sc->F))
    typed_vector_type_error_nr(sc, vec, val);
  vector_element(vec, loc) = val;
  return(val);
}

static s7_pointer t_vector_getter(s7_scheme *unused_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 *unused_sc, s7_pointer vec, s7_int loc) {return(small_int(byte_vector(vec, loc)));}

static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
{
  if (s7_is_integer(val))
    int_vector(vec, loc) = s7_integer_clamped_if_gmp(sc, val);
  else wrong_type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]);
  return(val);
}

static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
{
  float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!");
  return(val);
}

static s7_pointer complex_vector_setter(s7_scheme *unused_sc, s7_pointer vec, s7_int loc, s7_pointer val)
{
  complex_vector(vec, loc) = s7_to_c_complex(val);
  return(val);
}

static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
{
  s7_int byte;
  if (!s7_is_integer(val))
    wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]);
  byte = s7_integer_clamped_if_gmp(sc, val);
  if ((byte < 0) || (byte >= 256))
    wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, wrap_string(sc, "a byte", 6));
  byte_vector(vec, loc) = (uint8_t)byte;
  return(val);
}

static block_t *mallocate_empty_block(s7_scheme *sc)
{
  block_t *b = mallocate_block(sc);
#if s7_Debugging
  sc->blocks_mallocated[Block_List]++;
#endif
  block_data(b) = NULL;
  block_info(b) = NULL;
  return(b);
}

#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc)

static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
{
  s7_pointer vect;
  block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer));
  new_cell(sc, vect, T_VECTOR | T_Safe_Procedure);
  vector_length(vect) = len;
  vector_block(vect) = b;
  vector_elements(vect) = (s7_pointer *)block_data(b);
  vector_set_dimension_info(vect, NULL);
  vector_getter(vect) = t_vector_getter;
  vector_setter(vect) = t_vector_setter;
  add_vector(sc, vect);
  return(vect);
}

static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
{
  s7_pointer vect;
  block_t *b = mallocate_vector(sc, len * sizeof(s7_double));
  new_cell(sc, vect, T_FLOAT_VECTOR | T_Safe_Procedure);
  vector_length(vect) = len;
  vector_block(vect) = b;
  float_vector_floats(vect) = (s7_double *)block_data(b);
  vector_set_dimension_info(vect, NULL);
  vector_getter(vect) = float_vector_getter;
  vector_setter(vect) = float_vector_setter;
  add_vector(sc, vect);
  return(vect);
}

static inline s7_pointer make_simple_complex_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
{
  s7_pointer vect;
  block_t *b = mallocate_vector(sc, len * sizeof(s7_complex));
  new_cell(sc, vect, T_COMPLEX_VECTOR | T_Safe_Procedure);
  vector_length(vect) = len;
  vector_block(vect) = b;
  complex_vector_complexes(vect) = (s7_complex *)block_data(b);
  vector_set_dimension_info(vect, NULL);
  vector_getter(vect) = complex_vector_getter;
  vector_setter(vect) = complex_vector_setter;
  add_vector(sc, vect);
  return(vect);
}

static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
{
  s7_pointer vect;
  block_t *b = mallocate_vector(sc, len * sizeof(s7_int));
  new_cell(sc, vect, T_INT_VECTOR | T_Safe_Procedure);
  vector_length(vect) = len;
  vector_block(vect) = b;
  int_vector_ints(vect) = (s7_int *)block_data(b);
  vector_set_dimension_info(vect, NULL);
  vector_getter(vect) = int_vector_getter;
  vector_setter(vect) = int_vector_setter;
  add_vector(sc, vect);
  return(vect);
}

static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len)
{
  s7_pointer vect;
  block_t *b = mallocate_vector(sc, len); /* not inline_mallocate because we need to set block_data to NULL if len==0 */
  new_cell(sc, vect, T_BYTE_VECTOR | T_Safe_Procedure);
  vector_block(vect) = b;
  byte_vector_bytes(vect) = (uint8_t *)block_data(b);
  vector_length(vect) = len;
  vector_set_dimension_info(vect, NULL);
  vector_getter(vect) = byte_vector_getter;
  vector_setter(vect) = byte_vector_setter;
  add_vector(sc, vect);
  return(vect);
}

static Vectorized void t_vector_fill(s7_pointer vec, s7_pointer obj)
{
  s7_pointer *orig = vector_elements(vec);
  const s7_int len = vector_length(vec);
  s7_int i, left;
  if (len == 0) return;
  /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */
  left = len - 8;
  i = 0;
  while (i <= left)
    Loop_8(orig[i++] = obj);
  for (; i < len; i++)
    orig[i] = obj;
}

static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t typ)
{
  s7_pointer vect;

  if (len < 0)
    out_of_range_error_nr(sc, sc->make_vector_symbol, Int_One, wrap_integer(sc, len), It_Is_Negative_String);
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-vector length argument ~D is greater than (*s7* 'max-vector-length), ~D", 76),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));

  /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */
  new_cell(sc, vect, typ | T_Safe_Procedure);
  vector_length(vect) = len;
  if (len == 0)
    {
      vector_block(vect) = mallocate_empty_block(sc);
      any_vector_elements(vect) = NULL;
      if (typ == T_VECTOR) set_has_simple_elements(vect);
    }
  else
    if (typ == T_VECTOR)
      {
	block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer));
	vector_block(vect) = b;
	vector_elements(vect) = (s7_pointer *)block_data(b);
	vector_getter(vect) = t_vector_getter;
	vector_setter(vect) = t_vector_setter;
	if (filled) t_vector_fill(vect, sc->unused);
      }
    else
      if (typ == T_FLOAT_VECTOR)
	{
	  block_t *b = inline_mallocate(sc, len * sizeof(s7_double));
	  vector_block(vect) = b;
	  float_vector_floats(vect) = (s7_double *)block_data(b);
	  if (filled)
	    {
	      if (Step_8(len))
		memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double));
	      else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double));
	    }
	  vector_getter(vect) = float_vector_getter;
	  vector_setter(vect) = float_vector_setter;
	}
      else
	if (typ == T_INT_VECTOR)
	  {
	    block_t *b = inline_mallocate(sc, len * sizeof(s7_int));
	    vector_block(vect) = b;
	    int_vector_ints(vect) = (s7_int *)block_data(b);
	    if (filled)
	      {
		if (Step_8(len))
		  memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int));
		else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int));
	      }
	    vector_getter(vect) = int_vector_getter;
	    vector_setter(vect) = int_vector_setter;
	  }
	else
	  if (typ == T_COMPLEX_VECTOR)
	    {
	      block_t *b = inline_mallocate(sc, len * sizeof(s7_complex));
	      vector_block(vect) = b;
	      complex_vector_complexes(vect) = (s7_complex *)block_data(b);
	      if (filled)
		{
		  if (Step_8(len))
		    memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex));
		  else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex));
		}
	      vector_getter(vect) = complex_vector_getter;
	      vector_setter(vect) = complex_vector_setter;
	    }
	  else /* byte-vector */
	    {
	      block_t *b = mallocate(sc, len);
	      vector_block(vect) = b;
	      byte_vector_bytes(vect) = (uint8_t *)block_data(b);
	      vector_getter(vect) = byte_vector_getter;
	      vector_setter(vect) = byte_vector_setter;
	      if (filled)
		{
		  if (Step_64(len))
		    memclr64((void *)(byte_vector_bytes(vect)), len);
		  else memclr((void *)(byte_vector_bytes(vect)), len);
		}}
  vector_set_dimension_info(vect, NULL);
  return(vect);
}

#define Vector_Filled true
#define Vector_Not_Filled false

s7_pointer s7_make_vector(s7_scheme *sc, s7_int len)
{
  s7_pointer vec = make_vector_1(sc, len, Vector_Filled, T_VECTOR);
  add_vector(sc, vec);
  return(vec);
}

s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill)
{
  s7_pointer vect = make_simple_vector(sc, len);
  t_vector_fill(vect, fill);
  return(vect);
}

static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */
{
  vdims_t *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, Vector_Filled, type);
  if (dim_info)
    {
      vector_set_dimension_info(vect, make_vdims(sc, false, dims, dim_info)); /* false = don't free elements */
      add_multivector(sc, vect);
    }
  else add_vector(sc, vect);
  return(vect);
}

s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info)     {return(make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info));}
s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info)    {return(make_any_vector(sc, T_BYTE_VECTOR, len, dims, dim_info));}
s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info)   {return(make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info));}
s7_pointer s7_make_complex_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_COMPLEX_VECTOR, len, dims, dim_info));}
s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info)  {return(make_any_vector(sc, T_VECTOR, len, dims, dim_info));}

s7_pointer s7_make_int_vector_wrapper(s7_scheme *sc, s7_int len, s7_int *data, s7_int dims, s7_int *dim_info, bool free_data)
{
  /* this wraps up a C-allocated/freed int64_t array as an s7 int-vector */
  s7_pointer vect;
  block_t *b = mallocate_empty_block(sc);
  new_cell(sc, vect, T_INT_VECTOR | T_Safe_Procedure);
  vector_block(vect) = b;
  int_vector_ints(vect) = data;
  vector_getter(vect) = int_vector_getter;
  vector_setter(vect) = int_vector_setter;
  vector_length(vect) = len;
  if (!dim_info)
    {
      s7_int di[1];
      di[0] = len;
      vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di));
    }
  else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info));
  add_multivector(sc, vect);
  return(vect);
}

s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data)
{
  /* this wraps up a C-allocated/freed double array as an s7 float-vector */
  s7_pointer vect;
  block_t *b = mallocate_empty_block(sc);
  new_cell(sc, vect, T_FLOAT_VECTOR | T_Safe_Procedure);
  vector_block(vect) = b;
  float_vector_floats(vect) = data;
  vector_getter(vect) = float_vector_getter;
  vector_setter(vect) = float_vector_setter;
  vector_length(vect) = len;
  if (!dim_info)
    {
      s7_int di[1];
      di[0] = len;
      vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di));
    }
  else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info));
  add_multivector(sc, vect);
  return(vect);
}

s7_pointer s7_make_complex_vector_wrapper(s7_scheme *sc, s7_int len, s7_complex *data, s7_int dims, s7_int *dim_info, bool free_data)
{
  /* this wraps up a C-allocated/freed complex array as an s7 complex-vector */
  s7_pointer vect;
  block_t *b = mallocate_empty_block(sc);
  new_cell(sc, vect, T_COMPLEX_VECTOR | T_Safe_Procedure);
  vector_block(vect) = b;
  complex_vector_complexes(vect) = data;
  vector_getter(vect) = complex_vector_getter;
  vector_setter(vect) = complex_vector_setter;
  vector_length(vect) = len;
  if (!dim_info)
    {
      s7_int di[1];
      di[0] = len;
      vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di));
    }
  else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info));
  add_multivector(sc, vect);
  return(vect);
}


/* -------------------------------- vector-fill! -------------------------------- */
static Vectorized void float_vector_fill(s7_pointer vec, s7_double x)
{
  const s7_int len = vector_length(vec);
  if (len == 0) return;
  if (x == 0.0)
    {
      if (Step_8(len))
	memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double));
      else memclr((void *)float_vector_floats(vec), len * sizeof(s7_double));
    }
  else
    {
      s7_int i = 0;
      const s7_int 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;
      const s7_int left = len - 8;
      s7_int *orig = int_vector_ints(vec);
      while (i <= left)
	Loop_8(orig[i++] = k);
      for (; i < len; i++)
	orig[i] = k;
    }
}

static void byte_vector_fill(s7_pointer vec, uint8_t byte)
{
  const s7_int len = vector_length(vec);
  if (len == 0) return;
  if (byte > 0)
    local_memset((void *)(byte_vector_bytes(vec)), byte, len);
  else /* byte == 0 */
    if (Step_64(len))
      memclr64((void *)(byte_vector_bytes(vec)), len);
    else memclr((void *)(byte_vector_bytes(vec)), len);
}

static void complex_vector_fill(s7_pointer vec, s7_complex x)
{
  const s7_int len = vector_length(vec);
  if (len == 0) return;
  if (x == 0.0)
    {
      if (Step_8(len))
	memclr64((void *)complex_vector_complexes(vec), len * sizeof(s7_complex));
      else memclr((void *)complex_vector_complexes(vec), len * sizeof(s7_complex));
    }
  else
    {
      s7_int i = 0;
      const s7_int left = len - 8;
      s7_complex *orig = complex_vector_complexes(vec);
      while (i <= left)
	Loop_8(orig[i++] = x);
      for (; i < len; i++)
	orig[i] = x;
    }
}

void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
{
  switch (type(vec))
    {
    case T_FLOAT_VECTOR:
      if (!is_real(obj))
	wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]);
      float_vector_fill(vec, s7_real(obj));
      break;
    case T_INT_VECTOR:
      if (!s7_is_integer(obj)) /* possibly a bignum */
	wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]);
      int_vector_fill(vec, s7_integer_clamped_if_gmp(sc, obj));
      break;
    case T_BYTE_VECTOR:
      if (!is_byte(obj))
	wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6));
      byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj));
      break;
    case T_COMPLEX_VECTOR:
      if (!is_number(obj))
	wrong_type_error_nr(sc, wrap_string(sc, "complex-vector fill!", 20), 2, obj, sc->type_names[T_COMPLEX]);
      complex_vector_fill(vec, s7_to_c_complex(obj));
      break;
    case T_VECTOR:
    default:
      t_vector_fill(vec, obj);
    }
}

static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
{
  const s7_pointer vect = car(args);
  s7_pointer fill;

  if (!is_any_vector(vect))
    {
      if_method_exists_return_value(sc, vect, sc->vector_fill_symbol, args);
      /* not two_methods (and fill!) here else we get stuff like:
       *   (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa"
       */
      wrong_type_error_nr(sc, caller, 1, vect, sc->type_names[T_VECTOR]);
    }
  if (is_immutable_vector(vect))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, caller, vect));

  fill = cadr(args);
  if ((is_typed_t_vector(vect)) &&
      (typed_vector_typer_call(sc, vect, set_plist_1(sc, fill)) == sc->F))
    {
      const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, vect), Indefinite_Article);
      wrong_type_error_nr(sc, wrap_string(sc, "vector fill!", 12), 2, fill, wrap_string(sc, tstr, safe_strlen(tstr)));
    }
  if (is_float_vector(vect))
    {
      if (!is_real(fill)) /* possibly a bignum */
	return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2));
    }
  else
    if ((is_int_vector(vect)) || (is_byte_vector(vect)))
      {
	if (!s7_is_integer(fill))
	  return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2));
	if ((is_byte_vector(vect)) &&
	    ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255)))
	  error_nr(sc, sc->out_of_range_symbol,
		   set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill));
      }
    else
      if (is_complex_vector(vect))
	{
	  if (!is_number(fill)) /* possibly a bignum */
	    return(method_or_bust(sc, fill, caller, args, sc->type_names[T_COMPLEX], 2));
	}
  {
    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);
		  const s7_int left = end - 8;
		  s7_int i = start;
		  while (i <= left)
		    Loop_8(orig[i++] = y);
		  for (; i < end; i++)
		    orig[i] = y;
		}}
	  else
	    if (is_byte_vector(vect))
	      {
		const uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill);
		if (k == 0)
		  memclr((void *)(byte_vector_bytes(vect) + start), end - start);
		else local_memset((void *)(byte_vector_bytes(vect) + start), k, end - start); /* unaligned */
	      }
	    else
	      if (is_complex_vector(vect))
		{
		  s7_complex cfill = s7_to_c_complex(fill);
		  for (s7_int i = start; i < end; i++) complex_vector(vect, i) = cfill;
		}}
  return(fill);
}

#if !With_Pure_s7
/* -------------------------------- vector-fill! -------------------------------- */
static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val"
  #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol)
  return(g_vector_fill_1(sc, sc->vector_fill_symbol, args));
}

/* -------------------------------- vector-append -------------------------------- */
static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller);
static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_pointer args);

static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
{
  /* returns a one-dimensional vector.  To handle multidimensional vectors, we'd need to
   *   ensure all the dimensional data matches (rank, size of each dimension except the last etc),
   *   which is too much trouble.
   */
  #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments."
  #define Q_vector_append sc->pcl_v

  s7_pointer p = args;
  if (is_null(args))
    return(make_simple_vector(sc, 0));

  if ((is_null(cdr(args))) &&
      (is_any_vector(car(args))))
    return(copy_source_no_dest(sc, car(args), args));

  for (int32_t i = 0; is_pair(p); p = cdr(p), i++)
    {
      const s7_pointer vect = car(p);
      if (!is_any_vector(vect))
	{
	  if (has_active_methods(sc, vect))
	    {
	      const s7_pointer func = find_method_with_let(sc, vect, sc->vector_append_symbol);
	      if (func != sc->undefined)
		{
		  s7_pointer lst, vec, new_vec, arglist = args;
		  if (i == 0)
		    return(s7_apply_function(sc, func, args));
		  sc->temp7 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */
		  lst = sc->temp7;
		  for (int32_t k = 0; k < i; k++, arglist = cdr(arglist), lst = cdr(lst))
		    set_car(lst, car(arglist));
		  vec = g_vector_append(sc, sc->temp7);
		  new_vec = s7_apply_function(sc, func, set_ulist_1(sc, vec, p));
		  if ((s7_Debugging) && (!is_pair(sc->temp7))) fprintf(stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, display(sc->temp7));
		  sc->temp7 = sc->unused;
		  return(new_vec);
		}}
	  wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, vect, sc->type_names[T_VECTOR]);
	}}
  return(vector_append(sc, args, type(car(args)), sc->vector_append_symbol));
}

static s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer v1, s7_pointer v2)  /* this never happens (one call in s7test) */
{
  set_mlist_2(sc, v1, v2); /* 20-Nov-25 */
  return(g_vector_append(sc, sc->mlist_2));
}

static s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3)
{
  set_qlist_3(sc, v1, v2, v3);
  return(g_vector_append(sc, sc->qlist_3));
}
#endif


/* -------------------------------- vector-ref|set! -------------------------------- */
s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if (index >= vector_length(vec))
    out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
  return(vector_getter(vec)(sc, vec, index));
}

s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if (index >= vector_length(vec))
    out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, wrap_integer(sc, index), It_Is_Too_Large_String);
  if (is_typed_vector(vec))
    return(typed_vector_setter(sc, vec, index, value));
  vector_setter(vec)(sc, vec, index, T_Ext(value));
  return(value);
}

s7_pointer *s7_vector_elements(s7_pointer vec) {return(vector_elements(vec));}

/* these are for s7.h */
s7_int *s7_int_vector_elements(s7_pointer vec) {return(int_vector_ints(vec));}
s7_int s7_int_vector_ref(s7_pointer vec, s7_int index) {return(int_vector(vec, index));}
s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) {int_vector(vec, index) = value; return(value);}

uint8_t *s7_byte_vector_elements(s7_pointer vec) {return(byte_vector_bytes(vec));}
uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index) {return(byte_vector(vec, index));}
uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value) {byte_vector(vec, index) = value; return(value);}

s7_double *s7_float_vector_elements(s7_pointer vec) {return(float_vector_floats(vec));}
s7_double s7_float_vector_ref(s7_pointer vec, s7_int index) {return(float_vector(vec, index));}
s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value) {float_vector(vec, index) = value; return(value);}

s7_complex *s7_complex_vector_elements(s7_pointer vec) {return(complex_vector_complexes(vec));}
s7_complex s7_complex_vector_ref(s7_pointer vec, s7_int index) {return(complex_vector(vec, index));}
s7_complex s7_complex_vector_set(s7_pointer vec, s7_int index, s7_complex value) {complex_vector(vec, index) = value; return(value);}

s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size)
{
  if (dims_size <= 0) return(0);
  if (vector_dimension_info(vec))
    {
      s7_int lim = vector_ndims(vec);
      if (lim > dims_size) lim = dims_size;
      for (s7_int i = 0; i < lim; i++)	dims[i] = vector_dimension(vec, i);
      return(lim);
    }
  dims[0] = vector_length(vec);
  return(1);
}

s7_int s7_vector_dimension(s7_pointer vec, s7_int dim)
{
  if (vector_dimension_info(vec))
    return(vector_dimension(vec, dim));
  return((dim == 0) ? vector_length(vec) : -1);
}

s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size)
{
  if (offs_size <= 0) return(0);
  if (vector_dimension_info(vec))
    {
      s7_int lim = vector_ndims(vec);
      if (lim > offs_size) lim = offs_size;
      for (s7_int i = 0; i < lim; i++)	offs[i] = vector_offset(vec, i);
      return(lim);
    }
  offs[0] = 1;
  return(1);
}


static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_int indices, va_list ap)
{
  s7_int index;
  const s7_int rank = vector_rank(vector);
  if (rank != indices)
    {
      va_end(ap);
      wrong_number_of_arguments_error_nr(sc, "s7_vector_ref_n: wrong number of indices: ~A", 44, wrap_integer(sc, indices));
    }
  if (rank == 1)
    index = va_arg(ap, s7_int);
  else
    {
      s7_int i;
      const s7_int *dimensions = vector_dimensions(vector);
      const s7_int *offsets = vector_offsets(vector);
      for (i = 0, index = 0; i < indices; i++)
	{
	  const s7_int ind = va_arg(ap, s7_int);
	  if ((ind < 0) || (ind >= dimensions[i]))
	    {
	      va_end(ap);
	      out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	      return(-1);
	    }
	  index += (ind * offsets[i]);
	}}
  va_end(ap);
  return(index);
}

s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...)
{
  s7_int index;
  va_list ap;
  va_start(ap, indices);
  index = flatten_multivector_indices(sc, vector, indices, ap);
  return(vector_getter(vector)(sc, vector, index));
}

s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...)
{
  s7_int index;
  va_list ap;
  va_start(ap, indices);
  index = flatten_multivector_indices(sc, vector, indices, ap);
  if (is_typed_vector(vector))
    return(typed_vector_setter(sc, vector, index, value));
  return(vector_setter(vector)(sc, vector, index, value));
}


/* -------------------------------- vector->list -------------------------------- */
s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect)
{
  const s7_int len = vector_length(vect);
  if (len == 0) return(sc->nil);
  if (len > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "vector->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length)));
  begin_temp(sc->y, sc->nil);
  gc_protect_via_stack(sc, vect);
  check_free_heap_size(sc, 2 * len);
  switch (type(vect))
    {
    case T_VECTOR:
      for (s7_int i = len - 1; i >= 0; i--)
	sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y);
      break;
    case T_BYTE_VECTOR:
      for (s7_int i = len - 1; i >= 0; i--)
	sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y);
      break;
    case T_INT_VECTOR:
      for (s7_int i = len - 1; i >= 0; i--)
	sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y);
      break;
    case T_FLOAT_VECTOR:
      for (s7_int i = len - 1; i >= 0; i--)
	sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y);
      break;
    case T_COMPLEX_VECTOR:
      for (s7_int i = len - 1; i >= 0; i--)
	{
	  s7_complex z = complex_vector(vect, i);
	  sc->y = cons_unchecked(sc, make_complex_unchecked(sc, creal(z), cimag(z)), sc->y);
	}
      break;
    }
  unstack_gc_protect(sc);
  return_with_end_temp(sc->y);
}

s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array)
{
  if (num_values == 0) return(sc->nil);
  begin_temp(sc->y, sc->nil);
  check_free_heap_size(sc, num_values);
  for (s7_int i = num_values - 1; i >= 0; i--)
    sc->y = cons_unchecked(sc, array[i], sc->y);
  if (sc->safety > No_Safety)
    check_list_validity(sc, __func__, sc->y);
  return_with_end_temp(sc->y);
}

#if !With_Pure_s7
static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)"
  #define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol)

  s7_int start = 0, end;
  const s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(sole_arg_method_or_bust(sc, vec, sc->vector_to_list_symbol, args, sc->type_names[T_VECTOR]));
  end = vector_length(vec);
  if (!is_null(cdr(args)))
    {
      const s7_pointer p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, cdr(args), &start, &end);
      if (p != sc->unused) return(p);
      if (start == end) return(sc->nil);
    }
  if ((end - start) > sc->max_list_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_5(sc, wrap_string(sc, "vector->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78),
			 wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start),
			 wrap_integer(sc, sc->max_list_length)));

  check_free_heap_size(sc, end - start);
  begin_temp(sc->temp6, sc->nil);
  gc_protect_via_stack(sc, vec);
  if (is_t_vector(vec))
    for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_element(vec, i), sc->temp6);
  else for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->temp6);
  unstack_gc_protect(sc);
  return_with_end_temp(sc->temp6);
}

static s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer vec)
{
  if (!is_any_vector(vec))
    return(method_or_bust_p(sc, vec, sc->vector_to_list_symbol, sc->type_names[T_VECTOR]));
  return(s7_vector_to_list(sc, vec));
}
#endif


/* -------------------------------- string->byte-vector -------------------------------- */
static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector."
  #define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol)

  const s7_pointer str = car(args);
  if (!is_string(str))
    return(method_or_bust_p(sc, str, sc->string_to_byte_vector_symbol, sc->type_names[T_STRING]));
  if (string_length(str) > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "string->byte-vector string is too long: (> ~D ~D) (*s7* 'max-vector-length)", 75),
			 wrap_integer(sc, string_length(str)), wrap_integer(sc, sc->max_vector_length)));
  return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str)))));
}


/* -------------------------------- byte-vector->string -------------------------------- */
static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string."
  #define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol)

  const s7_pointer bv = car(args);
  if (!is_byte_vector(bv))
    return(method_or_bust_p(sc, bv, sc->byte_vector_to_string_symbol, sc->type_names[T_BYTE_VECTOR]));
  if (byte_vector_length(bv) == 0) return(nil_string);
  if (byte_vector_length(bv) > sc->max_string_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "byte-vector->string byte-vector is too large: (> ~D ~D) (*s7* 'max-string-length)", 81),
			 wrap_integer(sc, byte_vector_length(bv)), wrap_integer(sc, sc->max_string_length)));
  return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, bv, make_empty_string(sc, byte_vector_length(bv), '\0'))));
}


/* -------------------------------- vector -------------------------------- */
static s7_pointer g_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_vector "(vector ...) returns a vector whose elements are the arguments"
  #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T)

  s7_pointer end;
  const s7_int len = proper_list_length_with_end(args, &end);
  if (!is_null(end))
    error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "vector contents list is not a proper list", 41)));
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 71),
			 args, wrap_integer(sc, sc->max_vector_length)));
  {
    const s7_pointer vec = make_simple_vector(sc, len);
    if (len > 0)
      for (s7_int i = 0; is_pair(args); args = cdr(args), i++)
	vector_element(vec, i) = car(args);
    return(vec);
  }
}

static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
{
  const s7_pointer vec = make_simple_vector(sc, 2);
  vector_element(vec, 0) = p1;
  vector_element(vec, 1) = p2;
  return(vec);
}

static s7_pointer g_vector_2(s7_scheme *sc, s7_pointer args) {return(vector_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_vector_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = make_simple_vector(sc, 3);
  vector_element(vec, 0) = car(args); args = cdr(args);
  vector_element(vec, 1) = car(args);
  vector_element(vec, 2) = cadr(args);
  return(vec);
}

static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 2) return(sc->vector_2);
  return((args == 3) ? sc->vector_3 : func);
}


/* -------------------------------- float-vector? -------------------------------- */
static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector"
  #define Q_is_float_vector sc->pl_bt
  check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args);
}


/* -------------------------------- float-vector -------------------------------- */
static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments"
  #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol)

  s7_pointer bad_end = sc->nil;
  const s7_int len = proper_list_length_with_end(args, &bad_end);
  if (!is_null(bad_end))
    error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "float-vector contents list is not a proper list", 47)));
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "float-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 77),
			 args, wrap_integer(sc, sc->max_vector_length)));
  {
    const s7_pointer vec = make_simple_float_vector(sc, len);
    s7_int i = 0;
    if (len == 0) return(vec);
    for (s7_pointer nums = args; is_pair(nums); nums = cdr(nums), i++)
      {
	const s7_pointer num = car(nums);
	if (is_t_real(num))
	  float_vector(vec, i) = real(num);
	else
	  if (is_real(num))                         /* bignum is ok here */
	    float_vector(vec, i) = s7_real(num);
	  else return(method_or_bust(sc, num, sc->float_vector_symbol, args, sc->type_names[T_REAL], i + 1));
      }
    return(vec);
  }
}

static s7_pointer float_vector_p_d(s7_scheme *sc, s7_double x)
{
  s7_pointer vec = make_simple_float_vector(sc, 1);
  float_vector(vec, 0) = x;
  return(vec);
}

static s7_pointer float_vector_p_i(s7_scheme *sc, s7_int x) /* thash */
{
  s7_pointer vec = make_simple_float_vector(sc, 1);
  float_vector(vec, 0) = (s7_double)x;
  return(vec);
}
/* p_dd case doesn't get any hits */


/* -------------------------------- int-vector? -------------------------------- */
static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector"
  #define Q_is_int_vector sc->pl_bt
  check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args);
}


/* -------------------------------- int-vector -------------------------------- */
static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments"
  #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol)

  s7_pointer bad_end = sc->nil;
  const s7_int len = proper_list_length_with_end(args, &bad_end);
  if (!is_null(bad_end))
    error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "int-vector contents list is not a proper list", 45)));
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "int-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 75),
			 args, wrap_integer(sc, sc->max_vector_length)));
  {
    const s7_pointer vec = make_simple_int_vector(sc, len);
    s7_int i = 0;
    if (len == 0) return(vec);
    for (s7_pointer arglist = args; is_pair(arglist); arglist = cdr(arglist), i++)
      {
	const s7_pointer num = car(arglist);
	if (!s7_is_integer(num))
	  return(method_or_bust(sc, num, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1));
	int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, num);
      }
    return(vec);
  }
}

static s7_pointer int_vector_p_i(s7_scheme *sc, s7_int x)
{
  s7_pointer vec = make_simple_int_vector(sc, 1);
  int_vector(vec, 0) = x;
  return(vec);
}
/* p_ii case doesn't get any hits */


/* -------------------------------- byte-vector? -------------------------------- */
static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector"
  #define Q_is_byte_vector sc->pl_bt
  check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, args);
}


/* -------------------------------- byte-vector -------------------------------- */
static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments"
  #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol)

  s7_pointer bad_end = sc->nil;
  const s7_int len = proper_list_length_with_end(args, &bad_end);
  if (!is_null(bad_end))
    error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "byte-vector contents list is not a proper list", 46)));
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "byte-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 76),
			 args, wrap_integer(sc, sc->max_vector_length)));
  {
    s7_int i = 0;
    const s7_pointer vec = make_simple_byte_vector(sc, len);
    uint8_t *str = byte_vector_bytes(vec);
    if (len == 0) return(vec);
    for (s7_pointer arglist = args; is_pair(arglist); i++, arglist = cdr(arglist))
      {
	const s7_pointer byte = car(arglist);
	s7_int b;
	if (is_t_integer(byte))
	  b = integer(byte);
	else
#if With_Gmp
	  if (is_t_big_integer(byte))
	    b = big_integer_to_s7_int(sc, big_integer(byte));
	  else
#endif
	    return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, sc->type_names[T_INTEGER], i + 1));
	if ((b < 0) || (b > 255))
	  wrong_type_error_nr(sc, sc->byte_vector_symbol, i + 1, byte, An_Unsigned_Byte_String);
	str[i] = (uint8_t)b;
      }
    return(vec);
  }
}

/* -------------------------------- complex-vector? -------------------------------- */
static s7_pointer g_is_complex_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_complex_vector "(complex-vector? obj) returns #t if obj is an homogeneous complex vector"
  #define Q_is_complex_vector sc->pl_bt
  check_boolean_method(sc, s7_is_complex_vector, sc->is_complex_vector_symbol, args);
}


/* -------------------------------- complex-vector -------------------------------- */
static s7_pointer g_complex_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_complex_vector "(complex-vector ...) returns an homogeneous complex vector whose elements are the arguments"
  #define Q_complex_vector s7_make_circular_signature(sc, 1, 2, sc->is_complex_vector_symbol, sc->is_complex_symbol)

  s7_pointer bad_end = sc->nil;
  const s7_int len = proper_list_length_with_end(args, &bad_end);
  if (!is_null(bad_end))
    error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "complex-vector contents list is not a proper list", 49)));
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "complex-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 79),
			 args, wrap_integer(sc, sc->max_vector_length)));
  {
    const s7_pointer vec = make_simple_complex_vector(sc, len);
    s7_int i = 0;
    if (len == 0) return(vec);
    for (s7_pointer arglist = args; is_pair(arglist); arglist = cdr(arglist), i++)
      {
	const s7_pointer num = car(arglist);
	if (is_number(num))
	  complex_vector(vec, i) = s7_to_c_complex(num);
	else return(method_or_bust(sc, num, sc->complex_vector_symbol, args, sc->type_names[T_COMPLEX], i + 1));
      }
    return(vec);
  }
}


#if !With_Pure_s7
/* -------------------------------- list->vector -------------------------------- */
static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)"
  #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol)

  const s7_pointer lst = car(args);
  if (is_null(lst))
    return(make_simple_vector(sc, 0)); /* was s7_make_vector */
  sc->temp3 = lst;
  if (!s7_is_proper_list(sc, lst))
    return(method_or_bust_p(sc, lst, sc->list_to_vector_symbol, A_Proper_List_String));
  {
    s7_pointer result = g_vector(sc, lst);
    sc->temp3 = sc->unused;
    return(result);
  }
}

/* -------------------------------- vector-length -------------------------------- */
static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_length "(vector-length v) returns the length of vector v"
  #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)

  const s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(sole_arg_method_or_bust(sc, vec, sc->vector_length_symbol, args, sc->type_names[T_VECTOR]));
  return(make_integer(sc, vector_length(vec)));
}

static s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer vec)
{
  if (!is_any_vector(vec))
    return(integer(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR])));
  return(vector_length(vec));
}

static s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec)
{
  if (!is_any_vector(vec))
    return(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR]));
  return(make_integer(sc, vector_length(vec)));
}
#endif


/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */
static bool s7_is_subvector(s7_pointer vec) {return((is_any_vector(vec)) && (is_subvector(vec)));}

static s7_pointer g_is_subvector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector"
  #define Q_is_subvector sc->pl_bt
  check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol, args);
}

static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args)
{
  #define H_subvector_position "(subvector-position obj) returns obj's offset"
  #define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol)

  const s7_pointer sv = car(args);
  if (s7_is_subvector(sv))
    switch (type(sv))
      {
      case T_VECTOR:         return(make_integer(sc, (s7_int)(vector_elements(sv) - vector_elements(subvector_vector(sv)))));
      case T_INT_VECTOR:     return(make_integer(sc, (s7_int)(int_vector_ints(sv) - int_vector_ints(subvector_vector(sv)))));
      case T_FLOAT_VECTOR:   return(make_integer(sc, (s7_int)(float_vector_floats(sv) - float_vector_floats(subvector_vector(sv)))));
      case T_COMPLEX_VECTOR: return(make_integer(sc, (s7_int)(complex_vector_complexes(sv) - complex_vector_complexes(subvector_vector(sv)))));
      case T_BYTE_VECTOR:    return(make_integer(sc, (s7_int)(byte_vector_bytes(sv) - byte_vector_bytes(subvector_vector(sv)))));
      }
  return(sole_arg_method_or_bust(sc, sv, sc->subvector_position_symbol, args, sc->type_names[T_VECTOR]));
}

static s7_pointer g_subvector_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj"
  #define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol)

  const s7_pointer obj = car(args);
  if (s7_is_subvector(obj))
    return(subvector_vector(obj));
  return(sole_arg_method_or_bust(sc, obj, sc->subvector_vector_symbol, args, sc->type_names[T_VECTOR]));
}

static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7_int index)
{
  const s7_int dims = vector_ndims(vect) - skip_dims;
  s7_pointer subvect;
  if ((s7_Debugging) && (index >= vector_length(vect))) fprintf(stderr, "subvector index is too big\n");
  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);
    }

  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);
}

static s7_pointer g_subvector(s7_scheme *sc, s7_pointer args)
{
  #define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \
a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info."
  #define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol)

  /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6)
   * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6))
   */
  const s7_pointer orig = car(args);
  vdims_t *vd = NULL;
  s7_int new_len, orig_len, offset = 0;

  if (!is_any_vector(orig))
    return(method_or_bust(sc, orig, sc->subvector_symbol, args, sc->type_names[T_VECTOR], 1));

  orig_len = vector_length(orig);
  new_len = orig_len;

  if (is_pair(cdr(args))) /* get start point in vector */
    {
      const s7_pointer start = cadr(args);
      if (!s7_is_integer(start))
	return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2));
      offset = s7_integer_clamped_if_gmp(sc, start);
      if ((offset < 0) || (offset > orig_len))  /* we need this if, for example, offset == 9223372036854775807 */
	out_of_range_error_nr(sc, sc->subvector_symbol, Int_Two, start, (offset < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      new_len -= offset;

      if (is_pair(cddr(args))) /* get end point in vector */
	{
	  const s7_pointer end = caddr(args);
	  s7_int new_end;
	  if (!s7_is_integer(end))
	    return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3));
	  new_end = s7_integer_clamped_if_gmp(sc, end);
	  if ((new_end < 0) || (new_end > orig_len))
	    out_of_range_error_nr(sc, sc->subvector_symbol, Int_Three, end, (new_end < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	  if (offset > new_end)
	    out_of_range_error_nr(sc, sc->subvector_symbol, Int_Two, start, wrap_string(sc, "start point > end point", 23));
	  new_len = new_end - offset;

	  if (is_pair(cdddr(args))) /* get new dimensions */
	    {
	      const s7_pointer dims = cadddr(args);
	      if ((is_null(dims)) ||
		  (!s7_is_proper_list(sc, dims)))
		return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4));

	      for (s7_pointer dim_list = dims; is_pair(dim_list); dim_list = cdr(dim_list))
		if ((!s7_is_integer(car(dim_list)))        ||       /* (subvector v '((1 2) (3 4))) */
		    (s7_integer_clamped_if_gmp(sc, car(dim_list)) > orig_len) ||
		    (s7_integer_clamped_if_gmp(sc, car(dim_list)) < 0))
		  error_nr(sc, sc->wrong_type_arg_symbol,
			   set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43)));

	      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->wrong_type_arg_symbol,
			   set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~D, does not match the start and end positions: ~S to ~S~%", 88),
				       wrap_integer(sc, new_len), start, end));
		}
	      vdims_original(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 */

  {
    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);
  }
}


/* -------------------------------- vector-ref -------------------------------- */
static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices)
{
  s7_int index = 0;
  if (vector_length(vect) == 0)
    out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_One, vect, It_Is_Too_Large_String);

  if (vector_rank(vect) > 1)
    {
      s7_int i;
      s7_pointer index_list;
      for (index_list = indices, i = 0; (is_pair(index_list)) && (i < vector_ndims(vect)); index_list = cdr(index_list), i++)
	{
	  s7_int n;
	  const s7_pointer ind = car(index_list);
	  if (!s7_is_integer(ind))
	    return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2));
          n = s7_integer_clamped_if_gmp(sc, ind);
	  if ((n < 0) || (n >= vector_dimension(vect, i)))
	    out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	  index += n * vector_offset(vect, i);
	}
      if (is_not_null(index_list))
	{
	  s7_pointer nv;
	  if (!is_t_vector(vect))
	    error_nr(sc, sc->wrong_number_of_args_symbol,
		     set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices)));
	  nv = vector_element(vect, index);
	  return(implicit_index(sc, nv, index_list));
	}
      /* if not enough indices, return a subvector covering whatever is left */
      if (i < vector_ndims(vect))
	return(subvector(sc, vect, i, index));
    }
  else
    {
      const s7_pointer ind = car(indices);
      /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */
      if (!s7_is_integer(ind))
	return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2));
      index = s7_integer_clamped_if_gmp(sc, ind);
      if ((index < 0) || (index >= vector_length(vect)))
	out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_Two, ind, (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      if (is_not_null(cdr(indices)))                /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */
	{
	  s7_pointer nv;
	  if (!is_t_vector(vect))
	    error_nr(sc, sc->wrong_number_of_args_symbol,
		     set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices)));
	  nv = vector_element(vect, index);
	  return(implicit_pair_index_checked(sc, vect, nv, indices));
	}}
  return((vector_getter(vect))(sc, vect, index));
}

static s7_pointer g_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v."
  #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol)

  const s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(method_or_bust(sc, vec, sc->vector_ref_symbol, args, sc->type_names[T_VECTOR], 1));
  return(vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */
}

static s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((!is_t_vector(vec)) ||
      (vector_rank(vec) > 1) ||
      (index < 0) || (index >= vector_length(vec)))
    return(g_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index))));
  return(vector_element(vec, index));
}

static s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index) /* callable but just barely (tgsl.scm) */
{
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(vector_getter(vec)(sc, vec, index));
}

static s7_pointer t_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(vector_element(vec, index));
}

static s7_pointer t_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(vector_element(vec, index));}

static s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2)
{
  if ((!is_any_vector(vec)) ||
      (vector_rank(vec) != 2) ||
      (i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_ref(sc, set_plist_3(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2))));
  return(vector_getter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0))));
}

static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2)
{
  if ((i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_ref(sc, set_plist_3(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2))));
  return(vector_element(vec, i2 + (i1 * vector_offset(vec, 0))));
}

static inline s7_pointer vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer ind)
{
  s7_int index;
  if ((!is_t_vector(vec)) ||
      (vector_rank(vec) != 1) ||
      (!s7_is_integer(ind)))
    return(g_vector_ref(sc, set_plist_2(sc, vec, ind)));
  index = s7_integer_clamped_if_gmp(sc, ind);
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->vector_ref_symbol, Int_Two, ind, (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(vector_element(vec, index));
}

static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args) {return(vector_ref_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args);
  s7_pointer i1, i2;
  s7_int ix, iy;

  if (!is_any_vector(vec)) return(g_vector_ref(sc, args));
  if (vector_rank(vec) != 2) return(g_vector_ref(sc, args));
  i1 = cadr(args);
  if (!s7_is_integer(i1)) return(g_vector_ref(sc, args));
  i2 = caddr(args);
  if (!s7_is_integer(i2)) return(g_vector_ref(sc, args));
  ix = s7_integer_clamped_if_gmp(sc, i1);
  iy = s7_integer_clamped_if_gmp(sc, i2);
  if ((ix >= 0) && (iy >= 0) &&
      (ix < vector_dimension(vec, 0)) && (iy < vector_dimension(vec, 1)))
    {
      s7_int index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */
      return(vector_getter(vec)(sc, vec, index)); /* splitting out t_vector case here was not faster? */
    }
  return(g_vector_ref(sc, args));
}

static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 2) return(sc->vector_ref_2);
  return((args == 3) ? sc->vector_ref_3 : func);
}


/* -------------------------------- vector-set! -------------------------------- */
static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value."
  #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)

  const s7_pointer vec = car(args);
  s7_pointer val;
  s7_int index;

  if (!is_any_vector(vec))
    return(method_or_bust(sc, vec, sc->vector_set_symbol, args, sc->type_names[T_VECTOR], 1));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->vector_set_symbol, vec));
  if (vector_length(vec) == 0)
    out_of_range_error_nr(sc, sc->vector_set_symbol, Int_One, vec, It_Is_Too_Large_String);

  if (vector_rank(vec) > 1)
    {
      s7_int i;
      s7_pointer index_list;
      index = 0;
      for (index_list = cdr(args), i = 0; (is_pair(cdr(index_list))) && (i < vector_ndims(vec)); index_list = cdr(index_list), i++)
	{
	  s7_int n;
	  const s7_pointer ind = car(index_list);
	  if (!s7_is_integer(ind))
	    return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2));
          n = s7_integer_clamped_if_gmp(sc, ind);
	  if ((n < 0) || (n >= vector_dimension(vec, i)))
	    out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	  index += n * vector_offset(vec, i);
	}
      if (is_not_null(cdr(index_list)))
	wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args);
      if (i != vector_ndims(vec))
	wrong_number_of_arguments_error_nr(sc, "not enough arguments for vector-set!: ~S", 40, args);

      /* since vector-ref can return a subvector (if not passed enough args), it might be interesting to
       *   also set a complete subvector via set!, but would that introduce ambiguity?  Only copy the vector
       *   if at least one index is missing, and the value fits.  It also makes error detection harder,
       *   but so does the current vector-ref handling.  Can't decide...
       *   (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0)
       * Other possible additions: complex-vector and string-vector.
       */
      val = car(index_list);
    }
  else
    {
      const s7_pointer ind = cadr(args);
      if (!s7_is_integer(ind))
	return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
      index = s7_integer_clamped_if_gmp(sc, ind);
      if ((index < 0) || (index >= vector_length(vec)))
	out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, ind, (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      if (is_not_null(cdddr(args)))
	{
	  const s7_pointer new_vec = vector_getter(vec)(sc, vec, index);
	  if (!is_any_vector(new_vec))
	    wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args);
	  return(g_vector_set(sc, set_ulist_1(sc, new_vec, cddr(args))));
	}
      val = caddr(args);
    }
  if (is_typed_t_vector(vec))
    return(typed_vector_setter(sc, vec, index, val));
  if (is_t_vector(vec))
    vector_element(vec, index) = val;
  else vector_setter(vec)(sc, vec, index, val);
  return(val);
}

static s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) /* almost never called -- see one case in s7test.scm[13736] */
{
  if ((!is_any_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(g_vector_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value)));
  if (is_t_vector(vec))
    {
      if (is_typed_vector(vec)) return(typed_vector_setter(sc, vec, index, value));
      vector_element(vec, index) = value;
    }
  else vector_setter(vec)(sc, vec, index, value);
  return(value);
}

static s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((index >= 0) && (index < vector_length(vec)))
    vector_element(vec, index) = value;
  else out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(value);
}

static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value)
{
  if ((!is_any_vector(vec)) ||
      (vector_rank(vec) != 2) ||
      (i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value)));
  if (is_t_vector(vec))
    {
      if (is_typed_vector(vec))
	return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value));
      vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = value;
    }
  else vector_setter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value);
  return(value);
}

static s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value)
{
  /* normal untyped vector, rank == 2 */
  if ((i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value)));
  vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = value;
  return(value);
}

static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((index >= 0) && (index < vector_length(vec)))
    typed_vector_setter(sc, vec, index, value);
  else out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(value);
}

static s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value)
{
  if ((i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value)));
  return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value));
}

static s7_pointer t_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer value) {vector_element(vec, index) = value; return(value);}

static s7_pointer typed_t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  typed_vector_setter(sc, vec, index, value);
  return(value);
}

static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args)
{
  /* (vector-set! vector index value) */
  const s7_pointer vec = car(args);
  s7_int index;

  if (!is_any_vector(vec))
    return(g_vector_set(sc, args));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->vector_set_symbol, vec));
  if (vector_rank(vec) > 1)
    return(g_vector_set(sc, args));
  {
    const s7_pointer ind = cadr(args);
    if (!s7_is_integer(ind))
      return(g_vector_set(sc, args));
    index = s7_integer_clamped_if_gmp(sc, ind);
  }
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  {
    const s7_pointer val = caddr(args);
    if (is_typed_t_vector(vec))
      return(typed_vector_setter(sc, vec, index, val));
    if (is_t_vector(vec))
      vector_element(vec, index) = val;
    else vector_setter(vec)(sc, vec, index, val);
    return(val);
  }
}

static s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val)
{
  s7_int index;
  /* if ((s7_Debugging) && (is_mutable(ind)) && (is_t_integer(ind))) ind = make_integer(sc, integer(ind)); */
  /* if ((s7_Debugging) && (is_mutable(ind)) && (is_t_integer(ind))) fprintf(stderr, "%s[%d]: skipping make-integer\n", __func__, __LINE__); */

  if ((!is_t_vector(vec)) || (vector_rank(vec) > 1))
    return(g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->vector_set_symbol, vec));
  if (!s7_is_integer(ind))
    return(g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
  index = s7_integer_clamped_if_gmp(sc, ind);
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);

  if (is_typed_vector(vec))
    return(typed_vector_setter(sc, vec, index, val));
  vector_element(vec, index) = val;
  return(val);
}

static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args), ip1 = cadr(args), ip2 = caddr(args);
  s7_int i1, i2;
  if ((!is_any_vector(vec)) ||
      (vector_rank(vec) != 2) || (is_immutable_vector(vec)) ||
      (!s7_is_integer(ip1)) || (!s7_is_integer(ip2)))
    return(g_vector_set(sc, args));
  i1 = s7_integer_clamped_if_gmp(sc, ip1);
  i2 = s7_integer_clamped_if_gmp(sc, ip2);
  if ((i1 < 0) || (i2 < 0) ||
      (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1)))
    return(g_vector_set(sc, args));
  {
    const s7_pointer val = cadddr(args);
    if (is_typed_t_vector(vec))
      return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val));
    if (is_t_vector(vec))
      vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = val;
    else vector_setter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val);
    return(val);
  }
}

static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 3) return(sc->vector_set_3);
  return((args == 4) ? sc->vector_set_4 : func);
}


/* -------------------------------- make-vector -------------------------------- */
static s7_int multivector_length(s7_scheme *sc, s7_pointer dim_list, s7_pointer caller)
{
  s7_int len = 1;
  const s7_int num_dims = s7_list_length(sc, dim_list);
  if (num_dims <= 0)                /* 0 if circular, negative if dotted */
    wrong_type_error_nr(sc, caller, 1, dim_list, A_Proper_List_String);
  if (num_dims > sc->max_vector_dimensions)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "~S specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 78),
			 dim_list, wrap_integer(sc, sc->max_vector_dimensions)));
  for (s7_pointer dims = dim_list; is_pair(dims); dims = cdr(dims))
    {
      const s7_pointer dim = car(dims);
      if (!s7_is_integer(dim))
	wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, sc->type_names[T_INTEGER]);
#if Have_Overflow_Checks
      if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, dim), &len)) /* or better perhaps len > sc->max_vector_length */
	out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(dims, dim_list)), dim, It_Is_Too_Large_String);
#else
      len *= s7_integer_clamped_if_gmp(sc, dim);
#endif
      if (len < 0)
	wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, A_Non_Negative_Integer_String);
    }
  return(len);
}

static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf)
{
  const s7_pointer sig = c_function_signature(typf);
  if ((sig != sc->pl_bt) &&
      (is_pair(sig)) &&
      ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig)))))
    wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a boolean procedure", 19));
  if (!c_function_name(typf))
    wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a named function", 16));
  if (!c_function_marker(typf))
    c_function_set_marker(typf, mark_vector_1);
}

static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer 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 s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  s7_int len;
  const s7_pointer dims = car(args);
  s7_pointer fill = sc->unspecified, typf = sc->T;
  int32_t result_type = T_VECTOR;

  if (s7_is_integer(dims))
    {
      len = s7_integer_clamped_if_gmp(sc, dims);
      if (len < 0)
	wrong_type_error_nr(sc, caller, 1, dims, A_Non_Negative_Integer_String);
    }
  else
    {
      if (!is_pair(dims))
	return(method_or_bust(sc, dims, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1));
      if (!s7_is_integer(car(dims)))
	wrong_type_error_nr(sc, caller, 1, car(dims), sc->type_names[T_INTEGER]);
      len = (is_null(cdr(dims))) ? s7_integer_clamped_if_gmp(sc, car(dims)) : multivector_length(sc, dims, caller);
    }

  if (is_pair(cdr(args)))
    {
      fill = cadr(args);
      if (caller == sc->make_int_vector_symbol)
	result_type = T_INT_VECTOR;
      else
	if (caller == sc->make_float_vector_symbol)
	  result_type = T_FLOAT_VECTOR;
	else
	  if (caller == sc->make_byte_vector_symbol)
	    result_type = T_BYTE_VECTOR;
	  else
	    if (caller == sc->make_complex_vector_symbol)
	      result_type = T_COMPLEX_VECTOR;
      if (is_pair(cddr(args)))
	{
	  typf = caddr(args);
	  if ((!is_c_function(typf)) &&
	      (!is_any_closure(typf)) &&
	      (typf != sc->T))  /* default value */
	    wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a built-in procedure, a closure or #t", 37));
	  if (is_any_closure(typf))
	    {
	      if (!is_symbol(find_closure(sc, typf, closure_let(typf))))
		wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16));
	      /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */
	    }
	  else
	    if (is_c_function(typf))
	      {
		if (typf == global_value(sc->is_float_symbol))
		  {
		    if (!is_real(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_REAL]);
		    result_type = T_FLOAT_VECTOR;
		  }
		else
		  if (typf == global_value(sc->is_integer_symbol))
		    {
		      if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]);
		      result_type = (With_Gmp) ? T_VECTOR : T_INT_VECTOR;
		    }
		  else
		    if (typf == global_value(sc->is_byte_symbol))
		      {
			if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, An_Unsigned_Byte_String);
			result_type = T_BYTE_VECTOR;
		      }
		    else
		      if (typf == global_value(sc->is_complex_symbol))
			{
			  if (!is_number(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_COMPLEX]);
			  result_type = T_COMPLEX_VECTOR;
			}
		      else check_vector_typer_c_function(sc, caller, typf);
	      }}}
  /* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error.
   *    otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc.
   */
  if ((result_type == T_VECTOR) &&
      (typf != sc->T) &&            /* default value */
      (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F))
    {
      const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), Indefinite_Article);
      wrong_type_error_nr(sc, sc->make_vector_symbol, 2, fill, wrap_string(sc, tstr, safe_strlen(tstr)));
    }
  {
    const s7_pointer vec = make_vector_1(sc, len, Vector_Not_Filled, result_type);
    if ((result_type == T_VECTOR) &&
	(typf != sc->T))  /* default value */
      {
	set_typed_vector(vec);
	typed_vector_set_typer(vec, typf);

	if ((is_c_function(typf)) &&
	    (c_function_has_simple_elements(typf)))
	  set_has_simple_elements(vec);
      }
    s7_vector_fill(sc, vec, fill);
    if ((is_pair(dims)) &&
	(is_pair(cdr(dims))))
      return(make_multivector(sc, vec, dims));
    add_vector(sc, vec);
    return(vec);
  }
}

static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_vector "(make-vector len (value #<unspecified>) type) returns a vector of len elements initialized to value. \
To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \
(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size).  (make-vector '(2 3) 1.0) \
returns a 2 dimensional vector of 6 total elements, all initialized to 1.0. The 'type argument can set the element type. \
It is a function that checks the new value, returning #f if the value is not acceptable: (make-vector 8 1/2 rational?)."
  #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \
					  s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \
					  s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) /* actually #t here not boolean? */
  return(g_make_vector_1(sc, args, sc->make_vector_symbol));
}


/* -------------------------------- make-float-vector -------------------------------- */
static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector."
  #define Q_make_float_vector s7_make_signature(sc, 3, \
                                sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol)
  const s7_pointer size = car(args); /* can be a pair if multiple dimensions */
  s7_int len;

  if ((is_pair(cdr(args))) || (!s7_is_integer(size)))
    {
      s7_pointer init;
      if (is_pair(cdr(args)))
	{
	  init = cadr(args);
	  if (!is_real(init))
	    return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, sc->type_names[T_REAL], 2));
#if With_Gmp
	  if (s7_is_bignum(init))
	    return(g_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, s7_real(init))), sc->make_float_vector_symbol));
#endif
	  if (is_rational(init))
	    return(g_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol));
	}
      else init = Real_Zero;
      if (s7_is_integer(size))
	len = s7_integer_clamped_if_gmp(sc, size);
      else
	{
	  if (!is_pair(size))
	    return(method_or_bust(sc, size, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1));
	  len = multivector_length(sc, size, sc->make_float_vector_symbol);
	}
      {
	const s7_pointer vect = make_vector_1(sc, len, Vector_Not_Filled, T_FLOAT_VECTOR);
	float_vector_fill(vect, s7_real(init));
	if (!s7_is_integer(size))
	  return(make_multivector(sc, vect, size));
	add_vector(sc, vect);
	return(vect);
      }}
  len = s7_integer_clamped_if_gmp(sc, size);
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_float_vector_symbol, Int_One, size, It_Is_Negative_String);
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-float-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
  {
    block_t *arr = mallocate_vector(sc, len * sizeof(s7_double));
    s7_pointer vect;
    new_cell(sc, vect, T_FLOAT_VECTOR | T_Safe_Procedure);
    vector_length(vect) = len;
    vector_block(vect) = arr;
    float_vector_floats(vect) = (s7_double *)block_data(arr);
    if (len > 0)
      {
	if (Step_8(len))
	  memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double));
	else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double));
      }
    vector_set_dimension_info(vect, NULL);
    vector_getter(vect) = float_vector_getter;
    vector_setter(vect) = float_vector_setter;
    add_vector(sc, vect);
    return(vect);
  }
}

static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill)
{
  if ((is_t_integer(len)) && (is_t_real(fill)) &&
      (integer(len)>= 0) && (integer(len) < sc->max_vector_length))
    {
      s7_pointer fv = make_simple_float_vector(sc, integer(len));
      float_vector_fill(fv, real(fill));
      return(fv);
    }
  return(g_make_float_vector(sc, set_plist_2(sc, len, fill)));
}


/* -------------------------------- make-complex-vector -------------------------------- */
static s7_pointer g_make_complex_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_complex_vector "(make-complex-vector len (init 0.0)) returns a complex-vector."
  #define Q_make_complex_vector s7_make_signature(sc, 3, \
                                sc->is_complex_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_complex_symbol)
  const s7_pointer size = car(args);
  s7_int len;

  if ((is_pair(cdr(args))) || (!s7_is_integer(size)))
    {
      s7_pointer init;
      if (is_pair(cdr(args)))
	{
	  init = cadr(args);
	  if (!is_number(init))
	    return(method_or_bust(sc, init, sc->make_complex_vector_symbol, args, sc->type_names[T_COMPLEX], 2));
#if With_Gmp
	  if (s7_is_bignum(init))
	    return(g_make_vector_1(sc, set_plist_2(sc, size, init), sc->make_complex_vector_symbol));
#endif
	  if (is_rational(init))
	    return(g_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_complex_vector_symbol));
	}
      else init = Real_Zero;
      if (s7_is_integer(size))
	len = s7_integer_clamped_if_gmp(sc, size);
      else
	{
	  if (!is_pair(size))
	    return(method_or_bust(sc, size, sc->make_complex_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1));
	  len = multivector_length(sc, size, sc->make_complex_vector_symbol);
	}
      {
	const s7_pointer vect = make_vector_1(sc, len, Vector_Not_Filled, T_COMPLEX_VECTOR);
	complex_vector_fill(vect, s7_to_c_complex(init));
	if (!s7_is_integer(size))
	  return(make_multivector(sc, vect, size));
	add_vector(sc, vect);
	return(vect);
      }}
  len = s7_integer_clamped_if_gmp(sc, size);
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_complex_vector_symbol, Int_One, size, It_Is_Negative_String);
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-complex-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 83),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
  {
    block_t *arr = mallocate_vector(sc, len * sizeof(s7_complex));
    s7_pointer vect;
    new_cell(sc, vect, T_COMPLEX_VECTOR | T_Safe_Procedure);
    vector_length(vect) = len;
    vector_block(vect) = arr;
    complex_vector_complexes(vect) = (s7_complex *)block_data(arr);
    if (len > 0)
      {
	if (Step_8(len))
	  memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex));
	else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex));
      }
    vector_set_dimension_info(vect, NULL);
    vector_getter(vect) = complex_vector_getter;
    vector_setter(vect) = complex_vector_setter;
    add_vector(sc, vect);
    return(vect);
  }
}


/* -------------------------------- make-int-vector -------------------------------- */
static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector."
  #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, \
                               s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol)
  const s7_pointer size = car(args);
  s7_int len;

  if ((is_pair(cdr(args))) ||
      (!s7_is_integer(size)))
    {
      s7_pointer init;
      if (is_pair(cdr(args)))
	{
	  init = cadr(args);
	  if (!s7_is_integer(init))
	    return(method_or_bust(sc, init, sc->make_int_vector_symbol, args, sc->type_names[T_INTEGER], 2));
	}
      else init = Int_Zero;
      if (s7_is_integer(size))
	len = s7_integer_clamped_if_gmp(sc, size);
      else
	{
	  if (!is_pair(size))
	    return(method_or_bust(sc, size, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1));
	  len = multivector_length(sc, size, sc->make_int_vector_symbol);
	}
      {
	const s7_pointer vect = make_vector_1(sc, len, Vector_Not_Filled, T_INT_VECTOR);
	int_vector_fill(vect, s7_integer_clamped_if_gmp(sc, init));
	if (!s7_is_integer(size))
	  return(make_multivector(sc, vect, size));
	add_vector(sc, vect);
	return(vect);
      }}
  len = s7_integer_clamped_if_gmp(sc, size);
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_int_vector_symbol, Int_One, size, It_Is_Negative_String);
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-int-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 79),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
  {
    block_t *arr = mallocate_vector(sc, len * sizeof(s7_int));
    s7_pointer vect;
    new_cell(sc, vect, T_INT_VECTOR | T_Safe_Procedure);
    vector_length(vect) = len;
    vector_block(vect) = arr;
    int_vector_ints(vect) = (s7_int *)block_data(arr);
    if (len > 0)
      {
	if (Step_8(len))
	  memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int));
	else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int));
      }
    vector_set_dimension_info(vect, NULL);
    vector_getter(vect) = int_vector_getter;
    vector_setter(vect) = int_vector_setter;
    add_vector(sc, vect);
    return(vect);
  }
}

static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init)
{
  s7_pointer vec = make_vector_1(sc, len, Vector_Not_Filled, T_INT_VECTOR);
  int_vector_fill(vec, init);
  add_vector(sc, vec);
  return(vec);
}


/* -------------------------------- make-byte-vector -------------------------------- */
static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte."
  #define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, \
                               s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol)
  s7_int len = 0, ib = 0;
  const s7_pointer size = car(args);
  s7_pointer init;

  if (!is_pair(size))
    {
      if (!s7_is_integer(size))
	return(method_or_bust(sc, size, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1));
      len = s7_integer_clamped_if_gmp(sc, size);
      if (len < 0)
	out_of_range_error_nr(sc, sc->make_byte_vector_symbol, Int_One, size, It_Is_Negative_String);
      if (len > sc->max_vector_length)
	error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
    }
  if (is_pair(cdr(args)))
    {
      init = cadr(args);
      if (!s7_is_integer(init))
	return(method_or_bust(sc, init, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 2));
      ib = s7_integer_clamped_if_gmp(sc, init);
      if ((ib < 0) || (ib > 255))
	wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, An_Unsigned_Byte_String);
    }
  else init = Int_Zero;

 if (!s7_is_integer(size))
   return(g_make_vector_1(sc, set_plist_2(sc, size, init), sc->make_byte_vector_symbol));
 {
   const s7_pointer result = make_simple_byte_vector(sc, len);
   if (len > 0) /* make-byte-vector 2) should return #u(0 0) so we always need to fill */
     local_memset((void *)(byte_vector_bytes(result)), ib, len);
   return(result);
 }
}

static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init)
{
  if (len < 0)
    out_of_range_error_nr(sc, sc->make_byte_vector_symbol, Int_One, wrap_integer(sc, len), It_Is_Negative_String);
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80),
			 wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
  if ((init < 0) || (init > 255))
    wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), An_Unsigned_Byte_String);
  {
    const s7_pointer bvect = make_simple_byte_vector(sc, len);
    if (len > 0)
      local_memset((void *)(byte_vector_bytes(bvect)), init, len);
    return(bvect);
  }
}


/* -------------------------------- vector? -------------------------------- */
static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_vector "(vector? obj) returns #t if obj is a vector"
  #define Q_is_vector sc->pl_bt
  check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args);
}


/* -------------------------------- vector-rank -------------------------------- */
s7_int s7_vector_rank(s7_pointer vec) {return((s7_int)(vector_rank(vec)));}

static s7_pointer g_vector_rank(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect"
  #define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
  s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(sole_arg_method_or_bust(sc, vec, sc->vector_rank_symbol, args, sc->type_names[T_VECTOR]));
  return(make_integer(sc, vector_rank(vec)));
}


/* -------------------------------- vector-dimension -------------------------------- */
static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)"
  #define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol)
  const s7_pointer vec = car(args);
  const s7_pointer dim = cadr(args);
  s7_int n;
  if (!is_any_vector(vec))
    return(method_or_bust(sc, vec, sc->vector_dimension_symbol, args, sc->type_names[T_VECTOR], 1));
  if (!s7_is_integer(dim))
    return(method_or_bust(sc, vec, sc->vector_dimension_symbol, args, sc->type_names[T_INTEGER], 2));
  n = s7_integer_clamped_if_gmp(sc, dim);
  if (n < 0)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_2(sc, wrap_string(sc, "vector-dimension second argument is negative: ~S", 48), dim));
  if (n >= vector_rank(vec))
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "vector-dimension second argument, ~S, should be less than the vector rank, ~D", 77),
			 dim, wrap_integer(sc, vector_rank(vec))));
  if (vector_has_dimension_info(vec))
    return(make_integer(sc, vector_dimension(vec, n)));
  return(make_integer(sc, vector_length(vec)));
}


/* -------------------------------- vector-dimensions -------------------------------- */
static s7_pointer g_vector_dimensions(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions"
  #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol)

  const s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(sole_arg_method_or_bust(sc, vec, sc->vector_dimensions_symbol, args, sc->type_names[T_VECTOR]));
  if (vector_rank(vec) == 1)
    return(list_1(sc, make_integer(sc, vector_length(vec))));
  begin_temp(sc->y, sc->nil);
  for (s7_int i = vector_ndims(vec) - 1; i >= 0; i--)
    sc->y = cons(sc, make_integer(sc, vector_dimension(vec, i)), sc->y);
  return_with_end_temp(sc->y);
}


/* -------------------------------- vector-typer -------------------------------- */
static s7_pointer g_vector_typer(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_typer "(vector-typer vect) returns the vector's element type checking function"
  #define Q_vector_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_vector_symbol)

  const s7_pointer vec = car(args);
  if (!is_any_vector(vec))
    return(sole_arg_method_or_bust(sc, vec, sc->vector_typer_symbol, args, sc->type_names[T_VECTOR]));
  if (is_typed_t_vector(vec)) return(typed_vector_typer(vec));
  if (is_float_vector(vec)) return(global_value(sc->is_float_symbol));
  if (is_int_vector(vec)) return(global_value(sc->is_integer_symbol));
  if (is_byte_vector(vec)) return(global_value(sc->is_byte_symbol));
  if (is_complex_vector(vec)) return(global_value(sc->is_number_symbol));
  return(sc->F);
}

static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args), typer = cadr(args);

  if (!is_any_vector(vec))
    wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, vec, sc->type_names[T_VECTOR]);
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its vector-typer can't be set!", 49), vec));
  if (!is_t_vector(vec))
    {
      if (((is_int_vector(vec)) && (typer != global_value(sc->is_integer_symbol))) ||
	  ((is_float_vector(vec)) && (typer != global_value(sc->is_float_symbol))) ||
	  ((is_complex_vector(vec)) && (typer != global_value(sc->is_number_symbol))) ||
	  ((is_byte_vector(vec)) && (typer != global_value(sc->is_byte_symbol))))
	error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), vec, typer));
      return(typer);
    }
  if (is_boolean(typer))
    {
      if (is_typed_vector(vec))
	{
	  typed_vector_set_typer(vec, sc->F);
	  clear_typed_vector(vec);
	  clear_has_simple_elements(vec); /* 15-Oct-23 */
	}}
  else
    {
      if (is_c_function(typer))
	check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); /* this is just error checking */
      else
	{
	  s7_pointer typer_name;
	  if (!is_any_closure(typer))
	    wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41));
	  typer_name = find_typer(sc, typer);
	  if (!is_symbol(typer_name))
	    error_nr(sc, sc->wrong_type_arg_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);
}


/* -------------------------------- multivector -------------------------------- */
#define Multivector_Too_Many_Elements -1
#define Multivector_Not_Enough_Elements -2

static int32_t traverse_vector_data(s7_scheme *sc, s7_pointer vec, s7_int flat_ref, s7_int dimension, s7_int dimensions, s7_int *sizes, s7_pointer lst)
{
  /* we're filling vec, we're currently looking for element flat_ref,
   *   we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data
   *   #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12)))
   */
  s7_pointer vals = lst;
  for (s7_int i = 0; i < sizes[dimension]; i++, vals = cdr(vals))
    {
      if (!is_pair(vals))
	return(Multivector_Not_Enough_Elements);
      if (dimension == (dimensions - 1))
	vector_setter(vec)(sc, vec, flat_ref++, car(vals));
      else
	{
	  flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(vals));
	  if (flat_ref < 0) return(flat_ref);
	}}
  return((is_null(vals)) ? flat_ref : Multivector_Too_Many_Elements);
}

static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_pointer list)
{
  s7_pointer p = list, result = term;
  while (true)
    {
      s7_pointer q;
      Loop_4(if (is_null(p)) return(result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because Loop_4 is itself a do loop */
    }
  return(result);
}

static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list)
{
  return(reverse_in_place_unchecked(sc, sc->nil, list));
}

static no_return void multivector_error_nr(s7_scheme *sc, const char *message, s7_pointer data)
{
  error_nr(sc, sc->read_error_symbol,
	   set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31),
		       s7_make_string_wrapper(sc, message), data));
}

static s7_pointer multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  /* get the dimension bounds from data, make the new vector, fill it from data
   * dims needs to be s7_int so we can at least give correct error messages.
   */
  s7_pointer vals = data;
  s7_int *sizes;

  /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1
   * (#2d((1 2 3) (4 5 6)) 1 1) -> 5
   * (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7
   * #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc
   * but a special case: #nd() is an n-dimensional empty vector
   */

  if (dims <= 0)      /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims)));

  if ((s7_Debugging) && (dims > sc->max_vector_dimensions)) fprintf(stderr, "%s[%d]: can't happen: %" ld64 " > %" ld64 "\n", __func__, __LINE__, dims, sc->max_vector_dimensions);
  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);
	}}
  {
    const s7_pointer vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w)));
    const s7_int vec_loc = gc_protect_1(sc, vec);
    s7_int err;
    sc->w = sc->unused;
    /* now fill the vector checking that all the lists match */
    err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data);
    free(sizes);
    s7_gc_unprotect_at(sc, vec_loc);
    if (err < 0)
      multivector_error_nr(sc, (err == Multivector_Too_Many_Elements) ? "found too many elements" : "not enough elements found", data);
    return(vec);
  }
}

static s7_pointer int_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  s7_pointer *src;
  s7_int len;
  sc->value = multivector(sc, dims, data);
  src = (s7_pointer *)vector_elements(sc->value);
  len = vector_length(sc->value);
  for (s7_int i = 0; i < len; i++)
    if (!is_t_integer(src[i]))
      wrong_type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]);
  sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), Int_Zero), sc->make_int_vector_symbol);
  return(s7_copy_1(sc, sc->int_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
}

static s7_pointer byte_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  s7_pointer *src;
  s7_int len;
  sc->value = multivector(sc, dims, data);
  src = (s7_pointer *)vector_elements(sc->value);
  len = vector_length(sc->value);
  for (s7_int i = 0; i < len; i++)
    if (!is_byte(src[i]))
      wrong_type_error_nr(sc, wrap_string(sc, "#u(...)", 7), i + 1, src[i], wrap_string(sc, "a byte", 6));
  sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), Int_Zero), sc->make_byte_vector_symbol);
  return(s7_copy_1(sc, sc->byte_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
}

static s7_pointer float_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  s7_pointer *src;
  s7_int len;
  sc->value = multivector(sc, dims, data);
  src = (s7_pointer *)vector_elements(sc->value);
  len = vector_length(sc->value);
  for (s7_int i = 0; i < len; i++)
    if (!is_real(src[i]))
      wrong_type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]);
  sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), Real_Zero), sc->make_float_vector_symbol);
  return(s7_copy_1(sc, sc->float_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
}

static s7_pointer complex_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  s7_pointer *src;
  s7_int len;
  sc->value = multivector(sc, dims, data);
  src = (s7_pointer *)vector_elements(sc->value);
  len = vector_length(sc->value);
  for (s7_int i = 0; i < len; i++)
    if (!is_number(src[i]))
      wrong_type_error_nr(sc, wrap_string(sc, "#c(...)", 7), i + 1, src[i], sc->type_names[T_COMPLEX]);
  sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), Real_Zero), sc->make_complex_vector_symbol);
  return(s7_copy_1(sc, sc->complex_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
}

static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vec)
{
  const s7_int len = vector_length(old_vec);
  s7_pointer new_vec;

  if (is_t_vector(old_vec))
    {
      const s7_pointer *src = (const s7_pointer *)vector_elements(old_vec);
      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 = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), Real_Zero), sc->make_float_vector_symbol);
      else new_vec = make_simple_float_vector(sc, len);
      dst = (s7_double *)float_vector_floats(new_vec);
      for (s7_int i = len; i > 0; i--) *dst++ = *src++;  /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */
      return(new_vec);
    }
  if (is_int_vector(old_vec))
    {
      const s7_int *src = (s7_int *)int_vector_ints(old_vec);
      s7_int *dst;
      if (vector_rank(old_vec) > 1)
	new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), Int_Zero), sc->make_int_vector_symbol);
      else new_vec = make_simple_int_vector(sc, len);
      dst = (s7_int *)int_vector_ints(new_vec);
      for (s7_int i = len; i > 0; i--) *dst++ = *src++;
      return(new_vec);
    }
  if (is_byte_vector(old_vec))
    {
      const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vec);
      uint8_t *dst;
      if (vector_rank(old_vec) > 1)
	new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), Int_Zero), sc->make_byte_vector_symbol);
      else new_vec = make_simple_byte_vector(sc, len);
      dst = (uint8_t *)byte_vector_bytes(new_vec);
      for (s7_int i = len; i > 0; i--) *dst++ = *src++;
      return(new_vec);
    }
  if (is_complex_vector(old_vec))
    {
      const s7_complex *src = (s7_complex *)complex_vector_complexes(old_vec);
      s7_complex *dst;
      if (vector_rank(old_vec) > 1)
	new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), Real_Zero), sc->make_complex_vector_symbol);
      else new_vec = make_simple_complex_vector(sc, len);
      dst = (s7_complex *)complex_vector_complexes(new_vec);
      for (s7_int i = len; i > 0; i--) *dst++ = *src++;
      return(new_vec);
    }
  return(NULL);
}

s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vec) {return(s7_vector_copy_1(sc, old_vec));} /* repeated for Vectorized */

static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ)
{
  const s7_pointer vec = car(args);
  s7_pointer index;
  s7_int ind;

  if (type(vec) != typ)
    return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1));

  if (vector_rank(vec) == 1)
    {
      index = cadr(args);
      if (!s7_is_integer(index))
	return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2));
      ind = s7_integer_clamped_if_gmp(sc, index);
      if ((ind < 0) || (ind >= vector_length(vec)))
	sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      if (!is_null(cddr(args)))
	out_of_range_error_nr(sc, caller, Int_Two, cdr(args), Too_Many_Indices_String);
    }
  else
    {
      s7_int i;
      s7_pointer indices;
      ind = 0;
      for (indices = cdr(args), i = 0; (is_pair(indices)) && (i < vector_ndims(vec)); indices = cdr(indices), i++)
	{
	  s7_int n;
	  index = car(indices);
	  if (!s7_is_integer(index))
	    return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2));
	  n = s7_integer_clamped_if_gmp(sc, index);
	  if ((n < 0) || (n >= vector_dimension(vec, i)))
	    out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	  ind += n * vector_offset(vec, i);
	}
      if (is_not_null(indices))
	out_of_range_error_nr(sc, caller, Int_Two, cdr(args), Too_Many_Indices_String);

      /* if not enough indices, return a subvector covering whatever is left */
      if (i < vector_ndims(vec))
	return(subvector(sc, vec, i, ind));
    }
  if (typ == T_FLOAT_VECTOR)
    return(make_real(sc, float_vector(vec, ind)));
  if (typ == T_COMPLEX_VECTOR)
    return(make_complex(sc, creal(complex_vector(vec, ind)), cimag(complex_vector(vec, ind))));
  return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(vec, ind)) : small_int(byte_vector(vec, ind)));
}

static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ)
{
  const s7_pointer vec = car(args);
  s7_pointer val, index;
  s7_int ind;

  if (type(vec) != typ)
    return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, caller, vec));

  if (vector_rank(vec) > 1)
    {
      s7_int i;
      s7_pointer indices;
      ind = 0;
      for (indices = cdr(args), i = 0; (is_pair(cdr(indices))) && (i < vector_ndims(vec)); indices = cdr(indices), i++)
	{
	  s7_int n;
	  index = car(indices);
	  if (!s7_is_integer(index))
	    return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2));
	  n = s7_integer_clamped_if_gmp(sc, index);
	  if ((n < 0) || (n >= vector_dimension(vec, i)))
	    out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	  ind += n * vector_offset(vec, i);
	}
      if (is_not_null(cdr(indices)))
	error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args));
      if (i != vector_ndims(vec))
	error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args));
      val = car(indices);
    }
  else
    {
      const s7_pointer indices = cdr(args);
      if (is_null(indices))
	error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args));
      /* from (set! (v) val) after optimization into op_set_opsq_a which is completely confused -- set! gets v's setter (float-vector-set!) */
      index = car(indices);
      if (!s7_is_integer(index))
	return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2));
      ind = s7_integer_clamped_if_gmp(sc, index);
      if ((ind < 0) || (ind >= vector_length(vec)))
	out_of_range_error_nr(sc, caller, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      if (is_not_null(cddr(indices)))
	error_nr(sc, sc->wrong_number_of_args_symbol,
		 set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args));
      val = cadr(indices);
    }

  if (typ == T_FLOAT_VECTOR)
    {
      if (!is_real(val))
	return(method_or_bust(sc, val, caller, args, sc->type_names[T_REAL], 3));
      float_vector(vec, ind) = s7_real(val);
    }
  else
    if (typ == T_INT_VECTOR)
      {
	if (!s7_is_integer(val))
	  return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3));
	int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val);
      }
    else
      if (typ == T_BYTE_VECTOR)
	{
	  if (!is_byte(val))
	    return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3));
	  byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val);
	}
      else
	{
	  if (!is_number(val))
	    return(method_or_bust(sc, val, caller, args, sc->type_names[T_COMPLEX], 3));
	  complex_vector(vec, ind) = s7_to_c_complex(val);
	}
  return(val);
}


/* -------------------------------- complex-vector-ref -------------------------------- */
static s7_pointer g_complex_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_complex_vector_ref "(complex-vector-ref v ...) returns an element of the complex-vector v."
  #define Q_complex_vector_ref s7_make_circular_signature(sc, 2, 3, \
                               s7_make_signature(sc, 2, sc->is_complex_symbol, sc->is_complex_vector_symbol), \
                               sc->is_complex_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR));
}

static s7_pointer complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index)
{
  if (!is_complex_vector(vec))
    return(method_or_bust_pp(sc, vec, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_COMPLEX_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_ref(sc, set_plist_2(sc, vec, index), sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR));
  if (!s7_is_integer(index))
    return(method_or_bust_pp(sc, index, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2));
  {
    const 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)));
  }
}

static s7_pointer g_cv_ref_2(s7_scheme *sc, s7_pointer args) {return(complex_vector_ref_p_pp(sc, car(args), cadr(args)));}

static s7_pointer complex_vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index))));
  return(c_complex_to_s7(sc, complex_vector(vec, index)));
}

static s7_pointer complex_vector_ref_p_pi_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  s7_complex z;
  if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index))));
  z = complex_vector(vec, index);
  return(wrap_complex(sc, creal(z), cimag(z)));
}

static s7_pointer complex_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(c_complex_to_s7(sc, complex_vector(vec, index)));}

static s7_pointer complex_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->cv_ref_2 : func);
}


/* -------------------------------- complex-vector-set! -------------------------------- */
static s7_pointer g_complex_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_complex_vector_set "(complex-vector-set! v i ... value) sets the i-th element of the complex-vector v to value."
  #define Q_complex_vector_set s7_make_circular_signature(sc, 3, 4, \
                               sc->is_complex_symbol, sc->is_complex_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_number_at_end_symbol)
  return(univect_set(sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR));
}


static s7_pointer complex_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((!is_complex_vector(vec)) || (!is_number(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR));
  complex_vector(vec, index) = s7_to_c_complex(value);
  return(value);
}

static s7_pointer complex_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((index >= 0) && (index < vector_length(vec)))
    complex_vector(vec, index) = s7_to_c_complex(value);
  else out_of_range_error_nr(sc, sc->complex_vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(value);
}

static s7_pointer complex_vector_set_p_pip_direct(s7_scheme *unused_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(method_or_bust_ppp(sc, vec, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->complex_vector_set_symbol, vec));
  if (!s7_is_integer(index))
    return(method_or_bust_ppp(sc, index, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 2));
  if (!s7_is_number(value))
    return(method_or_bust_ppp(sc, value, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX], 3));
  {
    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);
}

static s7_pointer g_cv_set_3(s7_scheme *sc, s7_pointer args) {return(complex_vector_set_p_ppp(sc, car(args), cadr(args), caddr(args)));}
/* static s7_pointer g_cv_set_3_nr(s7_scheme *sc, s7_pointer args) {return(complex_vector_set_p_ppp_nr(sc, car(args), cadr(args), caddr(args)));} */

static s7_pointer complex_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 3) ? sc->cv_set_3 : func);
}


/* -------------------------------- float-vector-ref -------------------------------- */
static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v."
  #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, \
                               s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), \
                               sc->is_float_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
}

static /* inline */ s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index)
{
  if (!is_float_vector(vec))
    return(method_or_bust_pp(sc, vec, sc->float_vector_ref_symbol, vec, index, sc->type_names[T_FLOAT_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_ref(sc, set_plist_2(sc, vec, index), sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
  if (!s7_is_integer(index))
    return(method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2));
  {
    const 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 g_fv_ref_2(s7_scheme *sc, s7_pointer args) {return(float_vector_ref_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_fv_ref_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer fv = car(args);
  s7_pointer index;
  s7_int ind1, ind2;
  if (!is_float_vector(fv))
    return(method_or_bust(sc, fv, sc->float_vector_ref_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1));
  if (vector_rank(fv) != 2)
    return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
  ind1 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Two, index, (ind1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  index = caddr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
  ind2 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Three, index, (ind2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  ind1 = ind1 * vector_offset(fv, 0) + ind2;
  return(make_real(sc, float_vector(fv, ind1)));
}

static inline s7_int ref_check_index(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  /* according to callgrind, it is faster to split out the bounds check */
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(index);
}

static s7_pointer float_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((!is_float_vector(vec)) || (!is_real(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->float_vector_set_symbol, T_FLOAT_VECTOR));
  float_vector(vec, index) = s7_real(value);
  return(value);
}

static inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) {return(float_vector(vec, ref_check_index(sc, vec, index)));}
static s7_double float_vector_ref_d_7pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(float_vector(vec, index));}
static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_real(sc, float_vector(vec, index)));}
static s7_pointer float_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_real(sc, float_vector(vec, index)));}

static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(float_vector(vec, i2 + (i1 * vector_offset(vec, 0))));
}

static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i3 < 0) || (i3 >= vector_dimension(vec, 2)))
    out_of_range_error_nr(sc, sc->float_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(float_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0))));
}

static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : func));
}


/* -------------------------------- float-vector-set! -------------------------------- */
static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value."
  #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, \
                               sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol)
  return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
}

static s7_pointer g_fv_set_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer fv = car(args);
  s7_pointer index;
  if (!is_float_vector(fv))
    return(method_or_bust(sc, fv, sc->float_vector_set_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1));
  if (vector_rank(fv) != 1)
    return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
  if (is_immutable_vector(fv))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->float_vector_set_symbol, fv));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->float_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
  {
    const s7_int ind = s7_integer_clamped_if_gmp(sc, index);
    const s7_pointer value = caddr(args);
    if ((ind < 0) || (ind >= vector_length(fv)))
      out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
    if (!is_real(value))
      return(method_or_bust(sc, value, sc->float_vector_set_symbol, args, sc->type_names[T_REAL], 3));
    float_vector(fv, ind) = s7_real(value);
    return(value);
  }
}

static s7_pointer g_fv_set_unchecked(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer fv = car(args), value = caddr(args);
  s7_int ind;
  if (!is_real(value))
    wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, value, sc->type_names[T_REAL]);
  if (is_immutable_vector(fv))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->float_vector_set_symbol, fv));
  ind = s7_integer_clamped_if_gmp(sc, cadr(args));
  float_vector(fv, ind) = s7_real(value);
  return(value);
}

static bool find_matching_ref(s7_scheme *sc, const s7_pointer getter, s7_pointer expr)
{
  /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */
  const s7_pointer sym = cadr(expr), ind = caddr(expr);
  if ((is_symbol(sym)) && (!is_pair(ind)))
    {
      const s7_pointer val = cadddr(expr);
      if (is_optimized(val)) /* includes is_pair */
	for (s7_pointer p = val; is_pair(p); p = cdr(p))
	  if (is_pair(car(p)))
	    {
	      const s7_pointer ref = car(p);
	      if (((car(ref) == getter) &&             /* (getter sym ind) */
		   (is_proper_list_2(sc, cdr(ref))) &&
		   (cadr(ref) == sym) &&
		   (caddr(ref) == ind)) ||
		  ((car(ref) == sym) &&                /* (sym ind) */
		   (is_proper_list_1(sc, cdr(ref))) &&
		   (cadr(ref) == ind)))
		return(true);                          /* else keep looking */
	    }}
  return(false);
}

static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 3)
    return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3);
  return(func);
}

static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, index) = x; return(x);}

static s7_int set_check_index(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(index);
}

static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, set_check_index(sc, vec, index)) = x; return(x);}

static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_double x)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  float_vector(vec, i2 + (i1 * vector_offset(vec, 0))) = x;
  return(x);
}

static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3, s7_double x)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i3 < 0) || (i3 >= vector_dimension(vec, 2)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  float_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0))) = x;
  return(x);
}

static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  float_vector(vec, index) = real_to_double(sc, value, "float-vector-set!");
  return(value);
}

static s7_pointer float_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val)
{
  s7_int index;
  if (!is_float_vector(vec))
    return(method_or_bust_ppp(sc, vec, sc->float_vector_set_symbol, vec, ind, val, sc->type_names[T_FLOAT_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_set(sc, set_plist_3(sc, vec, ind, val), sc->float_vector_set_symbol, T_FLOAT_VECTOR));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->float_vector_set_symbol, vec));
  if (!s7_is_integer(ind))
    return(g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
  index = s7_integer_clamped_if_gmp(sc, ind);
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->float_vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if (!is_real(val))
    wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, val, sc->type_names[T_REAL]);
  float_vector(vec, index) = (is_t_real(val)) ? real(val) : s7_real(val);
  return(val);
}

/* -------------------------------- int-vector-ref -------------------------------- */
static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v."
  #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, \
                             s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), \
                             sc->is_int_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
}

static s7_int int_vector_ref_i_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(int_vector(vec, index));}
static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_integer(sc, int_vector(vec, index)));}
static s7_pointer int_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_integer(sc, int_vector(vec, index)));}

static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(int_vector(vec, index));
}

static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(int_vector(vec, i2 + (i1 * vector_offset(vec, 0))));
}

static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i3 < 0) || (i3 >= vector_dimension(vec, 2)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(int_vector(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0))));
}

static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index)
{
  s7_int ind;
  if (!is_int_vector(vec))
    return(method_or_bust_pp(sc, vec, sc->int_vector_ref_symbol, vec, index, sc->type_names[T_INT_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_ref(sc, set_plist_2(sc, vec, index), sc->int_vector_ref_symbol, T_INT_VECTOR));
  if (!s7_is_integer(index))
    return(method_or_bust_pp(sc, index, sc->int_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if ((ind < 0) || (ind >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(make_integer(sc, int_vector(vec, ind)));
}

static s7_pointer g_iv_ref_2(s7_scheme *sc, s7_pointer args) {return(int_vector_ref_p_pp(sc, car(args), cadr(args)));}

static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer ivec = car(args);
  s7_pointer index;
  s7_int ind1, ind2;
  if (!is_int_vector(ivec))
    return(method_or_bust(sc, ivec, sc->int_vector_ref_symbol, args, sc->type_names[T_INT_VECTOR], 1));
  if (vector_rank(ivec) != 2)
    return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
  ind1 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind1 < 0) || (ind1 >= vector_dimension(ivec, 0)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Two, index, (ind1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  index = caddr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
  ind2 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind2 < 0) || (ind2 >= vector_dimension(ivec, 1)))
    out_of_range_error_nr(sc, sc->int_vector_ref_symbol, Int_Three, index, (ind2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  ind1 = ind1 * vector_offset(ivec, 0) + ind2;
  return(make_integer(sc, int_vector(ivec, ind1)));
}

static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : func));
}


/* -------------------------------- int-vector-set! -------------------------------- */
static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value."
  #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
  return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR));
}

static s7_int int_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_int x) {int_vector(vec, index) = x; return(x);}

static s7_pointer int_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  if ((!is_int_vector(vec)) || (!is_t_integer(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec)))
    return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->int_vector_set_symbol, T_INT_VECTOR));
  int_vector(vec, index) = integer(value);
  return(value);
}

static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value)
{
  int_vector(vec, index) = s7_integer_clamped_if_gmp(sc, value);
  return(value);
}

static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index, s7_int x)
{
  if ((index < 0) || (index >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  int_vector(vec, index) = x;
  return(x);
}

static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3)
{
  if ((i1 < 0) || (i1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, wrap_integer(sc, i1), (i1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((i2 < 0) || (i2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Three, wrap_integer(sc, i2), (i2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  int_vector(vec, i2 + (i1 * vector_offset(vec, 0))) = i3;
  return(i3);
}

static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value)
{
  if ((is_int_vector(vec)) && (vector_rank(vec) == 1) && (!is_immutable_vector(vec)) &&
      (is_t_integer(index)) && (is_t_integer(value)))
    {
      s7_int i = integer(index);
      if ((i < 0) || (i >= vector_length(vec)))
	out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, index, (i < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
      int_vector(vec, i) = integer(value);
    }
  else
    {
      if (!is_int_vector(vec))
	return(method_or_bust_ppp(sc, vec, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INT_VECTOR], 1));
      if (vector_rank(vec) != 1)
	return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->int_vector_set_symbol, T_INT_VECTOR));
      if (is_immutable_vector(vec))
	immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->int_vector_set_symbol, vec));
      /* (int-vector-set!  #i() `(x 1) (abs x)) in a do loop in a function... */
      if (!s7_is_integer(index))
	return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 2));
      if (!s7_is_integer(value))
	return(method_or_bust_ppp(sc, value, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 3));
#if With_Gmp
      {
	const s7_int i = s7_integer_clamped_if_gmp(sc, index);
	if ((i < 0) || (i >= vector_length(vec)))
	  out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, index, (i < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, value);
      }
#else
      if (s7_Debugging) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__);
#endif
    }
  return(value);
}

static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args);
  s7_pointer index;
  s7_int ind;
  if (!is_int_vector(vec))
    return(method_or_bust(sc, vec, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->int_vector_set_symbol, vec));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if ((ind < 0) || (ind >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  {
    const s7_pointer value = caddr(args);
    if (!s7_is_integer(value))
      return(method_or_bust(sc, value, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 3));
    int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, value);
    return(value);
  }
}

static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if (args == 3)
    {
      s7_pointer arg3 = cadddr(expr);
      if ((is_pair(arg3)) && (has_fn(arg3)))
	{
	  if (fn_proc(arg3) == g_logand_2) set_fn_direct(arg3, g_logand_2_wrapped);
	  if (fn_proc(arg3) == g_logior_2) set_fn_direct(arg3, g_logior_2_wrapped);
#if !With_Gmp
	  if (fn_proc(arg3) == g_lognot) set_fn_direct(arg3, g_lognot_wrapped);
#endif
	}
      return(sc->iv_set_3);
    }
  return(func);
}


/* -------------------------------- byte-vector-ref -------------------------------- */
static s7_pointer g_byte_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect"
  #define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, \
                              s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), \
                              sc->is_byte_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
}

static s7_int byte_vector_ref_i_7pi(s7_scheme *sc, s7_pointer vec, s7_int index)
{
  if ((index < 0) || (index >= byte_vector_length(vec)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return((s7_int)((byte_vector(vec, index))));
}

static s7_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2)
{
  if ((index1 < 0) || (index1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Two, wrap_integer(sc, index1), (index1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((index2 < 0) || (index2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Three, wrap_integer(sc, index2), (index2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return((s7_int)byte_vector(vec, index2 + (index1 * vector_offset(vec, 0))));
}

static s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(small_int((byte_vector(vec, index))));}
static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index)    {return(byte_vector(vec, index));}

static s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args);
  s7_pointer index;
  s7_int ind;
  if (!is_byte_vector(vec))
    return(method_or_bust(sc, vec, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if ((ind < 0) || (ind >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  return(small_int(byte_vector(vec, ind)));
}

static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer iv = car(args);
  s7_pointer index;
  s7_int ind1, ind2;
  if (!is_byte_vector(iv))
    return(method_or_bust(sc, iv, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
  if (vector_rank(iv) != 2)
    return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
  ind1 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Two, index, (ind1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  index = caddr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
  ind2 = s7_integer_clamped_if_gmp(sc, index);
  if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1)))
    out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, Int_Three, index, (ind2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  ind1 = ind1 * vector_offset(iv, 0) + ind2;
  return(small_int(byte_vector(iv, ind1)));
}

static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : func));
}


/* -------------------------------- byte-vector-set -------------------------------- */
static s7_pointer g_byte_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte"
  #define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol)
  return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
}

static s7_int byte_vector_set_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index, s7_int byte)
{
  if (!is_byte_vector(vec))
    wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, vec, A_Byte_Vector_String);
  if ((byte < 0) || (byte > 255))
    wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, byte), An_Unsigned_Byte_String);
  if ((index < 0) || (index >= byte_vector_length(vec)))
    out_of_range_error_nr(sc, sc->byte_vector_set_symbol, Int_Two, wrap_integer(sc, index), (index < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  byte_vector(vec, index) = (uint8_t)byte;
  return(byte);
}

static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_int byte)
{
  byte_vector(vec, index) = (uint8_t)byte;
  return(byte);
}

static s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer byte)
{
  byte_vector(vec, index) = (uint8_t)s7_integer(byte);
  return(byte);
}

static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2, s7_int byte)
{
  if ((byte < 0) || (byte > 255))
    wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, byte), An_Unsigned_Byte_String);
  if ((index1 < 0) || (index1 >= vector_dimension(vec, 0)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Two, wrap_integer(sc, index1), (index1 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  if ((index2 < 0) || (index2 >= vector_dimension(vec, 1)))
    out_of_range_error_nr(sc, sc->int_vector_set_symbol, Int_Three, wrap_integer(sc, index2), (index2 < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  byte_vector(vec, index2 + (index1 * vector_offset(vec, 0))) = byte;
  return(byte);
}

static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer vec = car(args);
  s7_pointer index, value;
  s7_int ind;
  if (!is_byte_vector(vec))
    return(method_or_bust(sc, vec, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
  if (vector_rank(vec) != 1)
    return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->byte_vector_set_symbol, vec));
  index = cadr(args);
  if (!s7_is_integer(index))
    return(method_or_bust(sc, index, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
  ind = s7_integer_clamped_if_gmp(sc, index);
  if ((ind < 0) || (ind >= vector_length(vec)))
    out_of_range_error_nr(sc, sc->byte_vector_set_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
  value = caddr(args);
  if (!s7_is_integer(value))
    return(method_or_bust(sc, value, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 3));
  {
    const s7_int byte = s7_integer_clamped_if_gmp(sc, value);
    if ((byte < 0) || (byte > 255))
      wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, An_Unsigned_Byte_String);
    byte_vector(vec, ind) = (uint8_t)byte;
  }
  return(value);
}

static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 3) ? sc->bv_set_3 : func);
}


/* -------------------------------------------------------------------------------- */
static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
{
  const s7_pointer func = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */
  if ((func == opt1_cfunc(x)) ||
      ((func) && (is_any_c_function(func)) && (c_function_class(func) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, func))))
    return(true);
  sc->last_function = func;
  return(false);
}

static bool cl_function_is_ok(s7_scheme *sc, s7_pointer x)
{
  sc->last_function = lookup_unexamined(sc, car(x));
  return(sc->last_function == opt1_cfunc(x));
}

static bool arglist_has_rest(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    if (car(p) == sc->rest_keyword)
      return(true);
  return(!is_null(p));
}


/* -------------------------------- sort! -------------------------------- */
static int32_t dbl_less(const void *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);
}

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 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 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 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);
}

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);
}

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 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));}

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 int32_t chr_greater_2(const void *c1, const void *c2) {return(-chr_less_2(c1, c2));}

#if MS_Windows || defined(__APPLE__) || defined(__FreeBSD__)
struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);};

static int32_t sort_r_arg_swap(void *s, const void *aa, const void *bb)
{
  struct sort_r_data *ss = (struct sort_r_data*)s;
  return (ss->compar)(aa, bb, ss->arg);
}
#endif

/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows
 *   this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code.
 *
 *   qsort_r allocates an internal array (msort.c line 221) if the original array is > 1024 elements (or whatever),
 *   then calls the sort comparison function in a loop, after which it frees its temporary array.  This is an unavoidable
 *   memory leak if the comparison function calls s7_error (or its equivalent) which longjmps to the nearest catch
 *   (or, sigh, segfaults if none exists).  I can't see any way to hack around this memory leak -- don't raise
 *   an error in the sort function!
 */
static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*compar)(const void *, const void *, void *), void *arg)
{
#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */
  qsort_r(base, nmemb, size, compar, arg);
#else
#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */
  struct sort_r_data tmp = {arg, compar};
  qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap);
#else
#if MS_Windows
  struct sort_r_data tmp = {arg, compar};
  qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp);
#else
    /* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */
  if (nmemb > 1)
    {
      uint8_t *array = (uint8_t *)base;
      const uint8_t *after = (uint8_t *)(nmemb * size + array);
      size_t h, t;
      nmemb /= 4;
      h = nmemb + 1;
      for (t = 1; nmemb != 0; nmemb /= 4)
	t *= 2;
      do {
	const size_t bytes = h * size;
	uint8_t *i = (uint8_t *)(array + bytes);
	uint8_t *k;
	do {
	  uint8_t *j = (uint8_t *)(i - bytes);
	  if (compar(j, i, arg) > 0)
	    {
	      k = i;
	      do {
		uint8_t *p1 = j, *p2 = k;
		const uint8_t *end = (uint8_t *)(p2 + size);
		do {
		  uint8_t swap = *p1;
		  *p1++ = *p2;
		  *p2++ = swap;
		} while (p2 != end);
		if (bytes + array > j)
		  break;
		k = j;
		j -= bytes;
	      } while (compar(j, k, arg) > 0);
	    }
	  i += size;
	} while (i != after);
	t /= 2;
	h = t * t - t * 3 / 2 + 1;
      } while (t != 0);
    }
#endif
#endif
#endif
}

static int32_t vector_sort(const void *v1, const void *v2, void *arg)
{
  s7_scheme *sc = (s7_scheme *)arg;
  return(((*(sc->sort_f))(sc, (*(const s7_pointer *)v1), (*(const s7_pointer *)v2))) ? -1 : 1);
}

static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */
{
  s7_pointer i1 = (*(const s7_pointer *)v1);
  s7_pointer i2 = (*(const s7_pointer *)v2);
  if ((is_t_integer(i1)) && (is_t_integer(i2)))
    return((integer(i1) < integer(i2)) ? -1 : 1);
  return((lt_b_7pp((s7_scheme *)arg, i1, i2)) ? -1 : 1);
}

static int32_t vector_car_sort(const void *v1, const void *v2, void *arg)
{
  s7_scheme *sc = (s7_scheme *)arg;
  s7_pointer a = (*(const s7_pointer *)v1);
  s7_pointer b = (*(const s7_pointer *)v2);
  a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a));
  b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b));
  return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1);
}

static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg)
{
  s7_scheme *sc = (s7_scheme *)arg;
  s7_pointer a = (*(const s7_pointer *)v1);
  s7_pointer b = (*(const s7_pointer *)v2);
  a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a));
  b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b));
  return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1);
}

static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg)
{
  s7_scheme *sc = (s7_scheme *)arg;
  slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1)); /* first slot in curlet */
  slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); /* second slot in curlet */
  return((sc->sort_fb(sc->sort_o)) ? -1 : 1);
}

static int32_t opt_bool_sort_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 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 bool_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 (bool_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));}  /* bool_expr */
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));} /* not bool_expr */

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);
}

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;

  if (is_safe_c_function(lessp))    /* (sort! a <) */
    {
      const s7_pointer sig = c_function_signature(lessp);
      if ((sig) &&
	  (is_pair(sig)) &&
	  (car(sig) != sc->is_boolean_symbol))
	wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp,
			    wrap_string(sc, "sort! function should return a boolean", 38));
      sc->sort_f = s7_b_7pp_function(lessp);
      if (sc->sort_f) sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort;
    }
  else
    {
      if (is_closure(lessp))
	{
	  const s7_pointer expr = car(closure_body(lessp));
	  const s7_pointer pars = closure_pars(lessp);

	  if ((is_pair(pars)) &&       /* closure args not a symbol, etc */
	      (!arglist_has_rest(sc, pars)))
	    {
	      if ((is_null(cdr(closure_body(lessp)))) &&
		  (is_optimized(expr)) &&
		  (is_safe_c_op(optimize_op(expr))) &&
		  /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in
		   *   optimize in this case, for some arcane reason), the optimized expression won't be hop_safe,
		   *   but that is irrelevant at this point -- if c_function_is_ok, we're good to go.
		   */
		  ((op_has_hop(expr)) ||
		   ((is_defined_global(car(expr))) &&            /* (sort! x (lambda (car y) (car x)...))! */
		    (c_function_is_ok(sc, expr)))))
		{
		  const int32_t orig_data = optimize_op(expr);
		  set_optimize_op(expr, optimize_op(expr) | 1);
		  if ((optimize_op(expr) == HOP_SAFE_C_SS) &&
		      (car(pars) == cadr(expr)) &&
		      (cadr(pars) == caddr(expr)))
		    {
		      s7_pointer lp = lookup(sc, car(expr));
		      sc->sort_f = s7_b_7pp_function(lp);
		      if (sc->sort_f)
			{
			  sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort;
			  lessp = lp;
			}}
		  else
		    if (optimize_op(expr) == HOP_SAFE_C_opSq_opSq)
		      {
			const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
			if (((car(arg1) == sc->car_symbol) || (car(arg1) == sc->cdr_symbol)) &&
			    (car(arg1) == car(arg2)) &&
			    (car(pars) == cadr(arg1)) &&
			    (cadr(pars) == cadr(arg2)))  /* expr: (< (car a) (car b)) etc */
			  {
			    s7_pointer lp = lookup(sc, car(expr));
			    sc->sort_f = s7_b_7pp_function(lp);
			    if (sc->sort_f)
			      {
				sort_func = ((car(arg1) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort);
				lessp = lp;
			      }}}
		  set_optimize_op(expr, orig_data);
		}

	      if (!sort_func)
		{
		  s7_pointer init_val;
		  const s7_pointer old_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 = 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)))
			    {
			      const 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));
		}}}}

  {
    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;
	    const 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);
		}}
	  {
	    const 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, Vector_Filled, T_VECTOR);
	    /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop,
	     *   and the GC mark process expects the vector to have an s7_pointer at every element.
	     */
	    s7_pointer *elements = s7_vector_elements(vec);
	    gc_protect_2_via_stack(sc, vec, data);
	    add_vector(sc, vec);
	    check_free_heap_size(sc, len);
	    if (is_float_vector(data))
	      for (s7_int i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i));
	    else
	      if (is_int_vector(data))
		for (s7_int i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i));
	      else for (s7_int i = 0; i < len; i++) elements[i] = c_complex_to_s7(sc, complex_vector(data, i));
	    if (sort_func)
	      {
		local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc);
		if (is_float_vector(data))
		  for (s7_int i = 0; i < len; i++)	float_vector(data, i) = real(elements[i]);
		else
		  if (is_int_vector(data))
		    for (s7_int i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]);
		  else for (s7_int i = 0; i < len; i++) complex_vector(data, i) = s7_to_c_complex(elements[i]);
		unstack_gc_protect(sc);
		return(data);
	      }
	    set_car(args, vec);
	    begin_temp(sc->y, cons(sc, data, lessp));
	    unstack_gc_protect(sc);
	    push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */
	    end_temp(sc->y);
	  }}
	break;

      case T_VECTOR:
	len = vector_length(data);
	if (len < 2)
	  return(data);
	if (sort_func)
	  {
	    s7_pointer *els = s7_vector_elements(data);
	    int32_t typ = type(els[0]);
	    if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER))
	      for (s7_int i = 1; i < len; i++)
		if (type(els[i]) != typ)
		  {
		    typ = T_FREE;
		    break;
		  }
	    if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp))
	      {
		if (typ == T_INTEGER)
		  {
		    qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? int_less_2 : int_greater_2));
		    return(data);
		  }
		if (typ == T_REAL)
		  {
		    qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? dbl_less_2 : dbl_greater_2));
		    return(data);
		  }}
	    if ((typ == T_STRING) &&
		((sc->sort_f == string_lt_b_7pp) || (sc->sort_f == string_gt_b_7pp)))
	      {
		qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == string_lt_b_7pp) ? str_less_2 : str_greater_2));
		return(data);
	      }
	    if ((typ == T_CHARACTER) &&
		((sc->sort_f == char_lt_b_7pp) || (sc->sort_f == char_gt_b_7pp)))
	      {
		qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == char_lt_b_7pp) ? chr_less_2 : chr_greater_2));
		return(data);
	      }
	    local_qsort_r((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func, (void *)sc);
	    return(data);
	  }
	break;

      default:
	return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1));
      }
    {
      s7_int n = len - 1;
      s7_int k = (n / 2) + 1;
      const s7_pointer lx = make_simple_vector(sc, (sc->safety <= No_Safety) ? 4 : 6);
      t_vector_fill(lx, sc->unused); /* make_mutable_integer below can trigger GC, so all elements of lx must be legit */
      begin_temp(sc->y, lx);
      vector_element(lx, 0) = make_mutable_integer(sc, n);
      vector_element(lx, 1) = make_mutable_integer(sc, k);
      vector_element(lx, 2) = make_mutable_integer(sc, 0);
      vector_element(lx, 3) = make_mutable_integer(sc, 0);
      if (sc->safety > No_Safety)
	{
	  vector_element(lx, 4) = make_mutable_integer(sc, 0);
	  vector_element(lx, 5) = make_integer_unchecked(sc, n * n);
	}
      push_stack(sc, OP_SORT, args, lx);
      end_temp(sc->y);
    }}
  return(sc->F);
  /* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b)))
   * set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked.
   */
}

/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */
static s7_pointer vector_into_list(s7_scheme *sc, s7_pointer vect, s7_pointer lst)
{
  const s7_pointer *elements = vector_elements(vect);
  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 vector_into_fi_vector(s7_pointer source, s7_pointer dest)
{
  const s7_pointer *elements = vector_elements(source);
  const s7_int len = vector_length(source);
  if (is_float_vector(dest))
    {
      s7_double *flts = float_vector_floats(dest);
      for (s7_int i = 0; i < len; i++)	flts[i] = real(elements[i]);
    }
  else
    {
      s7_int *ints = int_vector_ints(dest);
      for (s7_int i = 0; i < len; i++)	ints[i] = integer(elements[i]);
    }
  return(dest);
}

static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest)
{
  const s7_pointer *elements = vector_elements(vect);
  const s7_int len = vector_length(vect);
  if (is_byte_vector(dest))
    {
      uint8_t *str = (uint8_t *)byte_vector_bytes(dest);
      for (s7_int i = 0; i < len; i++)	str[i] = (uint8_t)integer(elements[i]);
    }
  else
    {
      uint8_t *str = (uint8_t *)string_value(dest);
      for (s7_int i = 0; i < len; i++)	str[i] = character(elements[i]);
    }
  return(dest);
}

#define sort_n(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)
{
  const s7_int n = sort_n(sc), k = sort_k1(sc);
  s7_int j;
  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);
  const 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)
{
  const s7_int j = sort_j(sc), k = sort_k1(sc);
  if (j == k) return(true);
  if (is_true(sc, sc->value))
    {
      const 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 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]
   */
  const 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 bool op_sort3(s7_scheme *sc)
{
  const 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);
}


/* -------- 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) /* entries[i] might be NULL, or a list of entries traversed via hash_entry_next, ending in NULL */
	    {
	      n = hash_entry_next(p);
	      liberate_block(sc, p);
	    }
	  for (hash_entry_t *p = entries[i]; p; p = n)   /* i incremented above, all tables have an even number of entries, so do 2 at a time here */
	    {
	      n = hash_entry_next(p);
	      liberate_block(sc, p);
	    }}}
  liberate(sc, hash_table_block(table));
}

static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash)
{
  hash_entry_t *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);
}


/* -------------------------------- hash-table? -------------------------------- */
bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));}

static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table"
  #define Q_is_hash_table sc->pl_bt
  check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args);
}


/* -------------------------------- hash-table-entries -------------------------------- */
static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj"
  #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol)

  const s7_pointer obj = car(args);
  if (!is_hash_table(obj))
    return(sole_arg_method_or_bust(sc, obj, sc->hash_table_entries_symbol, args, sc->type_names[T_HASH_TABLE]));
  return(make_integer(sc, hash_table_entries(obj)));
}

static s7_int hash_table_entries_i_7p(s7_scheme *sc, s7_pointer table)
{
  if (!is_hash_table(table))
    return(integer(method_or_bust_p(sc, table, sc->hash_table_entries_symbol, sc->type_names[T_HASH_TABLE])));
  return(hash_table_entries(table));
}


/* -------------------------------- hash-table-key|value-typer -------------------------------- */
static s7_pointer g_hash_table_key_typer(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_key_typer "(hash-table-key-typer hash) returns the hash-table's key type checking function"
  #define Q_hash_table_key_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol)

  const s7_pointer table = car(args);
  if (!is_hash_table(table)) return(sole_arg_method_or_bust(sc, table, sc->hash_table_key_typer_symbol, args, sc->type_names[T_HASH_TABLE]));
  if (is_typed_hash_table(table)) return(hash_table_key_typer(table));
  return(sc->F);
}

static s7_pointer g_hash_table_value_typer(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_value_typer "(hash-table-value-typer hash) returns the hash-table's value type checking function"
  #define Q_hash_table_value_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol)

  const s7_pointer table = car(args);
  if (!is_hash_table(table)) return(sole_arg_method_or_bust(sc, table, sc->hash_table_value_typer_symbol, args, sc->type_names[T_HASH_TABLE]));
  if (is_typed_hash_table(table)) return(hash_table_value_typer(table));
  return(sc->F);
}

static s7_pointer make_hash_table_procedures(s7_scheme *sc)
{
  const s7_pointer p = cons(sc, sc->T, sc->T); /* checker, mapped */
  set_opt1_any(p, sc->T);                /* key */
  set_opt2_any(p, sc->T);                /* value */
  return(p);
}

static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table)
{
  if (is_pair(hash_table_procedures(table)))
    {
      const 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))
    {
      const 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);
}


/* ---------------- hash map and equality tables ---------------- */
/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */
#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key)

static hash_map_t eq_hash_map[Num_Types];
static hash_map_t string_eq_hash_map[Num_Types];
static hash_map_t char_eq_hash_map[Num_Types];
static hash_map_t closure_hash_map[Num_Types];
static hash_map_t equivalent_hash_map[Num_Types];
static hash_map_t c_function_hash_map[Num_Types];
#if !With_Pure_s7
static hash_map_t string_ci_eq_hash_map[Num_Types];
static hash_map_t char_ci_eq_hash_map[Num_Types];
#endif
/* also default_hash_map */


/* ---------------- hash-code ---------------- */
/* eqfunc handling which will require other dummy tables */

static s7_pointer make_dummy_hash_table(s7_scheme *sc) /* make the absolute minimal hash-table that can support hash-code */
{
  const s7_pointer table = alloc_pointer(sc);
  set_type_bit(table, T_Immutable | T_HASH_TABLE | T_Unheap);
  hash_table_mapper(table) = default_hash_map;
  hash_table_mask(table) = 1; /* we're lying... */
  return(table);
}

s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer unused_eqfunc)
{
  return(default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj));
}

static s7_pointer g_hash_code(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj."
  #define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T)

  const s7_pointer obj = car(args);
  s7_int code;
  if ((is_pair(cdr(args))) &&
      (!is_procedure(cadr(args))))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "hash-code second argument (currently ignored) should be a function: ~S", 70), cadr(args)));
  /* I think this function should not accept methods */
  code = default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj);
#ifdef __clang__
  if (code < 0) code = 0;
#endif
  return(make_integer(sc, code));
}


static bool (*equals[Num_Types])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci);
static bool (*equivalents[Num_Types])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci);

static hash_entry_t *(*default_hash_checks[Num_Types])(s7_scheme *sc, s7_pointer table, s7_pointer key);
static hash_entry_t *(*equal_hash_checks[Num_Types])(s7_scheme *sc, s7_pointer table, s7_pointer key);


/* ---------------- hash empty ---------------- */
static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer unused_table, s7_pointer unused_key) {return(sc->unentry);}

/* ---------------- hash syntax ---------------- */
static s7_uint hash_map_syntax(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)  {return(pointer_map(syntax_symbol(key)));}

static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table);
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if ((is_syntax(hash_entry_key(entry))) &&
	(syntax_symbol(hash_entry_key(entry)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */
      return(entry);
  return(sc->unentry);
}

/* ---------------- hash symbols ---------------- */
static s7_uint hash_map_symbol(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)  {return(pointer_map(key));}

static hash_entry_t *hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_uint loc = pointer_map(key) % hash_table_mask(table);
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if (key == hash_entry_key(entry))
      return(entry);
  return(sc->unentry);
}


/* ---------------- hash numbers ---------------- */
static s7_uint hash_map_int(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  const s7_int k = integer(key);
  return((k >= 0) ? k : ((k == s7_Int64_Min) ? s7_Int64_Max : -k)); /* ignoring s7_Int64_Min makes no difference in s7test/tmap-hash timings */
  /* return((k >= 0) ? k : -k); */
}

static s7_uint hash_map_ratio(s7_scheme *unused_sc, s7_pointer unused_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)));
}

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)));
#endif
}
  /* isnormal here in place of is_NaN and is_inf is slower.
   *   try using x*100 to expand small float bin range
   */

static s7_uint hash_map_real(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  return(hash_float_location(real(key)));
}

static s7_uint hash_complex_location(s7_double x)
{
  return(hash_float_location(x)); /* + hash_float_location(imag_part(key)) -- imag-part confuses epsilon distance calcs */
}

static s7_uint hash_map_complex(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  return(hash_complex_location(real_part(key)));
}

#if With_Gmp
static s7_uint hash_map_big_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* may need to use quotient here */
  mpz_abs(sc->mpz_1, big_integer(key));
  return(mpz_get_si(sc->mpz_1)); /* returns the bits that fit */
}

static s7_uint hash_map_big_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  mpq_abs(sc->mpq_1, big_ratio(key));
  mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1));
  return(mpz_get_si(sc->mpz_1));
}

static s7_uint hash_map_big_real_1(s7_scheme *sc, s7_pointer table, mpfr_t key)
{
  if ((mpfr_nan_p(key)) || (mpfr_inf_p(key))) return(0);
  mpfr_abs(sc->mpfr_1, key, Mpfr_Rndn);
  /* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */
  mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */
  return(mpz_get_si(sc->mpz_1));
}

static s7_uint hash_map_big_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(hash_map_big_real_1(sc, table, big_real(key)));
}

static s7_uint hash_map_big_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(hash_map_big_real_1(sc, table, mpc_realref(big_complex(key))));
}
#endif

static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key)
{
  bool (*equiv)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equivalents[type(key)];
  for (; bin; bin = hash_entry_next(bin))
    if (equiv(sc, key, hash_entry_key(bin), NULL))
      return(bin);
  return(NULL);
}

static hash_entry_t *hash_number_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */
#if With_Gmp
  /* first try loc from hash_loc, then get key-floor(key) [with abs], and check against
   *   epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1
   */
  const s7_uint hash_mask = hash_table_mask(table);
  const s7_uint loc = hash_loc(sc, table, key);
  {
    const s7_uint hash_loc = loc % hash_mask;
    hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
    if (i1) return(i1);
  }

  if (is_real(key))
    {
      s7_pointer result = any_real_to_mpfr(sc, key, sc->mpfr_1);
      if (result) return(sc->unentry);
    }
  else
    if (is_t_complex(key))
      mpfr_set_d(sc->mpfr_1, real_part(key), Mpfr_Rndn);
    else mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), Mpfr_Rndn);

  /* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */
  mpfr_abs(sc->mpfr_1, sc->mpfr_1, Mpfr_Rndn);
  mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
  mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
  {
    s7_uint loc1 = mpz_get_si(sc->mpz_1);
    if (loc1 != loc)
      {
	s7_uint hash_loc;
	hash_entry_t *i1;
	if (loc1 == hash_table_mask(table)) loc1 = 0;
	hash_loc = loc1 % hash_mask;
	i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
	return((i1) ? i1 : sc->unentry);
      }
    mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
    mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
    loc1 = mpz_get_si(sc->mpz_1);
    if (loc1 != loc)
      {
	s7_uint hash_loc;
	hash_entry_t *i1;
	if (loc1 < 0) loc1 = hash_table_mask(table);
	hash_loc = loc1 % hash_mask;
	i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
	if (i1) return(i1);
      }}
  return(sc->unentry);
#else
  const s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key);
  const s7_double fprobe = fabs(keyval);
  const s7_uint iprobe = (s7_uint)floor(fprobe);
  const s7_double bin_dist = fprobe - iprobe;
#ifdef __clang__
  s7_uint loc = ((is_NaN(keyval)) || (is_inf(keyval))) ? 0 : iprobe % hash_table_mask(table);
#else
  s7_uint loc = iprobe % hash_table_mask(table);
#endif
  hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, loc), key);
  if (i1) return(i1);

  if (bin_dist <= sc->equivalent_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->equivalent_float_epsilon))
      i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key);
  return((i1) ? i1 : sc->unentry);
#endif
}

static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
#if With_Gmp
  if ((is_t_integer(key)) || (is_t_big_integer(key)))
#else
  if (is_t_integer(key))
#endif
    {
      const s7_uint hash_mask = hash_table_mask(table);
      hash_entry_t *entry;
#if With_Gmp
      const s7_int kv = (is_t_integer(key)) ? integer(key) : mpz_get_si(big_integer(key));
#else
      const s7_int kv = integer(key);
#endif
      const s7_uint loc = s7_int_abs(kv) % hash_mask;
      for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
#if With_Gmp
	if (is_t_integer(hash_entry_key(entry)))
	  {
	    if (integer(hash_entry_key(entry)) == kv)
	      return(entry);
	  }
	else
	  if ((is_t_big_integer(hash_entry_key(entry))) &&
	      (mpz_get_si(big_integer(hash_entry_key(entry))) == kv))
	    return(entry);
#else
      if (integer(hash_entry_key(entry)) == kv)
	return(entry);
#endif
    }
  return(sc->unentry);
}

static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */
#if With_Gmp
  if ((is_t_real(key)) || (is_t_big_real(key)))
#else
  if (is_t_real(key))
#endif
    {
      s7_double keyval;
      s7_uint loc;
#if With_Gmp
      if (is_t_real(key))
	{
	  keyval = real(key);
	  if (is_NaN(keyval)) return(sc->unentry);
	}
      else
	{
	  if (mpfr_nan_p(big_real(key))) return(sc->unentry);
	  keyval = mpfr_get_d(big_real(key), Mpfr_Rndn);
	}
#else
      keyval = real(key);
      if (is_NaN(keyval)) return(sc->unentry);
#endif
      loc = hash_float_location(keyval) % hash_table_mask(table);
      for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
	{
	  if ((is_t_real(hash_entry_key(entry))) &&
	      (keyval == real(hash_entry_key(entry))))
	    return(entry);
#if With_Gmp
	  if ((is_t_big_real(hash_entry_key(entry))) &&
	      (mpfr_cmp_d(big_real(hash_entry_key(entry)), keyval) == 0) &&
	      (!mpfr_nan_p(big_real(hash_entry_key(entry)))))
	    return(entry);
#endif
	}}
  return(sc->unentry);
}

#if With_Gmp
static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table);
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if (num_eq_b_7pp(sc, key, hash_entry_key(entry)))
      return(entry);
  return(sc->unentry);
}

static hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if ((is_t_real(key)) && (is_NaN(real(key)))) return(sc->unentry);
  if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key)))) return(sc->unentry);
  return(hash_num_eq(sc, table, key));
}

static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if ((is_t_complex(key)) && ((is_NaN(real_part(key))) || (is_NaN(imag_part(key))))) return(sc->unentry);
  if ((is_t_big_complex(key)) && ((mpfr_nan_p(mpc_realref(big_complex(key)))) || (mpfr_nan_p(mpc_imagref(big_complex(key)))))) return(sc->unentry);
  return(hash_num_eq(sc, table, key));
}
#endif

static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_number(key))
    {
#if !With_Gmp
      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 */
	{
	  const s7_int keyi = integer(key);
	  const 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
	{
	  const 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);
	}
#else
	return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key));
#endif
    }
  return(sc->unentry);
}


/* ---------------- hash characters ---------------- */
static s7_uint hash_map_char(s7_scheme *unused_sc, s7_pointer unused_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.
       */
      const s7_uint loc = character(key) % hash_table_mask(table);
      for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
	if (key == hash_entry_key(entry))
	  return(entry);
    }
  return(sc->unentry);
}

#if !With_Pure_s7
static s7_uint hash_map_ci_char(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key) {return(upper_character(key));}

static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_character(key))
    {
      const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table);
      for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
	if (upper_character(key) == upper_character(hash_entry_key(entry)))
	  return(entry);
    }
  return(sc->unentry);
}
#endif


/* ---------------- hash strings ---------------- */
static s7_uint hash_map_string(s7_scheme *unused_sc, s7_pointer unused_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);
	}
      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);
}

#if !With_Pure_s7
static s7_uint hash_map_ci_string(s7_scheme *unused_sc, s7_pointer unused_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))
    {
      const s7_uint hash_mask = hash_table_mask(table);
      const s7_uint hash = hash_map_ci_string(sc, table, key);
      for (hash_entry_t *entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry))
	if (scheme_strequal_ci(key, hash_entry_key(entry)))
	  return(entry);
    }
  return(sc->unentry);
}
#endif


/* ---------------- hash eq? ---------------- */
static s7_uint hash_map_nil(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key) {return(type(key));}

static s7_uint hash_map_eq(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key) {return(pointer_map(key));}

static hash_entry_t *hash_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* explicit eq? as hash equality func for (for example) symbols as keys */
  const s7_uint loc = pointer_map(key) % hash_table_mask(table); /* hash_map_eq */
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if (key == hash_entry_key(entry))
      return(entry);
  return(sc->unentry);
}

/* ---------------- hash eqv? ---------------- */
static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table);
  if (is_number(key))
    {
#if With_Gmp
      for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
	if (numbers_are_eqv(sc, key, hash_entry_key(entry)))
	  return(entry);
#else
      const 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);
#endif
    }
  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);
}

/* ---------------- hash equal? ---------------- */
static s7_uint hash_map_hash_table(s7_scheme *sc, s7_pointer unused_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 = NULL;
    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 */
}

static s7_uint hash_map_int_vector(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  if (vector_length(key) == 0)
    return(0);
  if (vector_length(key) == 1)
    return(s7_int_abs(int_vector(key, 0)));
  return(vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), as long as it's consistent */
}

static s7_uint hash_map_byte_vector(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  if (byte_vector_length(key) == 0)
    return(0);
  if (byte_vector_length(key) == 1)
    return((s7_int)byte_vector(key, 0));
  return(byte_vector_length(key) + byte_vector(key, 0) + byte_vector(key, 1));
}

static s7_uint hash_map_float_vector(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  s7_uint loc1, loc2;
  if (vector_length(key) == 0) return(0);
  loc1 = hash_float_location(float_vector(key, 0));
  if (vector_length(key) == 1) return(loc1);
  loc2 = hash_float_location(float_vector(key, 1));
  return(vector_length(key) + loc1 + loc2);
}

static s7_uint hash_map_complex_vector(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  s7_uint loc1, loc2;
  if (vector_length(key) == 0) return(0);
  loc1 = hash_complex_location(creal(complex_vector(key, 0)));
  if (vector_length(key) == 1) return(loc1);
  loc2 = hash_complex_location(creal(complex_vector(key, 1)));
  return(vector_length(key) + loc1 + loc2);
}

static s7_uint hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_uint loc1, loc2;
  if ((vector_length(key) == 0) ||
      (is_sequence_or_iterator(vector_element(key, 0))))
    return(vector_length(key));
  loc1 = hash_loc(sc, table, vector_element(key, 0));
  if ((vector_length(key) == 1) ||
      (is_sequence_or_iterator(vector_element(key, 1))))
    return(loc1);
  loc2 = hash_loc(sc, table, vector_element(key, 1));
  return(vector_length(key) + loc1 + loc2);
}


static s7_uint hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_pointer f = hash_table_procedures_mapper(table);
  if (f == sc->unused)
    error_nr(sc, make_symbol(sc, "hash-map-recursion", 18),
	     set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42)));
  /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore hash-table-procedures */
  gc_protect_via_stack(sc, f);
  hash_table_set_procedures_mapper(table, sc->F);
  sc->value = s7_call(sc, f, set_plist_1(sc, key));
  unstack_gc_protect(sc);
  hash_table_set_procedures_mapper(table, f);
  if (!s7_is_integer(sc->value))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "hash-table map function should return an integer: ~S", 52), sc->value));
  return(integer(sc->value));
}

static s7_uint hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing. equal? follows outlet, but that is ridiculous here. */
  s7_pointer slot, slot1 = NULL, slot2 = NULL;
  s7_int slots;

  if ((key == sc->rootlet) || (!is_slot_checked(let_slots(key)))) return(0);
  for (slot = let_slots(key), slots = 0; is_slot_checked(slot); slot = next_slot(slot))
    if (!is_matched_symbol(slot_symbol(slot)))
      {
	if (!slot1) slot1 = slot; else slot2 = slot;
	set_match_symbol(slot_symbol(slot));
	slots++;
      }
  for (slot = let_slots(key); is_slot_checked(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)
{
  const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table);
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if (hash_entry_key(entry) == key)
      return(entry);
  return(sc->unentry);
}

#define hash_int_abs(X) ((X) >= 0 ? (X) : ((X == s7_Int64_Min) ? s7_Int64_Max : -(X)))

static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_int keyint = integer(key);
  const s7_uint loc = hash_int_abs(keyint) % hash_table_mask(table);  /* hash_loc -> hash_map_int */
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    {
      if ((is_t_integer(hash_entry_key(entry))) &&
	  (keyint == integer(hash_entry_key(entry))))
	return(entry);
#if With_Gmp
      if ((is_t_big_integer(hash_entry_key(entry))) &&
	  (mpz_cmp_si(big_integer(hash_entry_key(entry)), keyint) == 0))
	return(entry);
#endif
    }
  return(sc->unentry);
}

static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_int keynum = numerator(key), keyden = denominator(key);
  const s7_uint loc = s7_int_abs(keynum / keyden) % hash_table_mask(table);  /* hash_loc -> hash_map_ratio */
  /* fprintf(stderr, "%s %u ", display(key), (unsigned int)loc); */

  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    {
      if ((is_t_ratio(hash_entry_key(entry))) &&
	  (keynum == numerator(hash_entry_key(entry))) &&
	  (keyden == denominator(hash_entry_key(entry))))
	return(entry);
#if With_Gmp
      if ((is_t_big_ratio(hash_entry_key(entry))) &&
	  (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(entry))))) &&
	  (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(entry))))))
	return(entry);
#endif
    }
  return(sc->unentry);
}

static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_double keydbl = real(key);
  s7_uint loc = hash_float_location(keydbl) % hash_table_mask(table);
  /* if (is_NaN(keydbl)) return(sc->unentry); */
  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    {
      if ((is_t_real(hash_entry_key(entry))) && /* can real(key) == keydbl by accident? maybe complex key with the same real part? */
	  (keydbl == real(hash_entry_key(entry))))
	  return(entry);
#if With_Gmp
      if ((is_t_big_real(hash_entry_key(entry))) &&
	  (mpfr_cmp_d(big_real(hash_entry_key(entry)), keydbl) == 0) &&
	  (!mpfr_nan_p(big_real(hash_entry_key(entry)))))
	return(entry);
#endif
    }
  return(sc->unentry);
}

static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  const s7_double keyrl = real_part(key);
  const s7_double keyim = imag_part(key);
#if With_Gmp
  s7_uint loc;
  if ((is_NaN(keyrl)) || (is_NaN(keyim))) return(sc->unentry);
  loc = hash_map_complex(sc, table, key) % hash_table_mask(table);
#else
  const s7_uint loc = hash_map_complex(sc, table, key) % hash_table_mask(table);
#endif

  for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    {
      if ((is_t_complex(hash_entry_key(entry))) &&
	  (keyrl == real_part(hash_entry_key(entry))) &&
	  (keyim == imag_part(hash_entry_key(entry))))
	return(entry);
#if With_Gmp
      if ((is_t_big_complex(hash_entry_key(entry))) &&
	  (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(entry))), keyrl) == 0) &&
	  (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(entry))), keyim) == 0) &&
	  (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(entry))))) &&
	  (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(entry))))))
	return(entry);
#endif
    }
  return(sc->unentry);
}

static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  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, but is it safe? */
      return(entry);
  {
    bool (*equal)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equals[type(key)];
    for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
      if ((hash_entry_raw_hash(entry) == hash) &&
	  (equal(sc, key, hash_entry_key(entry), NULL)))
	return(entry);
  }
  return(sc->unentry);
}


/* ---------------- hash c_functions ---------------- */
static s7_uint hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_function f = c_function_call(hash_table_procedures_mapper(table));
  return(integer(f(sc, with_list_t1(sc, key))));
}

static s7_uint hash_map_c_pointer(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  return(pointer_map(c_pointer(key)));
}

static s7_uint hash_map_undefined(s7_scheme *unused_sc, s7_pointer unused_table, s7_pointer key)
{
  return(raw_string_hash((const uint8_t *)(undefined_name(key) + 1), undefined_name_length(key) - 1) + undefined_name_length(key));
  /* undefined_name always starts with "#", so we omit it above */
}

static s7_uint hash_map_iterator(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* cycles can happen here if the iterator_sequence contains the iterator and hash_loc checks that element */
  return(type(iterator_sequence(key)) + hash_loc(sc, table, iterator_sequence(key)));
}

static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key);

static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_pair(hash_table_procedures(table)))
    {
      const s7_function f = c_function_call(hash_table_procedures_checker(table));
      const s7_uint hash = hash_loc(sc, table, key);
      const s7_uint loc = hash % hash_table_mask(table);
      set_car(sc->t2_1, key);
      for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
	if (hash_entry_raw_hash(entry) == hash)
	  {
	    set_car(sc->t2_2, hash_entry_key(entry));
	    if (is_true(sc, f(sc, sc->t2_1)))
	      return(entry);
	  }
      return(sc->unentry);
    }
  return(hash_equal(sc, table, key));
}

static int32_t len_upto_100(s7_pointer p)
{
  int32_t i = 0;
  for (; (is_pair(p)) && (i < 100); i++, p = cdr(p));
  return(i);
}

static s7_uint hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location,
   *   so at least we need to take cadr into account if possible.  Better would combine the list_length (or tree-leaves == tree_len(sc, p))
   *   with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs.
   *   key can be cyclic, so tree_len would need to check for cycles.
   */
  const s7_pointer 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));
}

static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return((*(equal_hash_checks[type(key)]))(sc, table, key));
}

/* ---------------- hash equivalent? ---------------- */
static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *entry;
  s7_uint hash, loc;

  if (is_number(key))
    {
#if With_Gmp
      if (!is_nan_b_7p(sc, key))
	return(hash_number_equivalent(sc, table, key));
#else
      entry = hash_number_equivalent(sc, table, key);
      if ((entry != sc->unentry) || (!is_nan_b_7p(sc, key)))
	return(entry);
#endif
      for (entry = hash_table_element(table, 0); entry; entry = hash_entry_next(entry)) /* NaN is mapped to 0 */
	if (is_nan_b_7p(sc, hash_entry_key(entry)))  /* all NaN's are the same to equivalent? */
	  return(entry);
      return(sc->unentry);
    }
  hash = hash_loc(sc, table, key);
  loc = hash % hash_table_mask(table);
  for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if (hash_entry_key(entry) == key)
      return(entry);

  for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if ((hash_entry_raw_hash(entry) == hash) &&
	(s7_is_equivalent(sc, hash_entry_key(entry), key)))
      return(entry);
  return(sc->unentry);
}

static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash)
{
  return((is_null(hash_table_procedures(hash))) &&
	 (hash_table_mapper(hash) == default_hash_map) &&
	 (hash_table_checker(hash) != hash_equal) &&
	 (hash_table_checker(hash) != hash_equivalent) &&
	 (hash_table_checker(hash) != hash_closure) &&
	 (hash_table_checker(hash) != hash_c_function));
}


/* -------------------------------- make-hash-table -------------------------------- */
s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size)
{
  /* 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);
}

static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args);
static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args);

static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  #define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \
used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \
in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n"
  #define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \
					      s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \
					      s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol))
  s7_int size = sc->default_hash_table_length;

  if (is_pair(args))
    {
      const s7_pointer len = car(args);
      if (!s7_is_integer(len))
	return(method_or_bust(sc, len, caller, args, sc->type_names[T_INTEGER], 1));
      size = s7_integer_clamped_if_gmp(sc, len);
      if (size < 0)                      /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */
	out_of_range_error_nr(sc, caller, Int_One, len, wrap_string(sc, "it should be a positive integer", 31));
      if ((size > sc->max_vector_length) ||
	  (size >= (1LL << 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))
			    {
			      const s7_pointer eq_sig = c_function_signature(proc);
			      if ((eq_sig) &&
				  (is_pair(eq_sig)) &&
				  (is_pair(cdr(eq_sig))) &&
				  (!compatible_types(sc, cadr(eq_sig), c_function_symbol(keyp))))
				error_nr(sc, sc->wrong_type_arg_symbol,
					 set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97),
						     caller, typers));
			    }}
		      else
			if ((is_any_closure(keyp)) &&
			    (!is_symbol(find_closure(sc, keyp, closure_let(keyp)))))
			  error_nr(sc, sc->wrong_type_arg_symbol,
				   set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92),
					       caller, typers));
		      if ((valp != sc->T) &&
			  (!s7_is_aritable(sc, valp, 1)))
			error_nr(sc, sc->wrong_type_arg_symbol,
				 set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100),
						caller, typers));
		      if (is_c_function(valp))
			{
			  if (!c_function_name(valp))
			    error_nr(sc, sc->wrong_type_arg_symbol,
				     set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93),
						 caller, typers));
			  if (c_function_has_simple_elements(valp))
			    set_has_simple_values(table);
			  if (symbol_type(c_function_symbol(valp)) != T_FREE)
			    set_has_hash_value_type(table);
			}
		      else
			if ((is_any_closure(valp)) &&
			    (!is_symbol(find_closure(sc, valp, closure_let(valp)))))
			  error_nr(sc, sc->wrong_type_arg_symbol,
				   set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93),
					       caller, typers));
		      set_is_typed_hash_table(table);
		    }}
	      else
		if (typers != sc->F)
		  wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51));
	    }

	  /* check eq_func */
	  proc = cadr(args);
	  if (is_c_function(proc))
	    {
	      hash_set_chosen(table);

	      if (!s7_is_aritable(sc, proc, 2))
		wrong_type_error_nr(sc, caller, 2, proc, An_Eq_Func_String);

	      if (c_function_call(proc) == g_is_equal)
		{
		  hash_table_checker(table) = hash_equal;
		  return(table);
		}
	      if (c_function_call(proc) == g_is_equivalent)
		{
		  hash_table_checker(table) = hash_equivalent;
		  hash_table_mapper(table) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */
		  return(table);
		}
	      if (c_function_call(proc) == g_is_eq)
		{
		  hash_table_checker(table) = hash_eq;
		  hash_table_mapper(table) = eq_hash_map;
		  return(table);
		}
	      if (c_function_call(proc) == g_strings_are_equal)
		{
		  hash_table_checker(table) = hash_string;
		  hash_table_mapper(table) = string_eq_hash_map;
		  return(table);
		}
#if !With_Pure_s7
	      if (c_function_call(proc) == g_strings_are_ci_equal)
		{
		  hash_table_checker(table) = hash_ci_string;
		  hash_table_mapper(table) = string_ci_eq_hash_map;
		  return(table);
		}
	      if (c_function_call(proc) == g_chars_are_ci_equal)
		{
		  hash_table_checker(table) = hash_ci_char;
		  hash_table_mapper(table) = char_ci_eq_hash_map;
		  return(table);
		}
#endif
	      if (c_function_call(proc) == g_chars_are_equal)
		{
		  hash_table_checker(table) = hash_char;
		  hash_table_mapper(table) = char_eq_hash_map;
		  return(table);
		}
	      if (c_function_call(proc) == g_num_eq)
		{
		  if ((is_typed_hash_table(table)) &&
		      (hash_table_key_typer(table) == global_value(sc->is_integer_symbol)))
		    hash_table_checker(table) = hash_int;
		  else hash_table_checker(table) = hash_number_num_eq;
		  return(table);
		}
	      if (c_function_call(proc) == g_is_eqv)
		{
		  hash_table_checker(table) = hash_eqv;
		  return(table);
		}
	      error_nr(sc, sc->out_of_range_symbol,
		       set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc));
	    }
	  /* proc not c_function */
	  else
	    {
	      if (is_pair(proc))
		{
		  const s7_pointer checker = car(proc), mapper = cdr(proc);

		  hash_set_chosen(table);
		  if (!((is_any_c_function(checker)) ||	(is_any_closure(checker))))
		    error_nr(sc, sc->wrong_type_arg_symbol,
			     set_elist_4(sc, wrap_string(sc, "~A: first entry of type info, ~A, is ~A, but should be a function", 65),
					 caller, checker, type_name_string(sc, checker)));
		  if (!((is_any_c_function(mapper)) ||(is_any_closure(mapper))))
		    error_nr(sc, sc->wrong_type_arg_symbol,
			     set_elist_4(sc, wrap_string(sc, "~A: second entry of type info, ~A, is ~A, but should be a function", 66),
					 caller, mapper, type_name_string(sc, mapper)));

		  if (!s7_is_aritable(sc, checker, 2))
		    error_nr(sc, sc->wrong_type_arg_symbol,
			     set_elist_3(sc, wrap_string(sc, "~A's equality function, ~A, (car of the second argument) should be a function of two arguments", 94),
					 caller, checker));
		  if (!s7_is_aritable(sc, mapper, 1))
		    error_nr(sc, sc->wrong_type_arg_symbol,
			     set_elist_3(sc, wrap_string(sc, "~A's mapping function, ~A, (cdr of the second argument) should be a function of one argument", 92),
					 caller, mapper));

		  if (is_any_c_function(checker))
		    {
		      const s7_pointer sig = c_function_signature(checker);
		      if ((sig) &&
			  (is_pair(sig)) &&
			  (car(sig) != sc->is_boolean_symbol))
			error_nr(sc, sc->wrong_type_arg_symbol,
				 set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker));
		      hash_table_checker(table) = hash_c_function;
		    }
		  else hash_table_checker(table) = hash_closure;

		  if (is_any_c_function(mapper))
		    {
		      const s7_pointer sig = c_function_signature(mapper);
		      if ((sig) &&
			  (is_pair(sig)) &&
			  (car(sig) != sc->is_integer_symbol))
			error_nr(sc, sc->wrong_type_arg_symbol,
				 set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper));
		      hash_table_mapper(table) = c_function_hash_map;
		    }
		  else hash_table_mapper(table) = closure_hash_map;

		  if (is_null(hash_table_procedures(table)))
		    hash_table_set_procedures(table, make_hash_table_procedures(sc));
		  hash_table_set_procedures_checker(table, car(proc)); /* proc = cadr(args) */
		  hash_table_set_procedures_mapper(table, cdr(proc));
		  return(table);
		}
	      if (proc != sc->F)
		  wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "either #f or (cons equality-func map-func)", 42));
	      return(table);
	    }}}
  return(s7_make_hash_table(sc, size));
}

static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
{
  return(g_make_hash_table_1(sc, args, sc->make_hash_table_symbol));
}


/* -------------------------------- make-weak-hash-table -------------------------------- */
static s7_pointer g_make_weak_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table"
  #define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \
						   s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \
						   s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol))
  s7_pointer table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol);
  if (is_hash_table(table)) /* (make-weak-hash-table (openlet (inlet 'make-weak-hash-table list))) ! */
    {
      set_weak_hash_table(table);
      weak_hash_iters(table) = 0;
    }
  return(table);
}

static const char *hash_table_checker_name(s7_scheme *unused_sc, s7_pointer table)
{
  if (hash_table_checker(table) == hash_equal) return("equal?");
  if (hash_table_checker(table) == hash_equivalent) return("equivalent?");
  if (hash_table_checker(table) == hash_eq) return("eq?");
  if (hash_table_checker(table) == hash_eqv) return("eqv?");
  if (hash_table_checker(table) == hash_string) return("string=?");
#if !With_Pure_s7
  if (hash_table_checker(table) == hash_ci_string) return("string-ci=?");
  if (hash_table_checker(table) == hash_ci_char) return("char-ci=?");
#endif
  if (hash_table_checker(table) == hash_char) return("char=?");
  if (hash_table_checker(table) == hash_number_num_eq) return("=");
  return("#f");
}


/* -------------------------------- weak-hash-table? -------------------------------- */
static s7_pointer g_is_weak_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table"
  #define Q_is_weak_hash_table sc->pl_bt
  #define is_weak_hash(P) ((is_hash_table(P)) && (is_weak_hash_table(P))) /* for boolean_method below */
  check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol, args);
}

static void init_hash_maps(void)
{
  for (int32_t i = 0; i < Num_Types; i++)
    {
      default_hash_map[i] = hash_map_nil;
      string_eq_hash_map[i] = hash_map_nil;
      char_eq_hash_map[i] = hash_map_nil;
#if !With_Pure_s7
      string_ci_eq_hash_map[i] = hash_map_nil;
      char_ci_eq_hash_map[i] = hash_map_nil;
#endif
      closure_hash_map[i] = hash_map_closure;
      c_function_hash_map[i] = hash_map_c_function;
      eq_hash_map[i] = hash_map_eq;

      equal_hash_checks[i] = hash_equal_any;
      default_hash_checks[i] = hash_equal;
    }
  default_hash_map[T_CHARACTER] =     hash_map_char;
  default_hash_map[T_SYMBOL] =        hash_map_symbol;
  default_hash_map[T_SYNTAX] =        hash_map_syntax;
  default_hash_map[T_STRING] =        hash_map_string;
  default_hash_map[T_BYTE_VECTOR] =   hash_map_byte_vector;
  default_hash_map[T_HASH_TABLE] =    hash_map_hash_table;
  default_hash_map[T_VECTOR] =        hash_map_vector;
  default_hash_map[T_INT_VECTOR] =    hash_map_int_vector;
  default_hash_map[T_FLOAT_VECTOR] =  hash_map_float_vector;
  default_hash_map[T_COMPLEX_VECTOR] = hash_map_complex_vector;
  default_hash_map[T_LET] =           hash_map_let;
  default_hash_map[T_PAIR] =          hash_map_pair;
  default_hash_map[T_C_POINTER] =     hash_map_c_pointer;
  default_hash_map[T_UNDEFINED] =     hash_map_undefined;
  default_hash_map[T_ITERATOR] =      hash_map_iterator;
  for (int32_t i = T_OUTPUT_PORT; i < Num_Types; i++)
    default_hash_map[i] = hash_map_eq;

  default_hash_map[T_INTEGER] =       hash_map_int;
  default_hash_map[T_RATIO] =         hash_map_ratio;
  default_hash_map[T_REAL] =          hash_map_real;
  default_hash_map[T_COMPLEX] =       hash_map_complex;
#if With_Gmp
  default_hash_map[T_BIG_INTEGER] =   hash_map_big_int;
  default_hash_map[T_BIG_RATIO] =     hash_map_big_ratio;
  default_hash_map[T_BIG_REAL] =      hash_map_big_real;
  default_hash_map[T_BIG_COMPLEX] =   hash_map_big_complex;
#endif
  string_eq_hash_map[T_STRING] =      hash_map_string;
  string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector;
  char_eq_hash_map[T_CHARACTER] =     hash_map_char;
#if !With_Pure_s7
  string_ci_eq_hash_map[T_STRING] =   hash_map_ci_string;
  char_ci_eq_hash_map[T_CHARACTER] =  hash_map_ci_char;
#endif

  for (int32_t i = 0; i < Num_Types; i++)
    equivalent_hash_map[i] = default_hash_map[i];

  equal_hash_checks[T_SYNTAX] =       hash_equal_syntax;
  equal_hash_checks[T_SYMBOL] =       hash_equal_eq;
  equal_hash_checks[T_CHARACTER] =    hash_equal_eq;
  equal_hash_checks[T_INTEGER] =      hash_equal_integer;
  equal_hash_checks[T_RATIO] =        hash_equal_ratio;
  equal_hash_checks[T_REAL] =         hash_equal_real;
  equal_hash_checks[T_COMPLEX] =      hash_equal_complex;
  default_hash_checks[T_STRING] =     hash_string;
  default_hash_checks[T_INTEGER] =    hash_int;
  default_hash_checks[T_REAL] =       hash_float;
  default_hash_checks[T_SYMBOL] =     hash_symbol;
  default_hash_checks[T_CHARACTER] =  hash_char;
}

static void resize_hash_table(s7_scheme *sc, s7_pointer table)
{
  const s7_int entries = hash_table_entries(table);
  hash_entry_t **old_els = hash_table_elements(table);
  const s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */
  const s7_uint old_size = hash_table_size(table);
  const s7_uint new_size = old_size * 4; /* perhaps (old_size < 524288) ? (old_size * 4) : (old_size * 2) */
  const s7_uint hash_mask = new_size - 1;
  block_t *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)));
}

static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
  #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T)

  const s7_pointer table = car(args);
  s7_pointer result;
  if (!is_hash_table(table))
    return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1));
  result = s7_hash_table_ref(sc, table, cadr(args));
  if (is_pair(cddr(args)))
    return(ref_index_checked(sc, global_value(sc->hash_table_ref_symbol), result, args));
  return(result);
}

static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer table = car(args);
  if (!is_hash_table(table))
    return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1));
  return(hash_entry_value((*hash_table_checker(table))(sc, table, cadr(args))));
}

static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (!is_hash_table(table))
    return(method_or_bust(sc, table, sc->hash_table_ref_symbol, set_plist_2(sc, table, key), sc->type_names[T_HASH_TABLE], 1));
  return(hash_entry_value((*hash_table_checker(table))(sc, table, key)));
}

static bool op_implicit_hash_table_ref_a(s7_scheme *sc)
{
  const 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)
{
  const s7_pointer table = lookup_checked(sc, car(arg));
  if (!is_hash_table(table))
    return(s7_apply_function(sc, table, set_mlist_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)
{
  const s7_pointer table = lookup_checked(sc, car(sc->code));
  if (!is_hash_table(table)) {sc->last_function = table; return(false);}
  {
    const s7_pointer out_key = fx_call(sc, cdr(sc->code));
    const s7_pointer 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)
    {
      const s7_pointer key = caddr(expr);
      if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol)))
	set_class_and_fn_proc(key, sc->substring_uncopied);
      return(sc->hash_table_ref_2);
    }
 return(func);
}


/* -------------------------------- hash-table-set! -------------------------------- */
static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, const hash_entry_t *p)
{
  hash_entry_t *entry;
  s7_uint loc;

  if (p == sc->unentry) return(missing_key_value(sc));
  loc = hash_entry_raw_hash(p) % hash_table_mask(table);
  entry = hash_table_element(table, loc);
  if (entry == p)
    hash_table_element(table, loc) = hash_entry_next(entry);
  else
    {
      hash_entry_t *y;
      for (y = entry, entry = hash_entry_next(entry); entry; y = entry, entry = hash_entry_next(entry))
	if (entry == p)
	  {
	    hash_entry_next(y) = hash_entry_next(entry);
	    break;
	  }}
  hash_table_entries(table)--;
  if ((hash_table_entries(table) == 0) &&
      (hash_table_mapper(table) == default_hash_map))
    {
      hash_table_checker(table) = hash_empty;
      hash_clear_chosen(table);
    }
  liberate_block(sc, entry);
  return(sc->F);
}

static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table)
{
  const s7_int len = (s7_int)hash_table_size(table);
  hash_entry_t **entries = hash_table_elements(table);
  for (s7_int i = 0; i < len; i++)
    {
      hash_entry_t *nxp, *lxp = entries[i];
      for (hash_entry_t *entry = entries[i]; entry; entry = nxp)
	{
	  nxp = hash_entry_next(entry);
	  if (is_free_and_clear(hash_entry_key(entry)))
	    {
	      if (entry == entries[i])
		{
		  entries[i] = nxp;
		  lxp = nxp;
		}
	      else hash_entry_next(lxp) = nxp;
	      liberate_block(sc, entry);
	      hash_table_entries(table)--;
	      if (hash_table_entries(table) == 0)
		{
		  if (hash_table_mapper(table) == default_hash_map)
		    {
		      hash_table_checker(table) = hash_empty;
		      hash_clear_chosen(table);
		    }
		  return;
		}}
	  else lxp = entry;
	}}
}

static void hash_table_set_default_checker(s7_pointer table, uint8_t typ)
{
  if (hash_table_checker(table) != default_hash_checks[typ])
    {
      if (hash_table_checker(table) == hash_empty)
	hash_table_checker(table) = default_hash_checks[typ];
      else
	{
	  hash_table_checker(table) = hash_equal;
	  hash_set_chosen(table);
	}}
}

static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer)
{
  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 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 check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* check type -- raise error if incompatible with eq func set by make-hash-table */
  if (hash_table_checker(table) == hash_number_num_eq)
    {
      if (!is_number(key))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", 69),
			     key, type_name_string(sc, key)));
    }
  else
    if (hash_table_checker(table) == hash_eq)
      {
	if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */
	  error_nr(sc, sc->wrong_type_arg_symbol,
		   set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", 71),
			       key, type_name_string(sc, key)));
      }
    else
#if With_Pure_s7
      if (((hash_table_checker(table) == hash_string) && (!is_string(key))) ||
	  ((hash_table_checker(table) == hash_char) && (!is_character(key))))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70),
			     key, type_name_string(sc, key),
			     (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : sc->char_eq_symbol));
#else
      if ((((hash_table_checker(table) == hash_string) || (hash_table_checker(table) == hash_ci_string)) &&
	   (!is_string(key))) ||
	  (((hash_table_checker(table) == hash_char) || (hash_table_checker(table) == hash_ci_char)) &&
	   (!is_character(key))))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70),
			     key, type_name_string(sc, key),
			     (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol :
			     ((hash_table_checker(table) == hash_ci_string) ? sc->string_ci_eq_symbol :
			      ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->char_ci_eq_symbol))));
#endif
}

s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
{
  hash_entry_t *entry;

  if (value == missing_key_value(sc)) /* normally #f */
    return(remove_from_hash_table(sc, table, (*hash_table_checker(table))(sc, table, key)));
  if ((is_typed_hash_table(table)) && (sc->safety >= No_Safety)) /* this order is faster */
    check_hash_types(sc, table, key, value);

  entry = (*hash_table_checker(table))(sc, table, key);
  if (entry != sc->unentry)
    {
      hash_entry_set_value(entry, T_Ext(value));
      return(value);
    }
  /* hash_entry_raw_hash(entry) can save the hash_loc from the lookup operations, but at some added complexity in
   *   all the preceding code.  This saves about 5% compute time best case in this function.
   */
  if (!hash_chosen(table))
    hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */
  else
    if (sc->safety > No_Safety)
      check_hash_table_checker(sc, table, key);
  {
    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);
}

static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value"
  #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T)

  const s7_pointer table = car(args);
  if (!is_mutable_hash_table(table))
    return(mutable_method_or_bust(sc, table, sc->hash_table_set_symbol, args, sc->type_names[T_HASH_TABLE], 1));
  return(s7_hash_table_set(sc, table, cadr(args), caddr(args)));
}

static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
{
  if (!is_mutable_hash_table(table))  /* is_hash_table(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);
	   }}}
 return(func);
}


/* -------------------------------- hash-table -------------------------------- */
static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
{
  const s7_uint hash_mask = hash_table_mask(table);
  const s7_uint hash = hash_loc(sc, table, key);
  const s7_uint loc = hash % hash_mask;
  hash_entry_t *entry;

  if (!hash_chosen(table))
    hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */

  for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry))
    if ((hash_entry_raw_hash(entry) == hash) &&
	(s7_is_equal(sc, hash_entry_key(entry), key)))
      return(value);

  entry = mallocate_block(sc);
#if s7_Debugging
  sc->blocks_mallocated[Block_List]++;
#endif
  hash_entry_key(entry) = key;
  hash_entry_set_value(entry, T_Ext(value));
  hash_entry_set_raw_hash(entry, hash);
  hash_entry_next(entry) = hash_table_element(table, loc);
  hash_table_element(table, loc) = entry;
  hash_table_entries(table)++;
  if (hash_table_entries(table) > hash_mask)
    resize_hash_table(sc, table);
  return(value);
}

static s7_pointer g_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  s7_int len = proper_list_length(args);
  if (len & 1)
    error_nr(sc, sc->wrong_number_of_args_symbol,
	     set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args));
  len /= 2;
  if (len > sc->max_vector_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_4(sc, wrap_string(sc, "~S passed too many entries (> ~D ~D) (*s7* 'max-vector-length)", 62),
			 caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length)));
  {
    const 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 kp = args, vp = cdr(args); is_pair(kp); kp = cddr(kp), vp = cdr_unchecked(cdr(vp)))
	if (car(vp) != missing_key_value(sc))
	  hash_table_add(sc, table, car(kp), car(vp));
    return(table);
  }
}

static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \
That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled."
  #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T)
  return(g_hash_table_1(sc, args, sc->hash_table_symbol));
}

static s7_pointer g_hash_table_2(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer table = s7_make_hash_table(sc, sc->default_hash_table_length);
  if (cadr(args) != missing_key_value(sc)) /* #f default */
    hash_table_add(sc, table, car(args), cadr(args));
  return(table);
}


/* -------------------------------- weak-hash-table -------------------------------- */
static s7_pointer g_weak_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \
That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled."
  #define Q_weak_hash_table Q_hash_table

  const s7_pointer table = g_hash_table_1(sc, args, sc->weak_hash_table_symbol);
  set_weak_hash_table(table);
  weak_hash_iters(table) = 0;
  return(table);
}

static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  return((args == 2) ? sc->hash_table_2 : func);
}

static void check_old_table(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end)
{
  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;

  if (is_typed_hash_table(new_table))
    check_old_table(sc, old_table, new_table, start, end);

  old_lists = hash_table_elements(old_table);
  new_lists = hash_table_elements(new_table);

  if (hash_table_entries(new_table) == 0)
    {
      if ((start == 0) &&
	  ((s7_uint)end >= hash_table_entries(old_table)))
	{
	  if (old_len == hash_table_size(new_table))
	    {
	      for (s7_uint i = 0; i < old_len; i++)
		for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry))
		  {
		    hash_entry_t *p = (hash_entry_t *)mallocate_block(sc);
#if s7_Debugging
		    sc->blocks_mallocated[Block_List]++;
#endif
		    memcpy((void *)p, (const void *)entry, sizeof(block_t));
		    hash_entry_next(p) = new_lists[i];
		    new_lists[i] = p;
		  }}
	  else
	    for (s7_uint i = 0; i < old_len; i++)
	      for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry))
		{
		  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) = 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)
	      {
		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;
	      }
	    count++;
	  }
      hash_table_entries(new_table) = count - start;
      return(new_table);
    }
  /* this can't be optimized much because we have to look for key matches (we're copying old_table into the existing, non-empty new_table) */
  for (s7_uint i = 0; i < old_len; i++)
    for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry))
      {
	if (count >= end)
	  return(new_table);
	if (count >= start)
	  {
	    hash_entry_t *y = (*hash_table_checker(new_table))(sc, new_table, hash_entry_key(entry));
	    if (y != sc->unentry)
	      hash_entry_set_value(y, hash_entry_value(entry));
	    else
	      {
		const s7_uint loc = hash_entry_raw_hash(entry) % new_mask;
		hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry));
		hash_entry_next(p) = new_lists[loc];
		new_lists[loc] = p;
		hash_table_entries(new_table)++;
		if (!hash_chosen(new_table))
		  hash_table_set_default_checker(new_table, type(hash_entry_key(entry)));
	      }}
	count++;
      }
  return(new_table);
}

static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer table = car(args), val = cadr(args);
  if (is_immutable_hash_table(table))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->fill_symbol, table));

  if (hash_table_entries(table) > 0)
    {
      hash_entry_t **entries = hash_table_elements(table);
      const s7_int len = (s7_int)hash_table_size(table);   /* minimum len is 2 (see s7_make_hash_table) */
      if (val == missing_key_value(sc)) /* hash-table-ref returns #f (the default) if it can't find a key, so val == #f here means empty the table */
	{
	  hash_entry_t **hp = entries;
	  hash_entry_t **hn = (hash_entry_t **)(hp + len);
	  for (; hp < hn; hp++)
	    {
	      if (*hp)
		{
		  /* save top of entry list, go to end, point end->next at block_list top, reset top to entry_list top -> liberate entire list */
		  hash_entry_t *entry = *hp;
#if s7_Debugging
		  sc->blocks_freed[Block_List]++;
		  while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[Block_List]++;}
#else
		  while (hash_entry_next(entry)) entry = hash_entry_next(entry);
#endif
		  hash_entry_next(entry) = sc->block_lists[Block_List];
		  sc->block_lists[Block_List] = *hp;
		}
	      hp++;
	      if (*hp)
		{
		  hash_entry_t *entry = *hp;
#if s7_Debugging
		  sc->blocks_freed[Block_List]++;
		  while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[Block_List]++;}
#else
		  while (hash_entry_next(entry)) entry = hash_entry_next(entry);
#endif
		  hash_entry_next(entry) = sc->block_lists[Block_List];
		  sc->block_lists[Block_List] = *hp;
		}}
	  if (len >= 8)
	    memclr64(entries, len * sizeof(hash_entry_t *));
	  else memclr(entries, len * sizeof(hash_entry_t *));
	  if (hash_table_mapper(table) == default_hash_map)
	    {
	      hash_table_checker(table) = hash_empty;
	      hash_clear_chosen(table);
	    }
	  hash_table_entries(table) = 0;
	  return(val);
	}
      if ((is_typed_hash_table(table)) &&
	  (((is_c_function(hash_table_value_typer(table))) &&
	    (c_function_call(hash_table_value_typer(table))(sc, set_plist_1(sc, val)) == sc->F)) ||
	   ((is_any_closure(hash_table_value_typer(table))) &&
	    (s7_apply_function(sc, hash_table_value_typer(table), set_plist_1(sc, val)) == sc->F))))
	{
	  const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), Indefinite_Article);
	  wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr)));
	}
      for (s7_int i = 0; i < len; i++)
	for (hash_entry_t *entry = entries[i]; entry; entry = hash_entry_next(entry))
	  hash_entry_set_value(entry, val);
      /* keys haven't changed, so no need to mess with hash_table_checker */
    }
  return(val);
}

static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_table)
{
  const s7_int len = (s7_int)hash_table_size(old_table);
  hash_entry_t **old_lists = hash_table_elements(old_table);
  const s7_pointer new_table = s7_make_hash_table(sc, len);
  gc_protect_via_stack(sc, new_table);

  /* old_table checker/mapper functions don't always make sense reversed, although the key/value typers might be ok */
  for (s7_int i = 0; i < len; i++)
    for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry))
      s7_hash_table_set(sc, new_table, hash_entry_value(entry), hash_entry_key(entry));

  if (is_weak_hash_table(old_table)) /* 17-May-23, not sure it makes sense to reverse a weak-hash-table but... */
    {
      set_weak_hash_table(new_table);
      weak_hash_iters(new_table) = 0;
    }
  unstack_gc_protect(sc);
  return(new_table);
}


/* -------------------------------- functions -------------------------------- */

#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);}

bool s7_is_function(s7_pointer p) {return(is_c_function(p));}


/* -------------------------------- procedure? -------------------------------- */
bool s7_is_procedure(s7_pointer obj) {return(is_procedure(obj));}

static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args)
{
  #define H_is_procedure "(procedure? obj) returns #t if obj is a procedure"
  #define Q_is_procedure sc->pl_bt
  check_boolean_method(sc, is_procedure, sc->is_procedure_symbol, args);
}


/* -------------------------------- 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))
  const 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->unused); /* never hit */
}


/* -------------------------------- procedure-source -------------------------------- */
static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type)
{
  switch (type)
    {
    case T_CLOSURE:      return(sc->lambda_symbol);
    case T_CLOSURE_STAR: return(sc->lambda_star_symbol);
    case T_MACRO:        return(sc->macro_symbol);
    case T_MACRO_STAR:   return(sc->macro_star_symbol);
    case T_BACRO:        return(sc->bacro_symbol);
    case T_BACRO_STAR:   return(sc->bacro_star_symbol);
    default: if (s7_Debugging) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); /* break; ? */
    }
  return(sc->lambda_symbol);
}

static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_source "(procedure-source func) tries to return the definition of func"
  #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
  /* make it look like a scheme-level lambda */
  s7_pointer func = car(args);

  if ((is_symbol(func)) && ((func = s7_symbol_value(sc, func)) == sc->undefined))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), func));
  if ((is_c_function(func)) || (is_c_macro(func)))
    return(sc->nil);

  if_method_exists_return_value(sc, func, sc->procedure_source_symbol, set_plist_1(sc, func));
  if (has_closure_let(func))
    {
      const 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? */
}


/* -------------------------------- *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)"

  #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_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 (((is_procedure(let)) || (is_any_macro(let))) && (sym == sc->value_symbol))
	return(let);
    }
  if (!is_let(let))
    {
      const 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 (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);
  {
    const s7_pointer fname = funclet_function(let);
    const 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(sc->F);
}


/* -------------------------------- funclet -------------------------------- */
s7_pointer s7_funclet(s7_scheme *sc, s7_pointer func) {return((has_closure_let(func)) ? closure_let(func) : sc->rootlet);} /* c_function_let(func)?? */

static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args)
{
  #define H_funclet "(funclet func) tries to return a function's definition environment"
  #define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \
				      s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol))
  s7_pointer func = car(args);
  if (is_symbol(func))
    {
      if ((func = s7_symbol_value(sc, func)) == sc->undefined)
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not func here */
    }
  if_method_exists_return_value(sc, func, sc->funclet_symbol, args);
  if (!((is_any_procedure(func)) || (is_c_object(func))))
    sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, func, A_Procedure_Or_A_Macro_String);
  return(find_let(sc, func));
}


/* -------------------------------- s7_make_function, s7_define_function and friends --------------------------------
 *
 * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...)
 */

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 fallback_chooser(s7_scheme *unused_sc, s7_pointer func, int32_t unused_args, s7_pointer unused_expr) {return(func);}

s7_pointer s7_defun(s7_scheme *sc, const char *name, /* name=NULL gives anonymous func, return value not symbol */
		    s7_function f,
		    s7_int required_args, s7_int optional_args, bool rest_arg,
		    const char *doc,                 /* NULL for no doc */
		    s7_pointer signature,            /* NULL for no sig */
		    s7_pointer let,                  /* NULL for no definition in let */
		    s7_safety_t type)
{
  const s7_pointer func = (s7_pointer)alloc_pointer(sc);
  set_full_type(func, ((required_args == 0) && (rest_arg)) ? 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, (signature) ? T_Pair(signature) : sc->F); /* s7_make_signature returns a semipermanent list */
  c_function_min_args(func) = required_args;
  c_function_optional_args(func) = optional_args;    /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */
  c_function_max_args(func) = (rest_arg) ? MaxArity : required_args + optional_args;
  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, (let) ? let : sc->rootlet);
  /* this is not the same as the let in (let (...) (lambda ...)) and can't be used that way.  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.
   *   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.
   */
  unheap(func); /* else init_rootlet[101030]: not a c-function */
  if (type == s7_safe)
    set_type_bit(func, T_Safe_Procedure);
  else
    if (type == s7_semisafe)
      set_is_semisafe(func);
  if ((name) && (let))
    s7_define(sc, T_Let(let), c_function_symbol(func), func);
  return(func);
}

/* these s7_make_* and s7_define_* cases preceded s7_defun by many years, so this section is for convenience and backwards compatibility */

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)
{
  return(s7_defun(sc, name, f, required_args, optional_args, rest_arg, doc, NULL, NULL, s7_unsafe));
}

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)
{
  return(s7_defun(sc, name, f, required_args, optional_args, rest_arg, doc, NULL, NULL, s7_safe));
}

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)
{
  return(s7_defun(sc, name, f, required_args, optional_args, rest_arg, doc, signature, NULL, s7_safe));
}

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_defun(sc, name, f, required_args, optional_args, rest_arg, doc, signature, NULL, s7_safe);
  c_function_set_let(func, (let) ? let : sc->rootlet); /* not passed above so that 'name' is not defined in the let */
  return(func);
}

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_defun(sc, name, fnc, required_args, optional_args, rest_arg, doc, NULL, sc->rootlet, s7_unsafe);
  return(c_function_symbol(func)); /* truly ancient backwards compatibility */
}

s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer func = s7_defun(sc, name, fnc, required_args, optional_args, rest_arg, doc, NULL, sc->rootlet, s7_safe);
  return(c_function_symbol(func));
}

s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, /* same as above, but include signature */
				    s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature)
{
  s7_pointer func = s7_defun(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature, sc->rootlet, s7_safe);
  return(c_function_symbol(func));
}

s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg,
					   const char *doc, s7_pointer signature)
{
  s7_pointer func = s7_defun(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature, sc->rootlet, s7_unsafe);
  return(c_function_symbol(func));
}

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_defun(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature, sc->rootlet, s7_semisafe);
  return(c_function_symbol(func));
}

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, uint8_t category)
{
  const s7_pointer func = s7_defun(sc, name, fnc, 1, optional_args, false, doc, signature, sc->rootlet, s7_safe); /* 1 = required_args */
  const s7_pointer sym = T_Sym(c_function_symbol(func));
  symbol_set_type(sym, sym_to_type);
  symbol_set_category(sym, category);
  c_function_set_marker(func, marker);
  if (simple) c_function_set_has_simple_elements(func);
  {
    const s7_pointer bfunc = s7_defun(sc, name, bool_setter, 2, 0, false, NULL, NULL, NULL, s7_safe);
    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);
}

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, s7_Warn_Bufsize, "%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, s7_Warn_Bufsize, "%s :allow-other-keys should be the last parameter: %s\n", name, arglist);
		if (p == local_args)
		  s7_warn(sc, s7_Warn_Bufsize, "%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, s7_Warn_Bufsize, "%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)
{
  const 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)
{
  const s7_pointer func = (safe) ? s7_make_safe_function_star(sc, name, fnc, arglist, doc) : 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)
{
  const s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  const 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)
{
  const s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  const s7_pointer sym = T_Sym(c_function_symbol(func));
  set_full_type(func, T_C_MACRO | T_Expansion | T_Dont_Eval_Args | T_Unheap); /* s7_make_function includes T_Unheap */
  s7_define(sc, sc->rootlet, sym, func);
  set_full_type(sym, full_type(sym) | T_Expansion);
  return(sym);
}


/* -------------------------------- macro? -------------------------------- */
bool s7_is_macro(s7_scheme *sc, s7_pointer mac) {return(is_any_macro(mac));}
static bool is_macro_b(s7_pointer mac) {return(is_any_macro(mac));}

static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args)
{
  #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro"
  #define Q_is_macro sc->pl_bt
  check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args);
}


static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args);

static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args)
{
  int32_t arg_len;
  if (!s7_is_proper_list(sc, args))
    return(sc->F);
  arg_len = proper_list_length(args);
  if (!closure_is_aritable(sc, mac, closure_pars(mac), arg_len))
    return(sc->F);
  push_stack_direct(sc, OP_EVAL_DONE);
  sc->code = mac;
  sc->args = args;
  set_curlet(sc, make_let(sc, closure_let(sc->code)));
  eval(sc, OP_APPLY_LAMBDA); /* PERHAPS: could be apply_lambda unchecked */
  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));
    }
  /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */
  if_method_exists_return_value(sc, obj, sc->documentation_symbol, args);
  return(s7_make_string(sc, s7_documentation(sc, obj)));
}

const char *s7_set_documentation(s7_scheme *sc, s7_pointer sym, const char *new_doc)
{
  if (is_keyword(sym)) return(NULL);
  if (is_symbol(sym))
    {
      symbol_set_has_help(sym);
      symbol_set_help(sym, copy_string(new_doc));
      add_saved_pointer(sc, symbol_help(sym));
    }
  return(new_doc);
}


/* -------------------------------- help -------------------------------- */
const char *s7_help(s7_scheme *sc, s7_pointer obj)
{
  if (is_syntax(obj))
    return(syntax_documentation(obj));
  if (is_symbol(obj))
    {
      /* here look for name */
      if (s7_documentation(sc, obj))
	return(s7_documentation(sc, obj));
      obj = s7_symbol_value(sc, obj);
    }
  if (is_any_procedure(obj))
    return(s7_documentation(sc, obj));
  if (obj == sc->starlet)
    return("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)");
  /* if is string, apropos? (can scan symbol table) */
  return(NULL);
}

static s7_pointer g_help(s7_scheme *sc, s7_pointer args)
{
  #define H_help "(help obj) returns obj's documentation"
  #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->T)
  const char *doc;
  if_method_exists_return_value(sc, car(args), sc->help_symbol, args);
  doc = s7_help(sc, car(args));
  return((doc) ? s7_make_string(sc, doc) : sc->F);
}


/* -------------------------------- signature -------------------------------- */
static void init_signatures(s7_scheme *sc)
{
  sc->string_signature =       s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol);
  sc->byte_vector_signature =  s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol);
  sc->vector_signature =       s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol);
  sc->float_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol);
  sc->complex_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_complex_symbol, sc->is_complex_vector_symbol, sc->is_integer_symbol);
  sc->int_vector_signature =   s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol);
  sc->c_object_signature =     s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T);
  sc->let_signature =          s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol);
  sc->hash_table_signature =   s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T);
  sc->pair_signature =         s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol);
}

static s7_pointer g_signature(s7_scheme *sc, s7_pointer args)
{
  #define H_signature "(signature obj) returns obj's signature"
  #define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T)

  s7_pointer obj = car(args);
  switch (type(obj))
    {
    case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION:
    case T_C_FUNCTION_STAR: case T_C_MACRO:
      return((s7_pointer)c_function_signature(obj));

    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      {
	s7_pointer func = funclet_entry(sc, obj, sc->local_signature_symbol);
	if (func) return(func);
	func = funclet_entry(sc, obj, sc->signature_symbol);
	return((func) ? s7_apply_function(sc, func, args) : sc->F);
      }

    case T_VECTOR:
      if (vector_length(obj) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */
      if (!is_typed_vector(obj))
	return(sc->vector_signature);
      {
	s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, obj), sc->is_vector_symbol, sc->is_integer_symbol);
	set_cdddr(lst, cddr(lst));
	return(lst);
      }

    case T_FLOAT_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->float_vector_signature);
    case T_COMPLEX_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->complex_vector_signature);
    case T_INT_VECTOR:   return((vector_length(obj) == 0) ? sc->F : sc->int_vector_signature);
    case T_BYTE_VECTOR:  return((vector_length(obj) == 0) ? sc->F : sc->byte_vector_signature);
    case T_PAIR:         return(sc->pair_signature);
    case T_STRING:       return(sc->string_signature);

    case T_HASH_TABLE:
      if (is_typed_hash_table(obj))
	return(list_3(sc,
		      hash_table_typer_symbol(sc, hash_table_value_typer(obj)),
		      sc->is_hash_table_symbol,
		      hash_table_typer_symbol(sc, hash_table_key_typer(obj))));
      return(sc->hash_table_signature);

    case T_ITERATOR:
      obj = iterator_sequence(obj);
      if ((is_hash_table(obj)) || (is_let(obj)))   /* cons returned -- would be nice to include the car/cdr types if known */
	return(list_1(sc, sc->is_pair_symbol));
      obj = g_signature(sc, set_plist_1(sc, obj));
      return(list_1(sc, (is_pair(obj)) ? car(obj) : sc->T));

    case T_C_OBJECT:
      if_c_object_method_exists_return_value(sc, obj, sc->signature_symbol, args);
      return(sc->c_object_signature);

    case T_LET:
      if_let_method_exists_return_value(sc, obj, sc->signature_symbol, args);
      return(sc->let_signature);

    case T_SYMBOL:
      /* this used to get the symbol's value and call g_signature on that */
      {
	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;

    default: break;
    }
  return(sc->F);
}

s7_pointer s7_signature(s7_scheme *sc, s7_pointer func) {return(g_signature(sc, set_plist_1(sc, func)));}


/* -------------------------------- dynamic-wind -------------------------------- */
static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer body;
  if (!is_closure(obj)) return(obj);
  body = closure_body(obj);
  if (is_pair(cdr(body))) return(obj);
  if (!is_pair(car(body))) return(sc->F);
  return((is_quote(sc, caar(body))) ? sc->F : obj);
}

static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer old_func)
{
  /* for dynamic-wind to protect initial and final functions from call/cc */
  s7_pointer new_func = make_closure_unchecked(sc, sc->nil, closure_body(old_func), type(old_func), 0); /* always preceded by new dw cell */
  s7_pointer let = make_let(sc, closure_let(old_func)); /* let_outlet(let) = closure_let(old_func) */
  set_baffle_let(let);
  let_set_baffle_key(let, sc->baffle_ctr++);
  closure_set_let(new_func, let);
  return(new_func);
}

static bool is_dwind_thunk(s7_scheme *sc, s7_pointer obj)
{
  switch (type(obj))
    {
    case T_MACRO: case T_BACRO: case T_CLOSURE:
    case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR:
      return(is_null(closure_pars(obj)));    /* this case does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */
    case T_C_FUNCTION:
      return(c_function_is_aritable(obj, 0));
    case T_C_MACRO:
      return(c_macro_min_args(obj) == 0);
    case T_C_FUNCTION_STAR: case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION:
      return(true);
    }
  return(obj == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */
}

static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args)
{
  s7_pointer dw, init_func, final_func;

  new_cell(sc, dw, T_DYNAMIC_WIND);                          /* don't mark car/cdr, don't copy */
  dynamic_wind_in(dw) = closure_or_f(sc, car(args));
  dynamic_wind_body(dw) = cadr(args);
  dynamic_wind_out(dw) = closure_or_f(sc, caddr(args));
  push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw);             /* args will be the saved result, code = s7_dynwind_t obj */
                                                            /*   do this push_stack early to protect p from allocations in make_baffled_closure */
  init_func = dynamic_wind_in(dw);
  if ((is_any_closure(init_func)) && (!is_safe_closure(init_func))) /* wrap this use of init_func in a with-baffle */
    dynamic_wind_in(dw) = make_baffled_closure(sc, init_func);

  final_func = dynamic_wind_out(dw);
  if ((is_any_closure(final_func)) && (!is_safe_closure(final_func)))
    dynamic_wind_out(dw) = make_baffled_closure(sc, final_func);

  /* since we don't care about the in and out results, and they are thunks, if the body is not a pair,
   *   or is a quoted thing, we just ignore that function.
   */
  if (init_func != sc->F)
    {
      dynamic_wind_state(dw) = Dwind_Init;
      push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw));
    }
  else
    {
      dynamic_wind_state(dw) = Dwind_Body;
      push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(dw));
    }
  return(sc->F);
}

static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args)
{
  s7_pointer dw;
  const s7_pointer init_func = closure_or_f(sc, car(args));
  new_cell(sc, dw, T_DYNAMIC_WIND);                          /* don't mark car/cdr, don't copy */
  dynamic_wind_in(dw) = init_func;
  dynamic_wind_body(dw) = cadr(args);
  dynamic_wind_out(dw) = sc->F;
  if ((is_any_closure(init_func)) && (!is_safe_closure(init_func)))    /* wrap this use of init_func in a with-baffle */
    dynamic_wind_in(dw) = make_baffled_closure(sc, init_func);
  push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw);             /* args will be the saved result, code = s7_dynwind_t obj */
  dynamic_wind_state(dw) = Dwind_Init;
  push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw));
  return(sc->F);
}

static s7_pointer g_dynamic_wind_body(s7_scheme *sc, s7_pointer args)
{
  push_stack(sc, OP_APPLY, sc->nil, cadr(args));
  return(sc->F);
}

static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args)
{
  #define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \
each a function of no arguments, guaranteeing that finish is called even if body is exited"
  #define Q_dynamic_wind s7_make_signature(sc, 4, sc->values_symbol, \
                           s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol), \
                           sc->is_procedure_symbol, \
                           s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol))

  if (!is_dwind_thunk(sc, car(args)))
    return(method_or_bust(sc, car(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 1));
  if (!is_thunk(sc, cadr(args)))
    return(method_or_bust(sc, cadr(args), sc->dynamic_wind_symbol, args, A_Thunk_String, 2));
  if (!is_dwind_thunk(sc, caddr(args)))
    return(method_or_bust(sc, caddr(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 3));

  /* this won't work:
       (let ((final (lambda (a b c) (list a b c))))
         (dynamic-wind
           (lambda () #f)
           (lambda () (set! final (lambda () (display "in final"))))
           final))
   * but why not?  'final' is a thunk by the time it is evaluated. catch (the error handler) is similar.
   * It can't work here because we set up the dynamic_wind_out slot below and
   *   even if the thunk check was removed, we'd still be trying to apply the original function.
   */
  return(g_dynamic_wind_unchecked(sc, args));
}

static bool is_lambda(s7_scheme *sc, s7_pointer sym)
{
  return((sym == sc->lambda_symbol) && (is_global(sym))); /* do we need (!sc->in_with_let) ? */
}

static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynamic_wind_chooser */
{
  /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */
  if (arg == sc->F) return(3);
  if ((is_pair(arg)) &&
      (is_lambda(sc, car(arg))) &&
      (is_pair(cdr(arg))) &&
      (is_null(cadr(arg))) && /* (lambda () ...) */
      (is_pair(cddr(arg))) &&
      (s7_is_proper_list(sc, cddr(arg))))
    return(((is_null(cdddr(arg))) && (caddr(arg) == sc->F)) ? 2 : 1); /* 2: (lambda () #f) */
  return(0);
}

static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr)
{
  if ((args == 3) &&
      (is_ok_thunk(sc, caddr(expr))))
    {
      int32_t init = is_ok_thunk(sc, cadr(expr));
      int32_t end = is_ok_thunk(sc, cadddr(expr));
      if ((init > 1) && (end > 1)) return(sc->dynamic_wind_body);
      if ((init > 0) && (end > 1)) return(sc->dynamic_wind_init);
      if ((init > 0) && (end > 0)) return(sc->dynamic_wind_unchecked);
    }
  return(func);
}

s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish)
{
  /* this is essentially s7_call with a dynamic-wind wrapper around "body" */
  declare_jump_info();
  store_jump_info(sc);
  set_jump_info(sc, Dynamic_Wind_Set_Jump);
  if (jump_loc != No_Jump)
    {
      if (jump_loc != Error_Jump)
	eval(sc, sc->cur_op);
    }
  else
    {
      s7_pointer dw;
      push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */
      sc->args = sc->nil;
      new_cell(sc, dw, T_DYNAMIC_WIND);
      dynamic_wind_in(dw) = T_Ext(init);
      dynamic_wind_body(dw) = T_Ext(body);
      dynamic_wind_out(dw) = T_Ext(finish);
      push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw);
      if (init != sc->F)
	{
	  dynamic_wind_state(dw) = Dwind_Init;
	  sc->code = init;
	}
      else
	{
	  dynamic_wind_state(dw) = Dwind_Body;
	  sc->code = body;
	}
      eval(sc, OP_APPLY);
    }
  restore_jump_info(sc);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
  return(sc->value);
}

static void op_unwind_output(s7_scheme *sc)
{
  const bool is_file = is_file_port(sc->code);
  if ((is_output_port(sc->code)) &&
      (!port_is_closed(sc->code)))
    s7_close_output_port(sc, sc->code); /* may call fflush */
  if (((is_output_port(sc->args)) &&
       (!port_is_closed(sc->args))) ||
      (sc->args == sc->F))
    set_current_output_port(sc, sc->args);
  if ((is_file) &&
      (is_multiple_value(sc->value)))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

static void op_unwind_input(s7_scheme *sc)
{
  /* sc->code is an input port */
  if (!port_is_closed(sc->code))
    s7_close_input_port(sc, sc->code);
  if ((is_input_port(sc->args)) &&
      (!port_is_closed(sc->args)))
    set_current_input_port(sc, sc->args);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

static bool op_dynamic_wind(s7_scheme *sc)
{
  const s7_pointer dwind = T_Dyn(sc->code);
  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display_truncated(dwind));
  if (dynamic_wind_state(dwind) == Dwind_Init)
    {
      dynamic_wind_state(dwind) = Dwind_Body;
      push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dwind);
      sc->code = dynamic_wind_body(dwind);
      sc->args = sc->nil;
      return(true); /* goto Apply */
    }
  if (dynamic_wind_state(dwind) == Dwind_Body)
    {
      dynamic_wind_state(dwind) = Dwind_Finish;
      if (dynamic_wind_out(dwind) != sc->F)
	{
	  push_stack(sc, OP_DYNAMIC_WIND, sc->value, dwind);
	  sc->code = dynamic_wind_out(dwind);
	  sc->args = sc->nil;
	  return(true);
	}
      if (is_multiple_value(sc->value))
	sc->value = splice_in_values(sc, multiple_value(sc->value));
      return(false); /* goto Start */
    }
  if (is_multiple_value(sc->args))       /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */
    sc->value = splice_in_values(sc, multiple_value(sc->args));
  else sc->value = sc->args;             /* value saved above */
  return(false);
}


/* -------------------------------- c-object? -------------------------------- */
bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));}

static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args)
{
  #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object."
  #define Q_is_c_object sc->pl_bt
  const s7_pointer obj = car(args);
  if (is_c_object(obj)) return(sc->T);
  if (!has_active_methods(sc, obj)) return(sc->F);
  return(apply_boolean_method(sc, obj, sc->is_c_object_symbol));
}

static no_return void apply_error_nr(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  error_nr(sc, sc->syntax_error_symbol,
	   set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~S?", 29),
		       (is_null(obj)) ? wrap_string(sc, "nil", 3) : ((is_symbol_and_keyword(obj)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, obj)),
		       obj,
		       set_ulist_1(sc, obj, args))); /* was current_code(sc) which is unreliable */
}

static void fallback_free(void *unused_value) {}
static void fallback_mark(void *unused_value) {}

static s7_pointer fallback_ref(s7_scheme *sc, s7_pointer args) {apply_error_nr(sc, car(args), cdr(args)); return(NULL);}
static s7_pointer fallback_set(s7_scheme *sc, s7_pointer args) {syntax_error_nr(sc, "attempt to set ~S?", 18, car(args)); return(NULL);}
static s7_pointer fallback_length(s7_scheme *sc, s7_pointer unused_obj) {return(sc->F);}


/* -------------------------------- c-object-type -------------------------------- */
s7_int s7_c_object_type(s7_pointer obj) {return((is_c_object(obj)) ? c_object_type(obj) : -1);}

static s7_pointer g_c_object_type(s7_scheme *sc, s7_pointer args)
{
  #define H_c_object_type "(c-object-type obj) returns the c_object's type tag."
  #define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol)

  const s7_pointer cobj = car(args);
  if (!is_c_object(cobj))
    {
      if (!has_active_methods(sc, cobj))
	sole_arg_wrong_type_error_nr(sc, sc->c_object_type_symbol, cobj, sc->type_names[T_C_OBJECT]);
      return(find_and_apply_method(sc, cobj, sc->c_object_type_symbol, args));
    }
  return(make_integer(sc, c_object_type(cobj))); /* this is the c_object_types table index = tag */
}

s7_int s7_make_c_type(s7_scheme *sc, const char *name) /* shouldn't this be s7_make_c_object_type? */
{
  c_object_t *c_type;
  const s7_int tag = sc->num_c_object_types++;
  if (tag >= sc->c_object_types_size)
    {
      if (sc->c_object_types_size == 0)
	{
	  sc->c_object_types_size = 8;
	  sc->c_object_types = (c_object_t **)Calloc(sc->c_object_types_size, sizeof(c_object_t *));
	}
      else
	{
	  sc->c_object_types_size = tag * 2;
	  sc->c_object_types = (c_object_t **)Realloc((void *)(sc->c_object_types), sc->c_object_types_size * sizeof(c_object_t *));
	}}
  c_type = (c_object_t *)Calloc(1, sizeof(c_object_t)); /* Malloc+field=NULL is slightly faster here */
  sc->c_object_types[tag] = c_type;
  c_type->type = tag;
  c_type->scheme_name = make_permanent_string(name, safe_strlen(name));
  c_type->getter = sc->F;
  c_type->setter = sc->F;
  c_type->free = fallback_free;
  c_type->mark = fallback_mark;
  c_type->ref = fallback_ref;
  c_type->set = fallback_set;
  c_type->outer_type = T_C_OBJECT;
  c_type->length = fallback_length;
  /* all other fields are NULL */
  return(tag);
}

void s7_c_type_set_gc_free(s7_scheme *sc, s7_int tag, s7_pointer (*gc_free)(s7_scheme *sc, s7_pointer obj))      {sc->c_object_types[tag]->gc_free = gc_free;}
void s7_c_type_set_gc_mark(s7_scheme *sc, s7_int tag, s7_pointer (*marker)(s7_scheme *sc, s7_pointer obj))       {sc->c_object_types[tag]->gc_mark = marker;}
void s7_c_type_set_is_equal(s7_scheme *sc, s7_int tag, s7_pointer (*is_equal)(s7_scheme *sc, s7_pointer args))   {sc->c_object_types[tag]->equal = is_equal;}
void s7_c_type_set_copy(s7_scheme *sc, s7_int tag, s7_pointer (*copy)(s7_scheme *sc, s7_pointer args))           {sc->c_object_types[tag]->copy = copy;}
void s7_c_type_set_fill(s7_scheme *sc, s7_int tag, s7_pointer (*fill)(s7_scheme *sc, s7_pointer args))           {sc->c_object_types[tag]->fill = fill;}
void s7_c_type_set_reverse(s7_scheme *sc, s7_int tag, s7_pointer (*reverse)(s7_scheme *sc, s7_pointer args))     {sc->c_object_types[tag]->reverse = reverse;}
void s7_c_type_set_to_list(s7_scheme *sc, s7_int tag, s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args))     {sc->c_object_types[tag]->to_list = to_list;}
void s7_c_type_set_to_string(s7_scheme *sc, s7_int tag, s7_pointer (*to_string)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_string = to_string;}

void s7_c_type_set_length(s7_scheme *sc, s7_int tag, s7_pointer (*length)(s7_scheme *sc, s7_pointer args))
{
  sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */
}

void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args))
{
  sc->c_object_types[tag]->equivalent = is_equivalent;
}

/* the next three functions would ideally be deprecated, but much old code depends on them (they were accidentally documented forever) */
void s7_c_type_set_equal(s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2))
{
  sc->c_object_types[tag]->eql = equal;
}

void s7_c_type_set_free(s7_scheme *sc, s7_int tag, void (*gc_free)(void *value))
{
  sc->c_object_types[tag]->free = (gc_free) ? gc_free : fallback_free;
}

void s7_c_type_set_mark(s7_scheme *sc, s7_int tag, void (*mark)(void *value))
{
  sc->c_object_types[tag]->mark = (mark) ? mark : fallback_mark;
}

void s7_c_type_set_ref(s7_scheme *sc, s7_int tag, s7_pointer (*ref)(s7_scheme *sc, s7_pointer args))
{
  sc->c_object_types[tag]->ref = (ref) ? ref : fallback_ref;
  sc->c_object_types[tag]->outer_type = (sc->c_object_types[tag]->ref == fallback_ref) ? T_C_OBJECT : (T_C_OBJECT | T_Safe_Procedure);
}

void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter)
{
  sc->c_object_types[tag]->getter = (getter) ? T_Fnc(getter) : sc->F;
}

void s7_c_type_set_set(s7_scheme *sc, s7_int tag, s7_pointer (*set)(s7_scheme *sc, s7_pointer args))
{
  sc->c_object_types[tag]->set = (set) ? set : fallback_set;
}

void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter)
{
  sc->c_object_types[tag]->setter = (setter) ? T_Fnc(setter) : sc->F;
}


/* -------------------------------- c-object-let -------------------------------- */
s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));}

static s7_pointer g_c_object_let(s7_scheme *sc, s7_pointer args)
{
  #define H_c_object_let "(c-object-let obj) returns the c_object's local let, if any."
  #define Q_c_object_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_c_object_symbol)

  const s7_pointer cobj = car(args);
  if (!is_c_object(cobj))
    {
      if (!has_active_methods(sc, cobj))
	sole_arg_wrong_type_error_nr(sc, sc->c_object_let_symbol, cobj, sc->type_names[T_C_OBJECT]);
      return(find_and_apply_method(sc, cobj, sc->c_object_let_symbol, args));
    }
  return(c_object_let(cobj));
}

s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer 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, "#<c-object-set-let>", 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 */
{
  const 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_set_value(s7_pointer obj, void *value) {c_object_value(obj) = value; return(value);}

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);
}

#define With_GC true
#define Without_GC false

static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let, bool with_gc)
{
  s7_pointer obj;
  new_cell(sc, obj, sc->c_object_types[type]->outer_type);
  /* c_object_info(obj) = &(sc->c_object_types[type]); */
  /* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc
   *   and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's!
   * Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code.
   */
  c_object_type(obj) = type;
  c_object_value(obj) = value;
  c_object_set_let(obj, T_Let(let));
  c_object_sc(obj) = sc;
  if (with_gc) add_c_object(sc, obj);
  return(obj);
}

s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let)
{
  return(make_c_object_with_let(sc, type, value, let, With_GC));
}

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, With_GC));
}

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, Without_GC));
}

static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj)
{
  return((*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)));
}

static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj)
{
  const s7_pointer result = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj));
  if (s7_is_integer(result))
    return(s7_integer_clamped_if_gmp(sc, result));
  return(-1);
}

static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args)
{
  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_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj)
{
  const s7_int type = c_object_type(cobj);
  c_object_t *c_type = sc->c_object_types[type];
  return(internal_inlet(sc, 6,
			sc->name_symbol, c_type->scheme_name,
			make_symbol(sc, "getter", 6), s7_object_to_string(sc, c_type->getter, false),
			sc->setter_symbol, s7_object_to_string(sc, c_type->setter, false)));
  /* can't display equal et al in c_types -- maybe sc->F or the pointer? or add getter equivalent fields for equal et al? */
}

static void apply_c_object(s7_scheme *sc)  /* -------- applicable c_object -------- */
{
  sc->value = (*(c_object_ref(sc, sc->code)))(sc, set_ulist_1(sc, sc->code, sc->args));
  set_car(sc->u1_1, sc->F);
}

static bool op_implicit_c_object_ref_a(s7_scheme *sc)
{
  const s7_pointer cobj = lookup_checked(sc, car(sc->code));
  if (!is_c_object(cobj)) {sc->last_function = cobj; return(false);}
  set_car(sc->t2_2, fx_call(sc, cdr(sc->code)));
  set_car(sc->t2_1, cobj);        /* fx_call above might use sc->t2* */
  sc->value = (*(c_object_ref(sc, cobj)))(sc, sc->t2_1);
  return(true);
}

static s7_pointer fx_implicit_c_object_ref_a(s7_scheme *sc, s7_pointer arg)
{
  const s7_pointer cobj = lookup_checked(sc, car(arg));
  if (!is_c_object(cobj))
    return(s7_apply_function(sc, cobj, set_mlist_1(sc, fx_call(sc, cdr(arg)))));
  set_car(sc->t2_2, fx_call(sc, cdr(arg)));
  set_car(sc->t2_1, cobj);        /* fx_call above might use sc->t2* */
  return((*(c_object_ref(sc, cobj)))(sc, sc->t2_1));
}

/* We could add implicit c-pointer ref/set referring to its let, but that seems confusing -- c-object-ref|set! would be different */


/* -------- dilambda -------- */

s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer 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, "#<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)
{
  const s7_pointer get_func = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation);
  const s7_pointer set_func = c_function_setter(get_func);
  if (get_sig) c_function_set_signature(get_func, get_sig);
  if (set_sig) c_function_set_signature(set_func, set_sig);
  return(get_func);
}


/* -------------------------------- dilambda? -------------------------------- */
bool s7_is_dilambda(s7_pointer func)
{
  if (has_closure_let(func))
    return(is_any_procedure(closure_setter_or_map_list(func))); /* type >= T_CLOSURE (excludes goto/continuation) */
  if (is_any_c_function(func))
    return(is_any_procedure(c_function_setter(func)));          /* type >= T_C_FUNCTION_STAR */
  if (is_c_macro(func))
    return(is_any_procedure(c_macro_setter(func)));
  return(false);
}

static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args)
{
  #define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter."
  #define Q_is_dilambda sc->pl_bt
  check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args);
}


/* -------------------------------- dilambda -------------------------------- */
static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args)
{
  #define H_dilambda "(dilambda getter setter) sets getter's setter to be setter."
  #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol)

  const s7_pointer getter = car(args), setter = cadr(args);
  if (!is_any_procedure(getter))
    wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, A_Procedure_Or_A_Macro_String);
  if (!is_any_procedure(setter))
    wrong_type_error_nr(sc, sc->dilambda_symbol, 2, setter, A_Procedure_Or_A_Macro_String);

  s7_set_setter(sc, getter, setter);
  return(getter);
}


/* -------------------------------- arity -------------------------------- */
static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args)
{
  /* clo_args is unprocessed -- it is exactly the list as used in the closure[*] definition */
  int32_t len;
  if (is_symbol(clo_args))                  /* any number of args is ok */
    return(cons(sc, Int_Zero, Max_Arity));
  if (closure_arity_unknown(clo))
    closure_set_arity(clo, s7_list_length(sc, clo_args));
  len = closure_arity(clo);
  if (len < 0)                              /* dotted list => rest arg, (length '(a b . c)) is -2 */
    return(cons(sc, make_integer(sc, -len), Max_Arity));
  return(cons(sc, make_integer(sc, len), make_integer_unchecked(sc, len)));
}

static void closure_star_arity_1(s7_scheme *sc, s7_pointer clo, s7_pointer args)
{
  if (closure_arity_unknown(clo))
    {
      if (is_null(args))
	closure_set_arity(clo, 0);
      else
	if ((is_symbol(args)) || (allows_other_keys(args)))
	  closure_set_arity(clo, -1);
	else
	  {
	    s7_pointer pars;
	    int32_t i;
	    for (i = 0, pars = args; is_pair(pars); i++, pars = cdr(pars)) /* is_pair(pars) so (f1 a . b) will end with b not null */
	      if (car(pars) == sc->rest_keyword)
		break;
	    closure_set_arity(clo, ((is_null(pars)) ? i : -1));  /* see below */
	  }}
}

static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args)
{
  closure_star_arity_1(sc, clo, clo_args);
  return((closure_arity(clo) == -1) ? cons(sc, Int_Zero, Max_Arity) : cons(sc, Int_Zero, make_integer(sc, closure_arity(clo))));
}

static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer clo)
{
  /* not lambda* here */
  if (closure_arity_unknown(clo))
    {
      int32_t i;
      s7_pointer pars = closure_pars(clo);
      for (i = 0; is_pair(pars); i++, pars = cdr(pars)) {};
      if (is_null(pars))
	closure_set_arity(clo, i);
      else
	{
	  if (i == 0)
	    return(-1);
	  closure_set_arity(clo, -i);
	}}
  return(closure_arity(clo));
}

static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer clo)
{
  /* not lambda here */
  closure_star_arity_1(sc, clo, closure_pars(clo));
  return(closure_arity(clo));
}

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) == MaxArity) ? 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);
}

static s7_pointer g_arity(s7_scheme *sc, s7_pointer args) /* arity-uncopied could use sc->ulist */
{
  #define H_arity "(arity obj) the min and max number of args that obj can be applied to.  Returns #f if the object is not applicable."
  #define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T)
  if_method_exists_return_value(sc, car(args), sc->arity_symbol, args);
  return(s7_arity(sc, car(args)));
}


/* -------------------------------- aritable? -------------------------------- */
static bool closure_is_aritable(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args, int32_t args)
{
  /* clo_args is unprocessed -- it is exactly the list as used in the closure definition */
  s7_int len;
  if (args == 0) return(!is_pair(clo_args));
  if (is_symbol(clo_args)) return(true); /* any number of args is ok */
  len = closure_arity(clo);
  if (len == Closure_Arity_Not_Set)
    {
      len = s7_list_length(sc, clo_args);
      closure_set_arity(clo, len);
    }
  if (len < 0)                          /* dotted list => rest arg, (length '(a b . c)) is -2 */
    return((-len) <= args);             /*   so we have enough to take care of the required args */
  return(args == len);                  /* in a normal lambda list, there are no other possibilities */
}

static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args, int32_t args)
{
  if (is_symbol(clo_args))
    return(true);
  closure_star_arity_1(sc, clo, clo_args);
  return((closure_arity(clo) == -1) || (args <= closure_arity(clo)));
}

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)

  const 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 > MaxArity) num = MaxArity;
  return(make_boolean(sc, s7_is_aritable(sc, car(args), num)));
}

static bool is_aritable_b_7pp(s7_scheme *sc, s7_pointer func, s7_pointer num_args) {return(g_is_aritable(sc, set_plist_2(sc, func, num_args)) != sc->F);}

static int32_t arity_to_int(s7_scheme *sc, s7_pointer clo)
{
  int32_t args;
  switch (type(clo))
    {
    case T_C_FUNCTION: case T_C_FUNCTION_STAR:  return(c_function_max_args(clo));
    case T_C_RST_NO_REQ_FUNCTION:               return(MaxArity);
    case T_CLOSURE:
    case T_MACRO: case T_BACRO:                 args = closure_arity_to_int(sc, clo); return((args < 0) ? MaxArity : args);
    case T_CLOSURE_STAR:
    case T_MACRO_STAR: case T_BACRO_STAR:       args = closure_star_arity_to_int(sc, clo);  return((args < 0) ? MaxArity : args);
    case T_C_MACRO:                             return(c_macro_max_args(clo));
    case T_GOTO: case T_CONTINUATION:           return(MaxArity);
    /* case T_C_OBJECT: return(MaxArity); */
    }
  /* if (s7_Debugging) fprintf(stderr, "%s -1 %s\n", __func__, display(clo)); */
  return(-1);
}


/* -------------------------------- sequence? -------------------------------- */
static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args)
{
  #define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)"
  #define Q_is_sequence sc->pl_bt
  /* is_simple_sequence includes T_LET, so check_boolean_method will never call a method */
  const s7_pointer seq = car(args);
  s7_pointer func;
  if (!has_active_methods(sc, seq))
    return(make_boolean(sc, is_simple_sequence(seq)));
  func = find_method_with_let(sc, seq, sc->is_sequence_symbol);
  if (func == sc->undefined)
    return(make_boolean(sc, is_simple_sequence(seq)));
  return(s7_apply_function(sc, func, set_mlist_1(sc, seq)));
}

static bool is_sequence_b(s7_pointer seq) {return(is_simple_sequence(seq));}


/* -------------------------------- setter ------------------------------------------------ */
static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) /* see bool_defun -> define_bool_function */
{
  if (type(cadr(args)) != typer)
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34),
			 car(args), cadr(args), sc->type_names[type(cadr(args))], sc->type_names[typer]));
  return(cadr(args));
}

/* these are for the simplified setter designation: (let ((x 1)) (set! (setter 'x) integer?) (set! x 3.14)) -> error */

static s7_pointer b_is_boolean_setter(s7_scheme *sc, s7_pointer args)      {return(b_simple_setter(sc, T_BOOLEAN, args));}
static s7_pointer b_is_byte_vector_setter(s7_scheme *sc, s7_pointer args)  {return(b_simple_setter(sc, T_BYTE_VECTOR, args));}
static s7_pointer b_is_c_object_setter(s7_scheme *sc, s7_pointer args)     {return(b_simple_setter(sc, T_C_OBJECT, args));}
static s7_pointer b_is_c_pointer_setter(s7_scheme *sc, s7_pointer args)    {return(b_simple_setter(sc, T_C_POINTER, args));}
static s7_pointer b_is_char_setter(s7_scheme *sc, s7_pointer args)         {return(b_simple_setter(sc, T_CHARACTER, args));}
static s7_pointer b_is_continuation_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CONTINUATION, args));}
static s7_pointer b_is_eof_object_setter(s7_scheme *sc, s7_pointer args)   {return(b_simple_setter(sc, T_EOF, args));}
static s7_pointer b_is_float_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_FLOAT_VECTOR, args));}
static s7_pointer b_is_complex_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_COMPLEX_VECTOR, args));}
static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args)         {return(b_simple_setter(sc, T_GOTO, args));}
static s7_pointer b_is_hash_table_setter(s7_scheme *sc, s7_pointer args)   {return(b_simple_setter(sc, T_HASH_TABLE, args));}
static s7_pointer b_is_input_port_setter(s7_scheme *sc, s7_pointer args)   {return(b_simple_setter(sc, T_INPUT_PORT, args));}
static s7_pointer b_is_int_vector_setter(s7_scheme *sc, s7_pointer args)   {return(b_simple_setter(sc, T_INT_VECTOR, args));}
static s7_pointer b_is_iterator_setter(s7_scheme *sc, s7_pointer args)     {return(b_simple_setter(sc, T_ITERATOR, args));}
static s7_pointer b_is_let_setter(s7_scheme *sc, s7_pointer args)          {return(b_simple_setter(sc, T_LET, args));}
static s7_pointer b_is_null_setter(s7_scheme *sc, s7_pointer args)         {return(b_simple_setter(sc, T_NIL, args));}
static s7_pointer b_is_output_port_setter(s7_scheme *sc, s7_pointer args)  {return(b_simple_setter(sc, T_OUTPUT_PORT, args));}
static s7_pointer b_is_pair_setter(s7_scheme *sc, s7_pointer args)         {return(b_simple_setter(sc, T_PAIR, args));}
static s7_pointer b_is_random_state_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_RANDOM_STATE, args));}
static s7_pointer b_is_string_setter(s7_scheme *sc, s7_pointer args)       {return(b_simple_setter(sc, T_STRING, args));}
static s7_pointer b_is_symbol_setter(s7_scheme *sc, s7_pointer args)       {return(b_simple_setter(sc, T_SYMBOL, args));}
static s7_pointer b_is_syntax_setter(s7_scheme *sc, s7_pointer args)       {return(b_simple_setter(sc, T_SYNTAX, args));}
static s7_pointer b_is_undefined_setter(s7_scheme *sc, s7_pointer args)    {return(b_simple_setter(sc, T_UNDEFINED, args));}
static s7_pointer b_is_unspecified_setter(s7_scheme *sc, s7_pointer args)  {return(b_simple_setter(sc, T_UNSPECIFIED, args));}

#define b_setter(Sc, Typer, Args, Str, Len)	\
  do {						\
    if (!Typer(cadr(Args)))			\
      error_nr(Sc, Sc->wrong_type_arg_symbol,			\
	       set_elist_5(Sc, wrap_string(Sc, "set! ~S, ~S is ~A but should be ~A", 34), \
			   car(Args), cadr(Args), Sc->type_names[type(cadr(Args))], wrap_string(Sc, Str, Len))); \
    return(cadr(Args));							\
  } while (0)

static s7_pointer b_is_byte_setter(s7_scheme *sc, s7_pointer args)        {b_setter(sc, is_byte, args, "an unsigned byte", 16);}
static s7_pointer b_is_complex_setter(s7_scheme *sc, s7_pointer args)     {b_setter(sc, s7_is_complex, args, "a number", 8);}
static s7_pointer b_is_dilambda_setter(s7_scheme *sc, s7_pointer args)    {b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);}
static s7_pointer b_is_float_setter(s7_scheme *sc, s7_pointer args)       {b_setter(sc, is_t_real, args, "a float", 7);}
static s7_pointer b_is_gensym_setter(s7_scheme *sc, s7_pointer args)      {b_setter(sc, is_gensym, args, "a gensym", 8);}
static s7_pointer b_is_integer_setter(s7_scheme *sc, s7_pointer args)     {b_setter(sc, s7_is_integer, args, "an integer", 10);}
static s7_pointer b_is_keyword_setter(s7_scheme *sc, s7_pointer args)     {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);}
static s7_pointer b_is_list_setter(s7_scheme *sc, s7_pointer args)        {b_setter(sc, is_list, args, "a list", 6);}
static s7_pointer b_is_macro_setter(s7_scheme *sc, s7_pointer args)       {b_setter(sc, is_any_macro, args, "a macro", 7);}
static s7_pointer b_is_number_setter(s7_scheme *sc, s7_pointer args)      {b_setter(sc, s7_is_complex, args, "a number", 8);}
static s7_pointer b_is_openlet_setter(s7_scheme *sc, s7_pointer args)     {b_setter(sc, has_methods, args, "an open let", 11);}
static s7_pointer b_is_procedure_setter(s7_scheme *sc, s7_pointer args)   {b_setter(sc, is_any_procedure, args, "a procedure", 11);}
static s7_pointer b_is_rational_setter(s7_scheme *sc, s7_pointer args)    {b_setter(sc, is_rational, args, "a rational", 10);}
static s7_pointer b_is_real_setter(s7_scheme *sc, s7_pointer args)        {b_setter(sc, is_real, args, "a real", 6);}
static s7_pointer b_is_sequence_setter(s7_scheme *sc, s7_pointer args)    {b_setter(sc, is_sequence, args, "a sequence", 10);}
static s7_pointer b_is_subvector_setter(s7_scheme *sc, s7_pointer args)   {b_setter(sc, is_subvector, args, "a subvector", 11);}
static s7_pointer b_is_vector_setter(s7_scheme *sc, s7_pointer args)      {b_setter(sc, is_any_vector, args, "a vector", 8);}
static s7_pointer b_is_weak_hash_table_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17);}

static s7_pointer b_is_proper_list_setter(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_proper_list(sc, car(args)))
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34),
			 car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13)));
  return(cadr(args));
}

static s7_pointer lambda_setter(s7_scheme *sc, s7_pointer clo)
{
  if (is_any_procedure(closure_setter_or_map_list(clo)))        /* setter already known */
    return(closure_setter(clo));
  if (is_pair(closure_setter_or_map_list(clo)))  /* it's a map_list masquerading as a setter */
    return(sc->F);
  if (!closure_no_setter(clo))
    {
      const s7_pointer setter = funclet_entry(sc, clo, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(clo) */
      if (setter)
	{
	  if (setter == sc->F)
	    {
	      closure_set_no_setter(clo);
	      return(sc->F);
	    }
	  if (!is_any_procedure(setter))
	    sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, clo, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45));
	  closure_set_setter(clo, setter);
	  return(setter);
	}
      /* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */
      closure_set_no_setter(clo);
    }
  return(sc->F);
}

static s7_pointer symbol_to_slot_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
    {
      const 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);
  }
}

static s7_pointer macro_setter_p_pp(s7_scheme *sc, s7_pointer obj)
{
  if (is_c_macro((obj))) return(c_macro_setter(obj));
  if ((is_any_closure(obj)) || (is_any_macro(obj))) return(closure_setter(obj));
  if (is_c_function(obj)) return(c_function_setter(obj));
  return(NULL);
}

static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer let)
{
  if (!is_let(let))
    {
      const 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);

      /* here perhaps an immutable object should return #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_to_slot_setter(sc, obj, let));
    }
  /* wrong_type_error_nr(sc, sc->setter_symbol, 1, obj, wrap_string(sc, "something that might have a setter", 34)); */ /* this seems unfriendly */
  return(sc->F);
}

static s7_pointer g_setter(s7_scheme *sc, s7_pointer args)
{
  #define H_setter "(setter obj let) returns the setter associated with obj"
  #define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->T, has_let_signature(sc))
  return(setter_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->curlet));
}

s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, sc->curlet));}

static s7_pointer g_restore_setter(s7_scheme *unused_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;
  }
}

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) #<lambda (s v ...)>) */
      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 #<lambda (s v)>) */
      func = cadr(args);
    }
  if (!is_slot(slot))
    return(sc->F);

  if (func != sc->F)
    {
      if (sym == sc->setter_symbol)
	immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func));
      if (is_syntax_or_qq(slot_value(slot)))         /* (set! (setter 'begin) ...), qq is syntax sez r7rs */
	immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func));
      if (!is_any_procedure(func))                   /* 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)
    set_slot_has_setter(slot);
  else clear_slot_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)
    {
      s7_int setter_arity;
      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));
      setter_arity = arity_to_int(sc, setter);
      if ((setter_arity <= arity_to_int(sc, obj)) &&    /* we need at least an arg for the set! value, but these are max argn? */
	  (setter_arity != integer(Max_Arity)))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take one more argument than its target", 66), 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)
	{
	  set_slot_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);
	}
      clear_slot_has_setter(global_slot(obj));
      slot_set_setter(global_slot(obj), sc->F);
      return(sc->F);
    }
  return(g_set_setter(sc, set_plist_2(sc, obj, setter))); /* if T_Clo(setter), doesn't it need GC protection as above? */
}

/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix))
 *    which does not call the setter presumably because the set! has been optimized to ignore it -- set the setter before use!
 */

static s7_pointer call_c_function_setter(s7_scheme *sc, s7_pointer func, s7_pointer symbol, s7_pointer new_value)
{
  if (has_let_arg(func)) /* setter has optional third arg, the let */
    return(c_function_call(func)(sc, with_list_t3(sc, symbol, new_value, sc->curlet)));
  return(c_function_call(func)(sc, with_list_t2(sc, symbol, new_value)));
}

static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) /* see also op_set1 */
{
  const s7_pointer func = slot_setter(slot);
  if (is_c_function(func))
    return(call_c_function_setter(sc, func, slot_symbol(slot), new_value));
  if (!is_any_procedure(func))
    return(new_value);
  sc->temp9 = (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, sc->curlet) : list_2(sc, slot_symbol(slot), new_value);
  /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */
  /*  the following s7_call can clobber the temp var (perhaps setter is calling implicit set!?) */
  {
    s7_pointer result = s7_call(sc, func, sc->temp9);
    sc->temp9 = sc->unused;
    return(result);
  }
}

static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value)
{
  const s7_pointer func = setter_p_pp(sc, symbol, sc->curlet);
  if (is_c_function(func))
    return(call_c_function_setter(sc, func, symbol, new_value));
  if (!is_any_procedure(func))
    return(new_value);
  sc->args = (has_let_arg(func)) ? list_3(sc, symbol, new_value, sc->curlet) : list_2(sc, symbol, new_value);
  push_stack_direct(sc, op);
  sc->code = func;
  return(sc->no_value); /* this means the setter in set! needs to goto Apply to get the new value */
}


/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */
bool s7_is_eq(s7_pointer obj1, s7_pointer obj2)
{
  return((obj1 == obj2) ||                                     /* so floats and NaNs might be eq? but not eqv? */
	 ((is_unspecified(obj1)) && (is_unspecified(obj2))));  /* this is needed because this function is used by s7_b_pp */
}

static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2)
{
  return(make_boolean(sc, ((obj1 == obj2) || ((is_unspecified(obj1)) && (is_unspecified(obj2))))));
}

static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args)
{
  #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2"
  #define Q_is_eq sc->pcl_bt
  return(make_boolean(sc, ((car(args) == cadr(args)) ||
			   ((is_unspecified(car(args))) && (is_unspecified(cadr(args)))))));
  /* (eq? (apply apply apply values '(())) #<unspecified>) should return #t */
}

bool s7_is_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#if With_Gmp
  if ((is_big_number(x)) || (is_big_number(y))) return(big_numbers_are_eqv(sc, x, y));
#endif
  if (type(x) != type(y)) return(false);
  if ((x == y) && (!is_number(x)))         /* if x is NaN, x == y doesn't mean (eqv? x y) */
    return(true);                          /* x == y means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */
  if (is_number(x)) return(numbers_are_eqv(sc, x, y));
  if (is_unspecified(x)) return(true);     /* types are the same so we know y is also unspecified */
  return(false);
}

static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args)
{
  #define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2"
  #define Q_is_eqv sc->pcl_bt
  return(make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args))));
}

static s7_pointer is_eqv_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) {return(make_boolean(sc, s7_is_eqv(sc, obj1, obj2)));}

static bool floats_are_equivalent(s7_scheme *sc, s7_double x, s7_double y)
{
  s7_double diff;
  if (x == y) return(true);
  diff = fabs(x - y);
  if (diff <= sc->equivalent_float_epsilon) return(true);
  return((is_NaN(x)) && (is_NaN(y)));
}

#if With_Gmp
static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y)
{
  /* protect mpfr_1 */
  if ((mpfr_nan_p(x)) || (mpfr_nan_p(y)))
    return((mpfr_nan_p(x)) && (mpfr_nan_p(y)));
  mpfr_sub(sc->mpfr_3, x, y, Mpfr_Rndn);
  mpfr_abs(sc->mpfr_3, sc->mpfr_3, Mpfr_Rndn);
  return(mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0);
}
#endif

static bool eq_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);}

static bool symbol_equivalent(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_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 *unused_sc, s7_pointer unused_x, s7_pointer y, shared_info_t *unused_ci)
{
  return(is_unspecified(y));
}

static bool undefined_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_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 *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  return((is_string(y)) && (scheme_strings_are_equal(x, y)));
}

static bool syntax_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y)));
}

static bool port_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);}

static bool port_equivalent(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_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 (is_string_port(x))
    {
      if (!is_string_port(y)) return(false);
      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))));
    }
  if (is_file_port(x))
    {
      if (!is_file_port(y)) return(false);
      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
    }
  /* else must be a function port */
  if (!is_function_port(y)) return(false);
  if (is_input_port(x))
    return(port_input_function(x) == port_input_function(y));
  return(port_output_function(x) == port_output_function(y));
}

static void add_shared_ref(shared_info_t *ci, s7_pointer x, int32_t ref_x)
{
  /* called only in equality check, not printer */
  if (ci->top == ci->size)
    enlarge_shared_info(ci);
  set_collected(x);
  ci->objs[ci->top] = x;
  ci->refs[ci->top++] = ref_x;
}

static Inline bool inline_equal_ref(s7_scheme *unused_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 */
  const int32_t ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0;
  if (is_collected(x))
    {
      const int32_t ref_x = peek_shared_ref_1(ci, x);
      if (ref_y != 0)
	return(ref_x == ref_y);	/* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */
      /* try to harmonize the new guy -- there can be more than one structure equal to the current one */
      if (ref_x != 0)
	add_shared_ref(ci, y, ref_x);
    }
  else
    if (ref_y != 0)
      add_shared_ref(ci, x, ref_y);
    else
      {
	/* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer */
	if (ci->top >= ci->size2) enlarge_shared_info(ci);
	set_collected(x);
	set_collected(y);
	ci->objs[ci->top] = x;
	ci->refs[ci->top++] = ++ci->ref;
	ci->objs[ci->top] = y;
	ci->refs[ci->top++] = ci->ref;
      }
  return(false);
}

static bool equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(inline_equal_ref(sc, x, y, ci));}

static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, shared_info_t *ci)
{
  s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args);
  shared_info_t *nci = ci;

  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);
  {
    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_equal_method(Sc, X, Y) \
  do {						 \
    if (has_active_methods(sc, X))					\
      {									\
	s7_pointer _Equal_Func_ = find_method_with_let(Sc, 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)))); \
      }}								\
    while (0)

#define check_equivalent_method(Sc, X, Y) \
  do {						 \
    if (has_active_methods(sc, X))					\
      {									\
	s7_pointer _Equal_Func_ = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \
	if (_Equal_Func_ != Sc->undefined)				\
	  return(s7_boolean(Sc, s7_apply_function(Sc, _Equal_Func_, set_plist_2(Sc, X, Y)))); \
      }}								\
    while (0)

static bool c_objects_are_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  check_equivalent_method(sc, x, y);
  if (c_object_equivalent(sc, x))
    return(((*(c_object_equivalent(sc, x)))(sc, set_plist_2(sc, x, y))) != sc->F);
  return(c_objects_are_equal(sc, x, y, ci));
}

static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent)
{
  hash_entry_t **lists;
  s7_int len;
  shared_info_t *nci = ci;
  hash_check_t 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);
      else check_equal_method(sc, y, x);
      return(false);
    }
  if ((ci) && (equal_ref(sc, x, y, ci))) return(true);

  if (hash_table_entries(x) != hash_table_entries(y))
    return(false);
  if (hash_table_entries(x) == 0)
    return(true);
  if ((!equivalent) && ((hash_table_mapper(x) != default_hash_map) || (hash_table_mapper(y) != default_hash_map)))
    {
      if (hash_table_checker(x) != hash_table_checker(y))
	return(false);
      if (hash_table_mapper(x) != hash_table_mapper(y))
	return(false);
    }

  len = (s7_int)hash_table_size(x);
  lists = hash_table_elements(x);
  if (!nci) nci = clear_shared_info(sc->circle_info);
  eqf = (equivalent) ? is_equivalent_1 : is_equal_1;

  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);
    }

  /* 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, bool use_equal, shared_info_t *nci)
{
  for (s7_pointer e = y_let; e; e = let_outlet(e))
    for (s7_pointer y_slot = let_slots(e); is_slot_checked(y_slot); y_slot = next_slot(y_slot))
      if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */
	{
	  if (use_equal)
	    return(is_equal_1(sc, slot_value(x_slot), slot_value(y_slot), nci));
	  return(is_equivalent_1(sc, slot_value(x_slot), slot_value(y_slot), nci));
	}
  return(false);
}

static bool simple_slots_match(s7_scheme *sc, s7_pointer x_slot, s7_pointer y_let, bool use_equal, shared_info_t *nci)
{
  for (s7_pointer y_slot = let_slots(y_let); is_slot_checked(y_slot); y_slot = next_slot(y_slot))
    if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */
      {
	if (use_equal)
	  return(is_equal_1(sc, slot_value(x_slot), slot_value(y_slot), nci));
	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;

  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);

  if (let_outlet(x_let) == let_outlet(y_let)) /* not great savings in time */
    {
      clear_small_symbol_set(sc); /* not begin, slots_match below calls equal_1 -> let_equal_1 */
      x_len = 0;
      for (s7_pointer slot = let_slots(x_let); is_slot_checked(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 slot = let_slots(y_let); is_slot_checked(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 slot = let_slots(y_let); is_slot_checked(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)
	return(false);
      {
	shared_info_t *nci = ci;
	if (!nci) nci = clear_shared_info(sc->circle_info);
	for (s7_pointer slot = let_slots(x_let); is_slot_checked(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); /* so we don't see shadowed values(?) */
	      if (!simple_slots_match(sc, slot, y_let, !equivalent, nci))
		return(false);
	    }}
      return(true);
    }

  /* "shadowed" below refers to cases like: (equal? (sublet (inlet 'a 1) 'b 2) (sublet (inlet 'a 1 'b 2) 'b 2)) */
  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_slot_checked(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_slot_checked(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_slot_checked(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_slot_checked(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);
	    if (!slots_match(sc, slot, y_let, !equivalent, 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 */
  if (x_let == y_let) return(true);
  check_equal_method(sc, x_let, y_let);
  return(let_equal_1(sc, x_let, y_let, ci, false));
}

/* what should these do if there are setters? */
static bool let_equivalent(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci)
{
  if (x_let == y_let) return(true);
  check_equivalent_method(sc, x_let, y_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 *unused_ci)
{
  if (x == y)
    return(true);
  if (type(x) != type(y))
    return(false);
  if ((!is_global(sc->is_equal_symbol)) &&
      (has_active_methods(sc, x)) &&
      (has_active_methods(sc, y)))
    {
      const 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 ((!is_global(sc->is_equivalent_symbol)) &&
      (has_active_methods(sc, x)) &&
      (has_active_methods(sc, y)))
    {
      const s7_pointer equal_func = find_method(sc, closure_let(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))));
    }
  /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y))
   *   because locally defined constant functions on the second pass find the outer let.
   */
  return((is_equivalent_1(sc, closure_pars(x), closure_pars(y), ci)) &&
	 (is_equivalent_1(sc, closure_body(x), closure_body(y), ci)));
}

static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  if (x == y)
    return(true);
  if (!is_pair(y))
    return(false);
  if (!ci)
    ci = clear_shared_info(sc->circle_info);
  else
    if (inline_equal_ref(sc, x, y, ci))
      return(true);
  if (!is_equal_1(sc, car(x), car(y), ci)) return(false);
  {
    s7_pointer px, py;
    for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py))
      {
	if (!is_equal_1(sc, car(px), car(py), ci)) return(false);
	if (inline_equal_ref(sc, px, py, ci)) return(true);
      }
    return((px == py) || (is_equal_1(sc, px, py, ci)));
  }
}

static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  if (x == y)
    return(true);
  if (!is_pair(y))
    {
      check_equivalent_method(sc, y, x);
      return(false);
    }
  if (!ci)
    ci = clear_shared_info(sc->circle_info);
  else
    if (inline_equal_ref(sc, x, y, ci))
      return(true);
  if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false);
  {
    s7_pointer px, py;
    for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py))
      {
	if (!is_equivalent_1(sc, car(px), car(py), ci)) return(false);
	if (inline_equal_ref(sc, px, py, ci)) return(true);
      }
    return((px == py) || ((is_equivalent_1(sc, px, py, ci))));
  }
}

static bool vector_rank_match(s7_scheme *unused_sc, s7_pointer x, s7_pointer y)
{
  s7_int x_dims;
  if (!vector_has_dimension_info(x))
    return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
  x_dims = vector_ndims(x);
  if (x_dims == 1)
    return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
  if ((!vector_has_dimension_info(y)) ||
      (x_dims != vector_ndims(y)))
    return(false);
  for (s7_int j = 0; j < x_dims; j++)
    if (vector_dimension(x, j) != vector_dimension(y, j))
      return(false);
  return(true);
}

static bool iv_equivalent(const s7_int *ex, const s7_int *ey, s7_int len)
{
  s7_int i = 0;
  const s7_int 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 *unused_sc, s7_pointer x, s7_pointer y)
{
  const s7_int len = vector_length(x);
  const uint8_t *xp = byte_vector_bytes(x);
  const uint8_t *yp = byte_vector_bytes(y);
  for (s7_int i = 0; i < len; i++)
    if (xp[i] != yp[i])
      return(false);
  return(true);
}

static bool biv_equivalent(s7_pointer x, s7_pointer y)
{
  const s7_int len = vector_length(x);
  const uint8_t *xp = byte_vector_bytes(x);
  const s7_int *yp = int_vector_ints(y);
  for (s7_int i = 0; i < len; i++)
    if ((s7_int)(xp[i]) != yp[i])
      return(false);
  return(true);
}

static bool fv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len)
{
  const s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y);
  const s7_double fudge = sc->equivalent_float_epsilon;
  if (fudge == 0.0)
    {
      for (s7_int i = 0; i < len; i++)
	if ((arr1[i] != arr2[i]) &&
	    ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i]))))
	  return(false);
    }
  else
    if ((len & 0x3) == 0)
      for (s7_int i = 0; i < len; )
	Loop_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++);
    else
      for (s7_int i = 0; i < len; i++)
	if (!floats_are_equivalent(sc, arr1[i], arr2[i]))
	  return(false);
  return(true);
}

static bool cv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len)
{
  const s7_complex *arr1 = complex_vector_complexes(x), *arr2 = complex_vector_complexes(y);
  const s7_double fudge = sc->equivalent_float_epsilon;
  if (fudge == 0.0)
    {
      for (s7_int i = 0; i < len; i++)
	if (((creal(arr1[i]) != creal(arr2[i])) || (cimag(arr1[i]) != cimag(arr2[i]))) &&
	    ((!is_NaN(creal(arr1[i]))) || (!is_NaN(creal(arr2[i]))) || (!is_NaN(cimag(arr1[i]))) || (!is_NaN(cimag(arr2[i])))))
	  return(false);
    }
  else
    if ((len & 0x3) == 0)
      for (s7_int i = 0; i < len; )
	Loop_4(if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[i])))) return(false); i++);
    else
      for (s7_int i = 0; i < len; i++)
	if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[i]))))
	  return(false);
  return(true);
}

#define base_vector_equal(Sc, X, Y)			\
  do {							\
    if (X == Y) return(true);				\
    len = vector_length(X);				\
    if (len != vector_length(Y)) return(false);		\
    if (!vector_rank_match(Sc, X, Y)) return(false);	\
    if (len == 0) return(true);				\
  } while (0)

static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  s7_int len;
  shared_info_t *nci = ci;

  if (!is_any_vector(y)) return(false);
  base_vector_equal(sc, x, y); /* sets len */
  if (type(x) != type(y))
    {
      if ((is_int_vector(x)) && (is_byte_vector(y)))
	return(biv_equivalent(y, x));
      if ((is_byte_vector(x)) && (is_int_vector(y)))
	return(biv_equivalent(x, y));
      for (s7_int i = 0; i < len; i++)
	if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */
	  return(false);
      return(true);
    }
  if (!has_simple_elements(x))
    {
      if (ci)
	{
	  if (equal_ref(sc, x, y, ci)) return(true);
	}
      else nci = clear_shared_info(sc->circle_info);
    }
  /* splitting out the typed_vector_typer case is only slightly faster (5% and much trickier) */
  for (s7_int i = 0; i < len; i++)
    if (!is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci))
      return(false);
  return(true);
}

static bool byte_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  s7_int len;
  if (!is_byte_vector(y))
    return(vector_equal(sc, x, y, ci));
  base_vector_equal(sc, x, y);
  return(byte_vector_equal_1(sc, x, y));
}

static bool int_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  s7_int len;
  if (!is_int_vector(y))
    return(vector_equal(sc, x, y, ci));
  base_vector_equal(sc, x, y);
  return(iv_equivalent(int_vector_ints(x), int_vector_ints(y), len));
}

static bool float_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  s7_int len;
  if (!is_float_vector(y))
    return(vector_equal(sc, x, y, ci));
  base_vector_equal(sc, x, y);
  for (s7_int i = 0; i < len; i++)
    if (float_vector(x, i) != float_vector(y, i))
      return(false);
  return(true);
}

static bool complex_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  s7_int len;
  if (!is_complex_vector(y))
    return(vector_equal(sc, x, y, ci));
  base_vector_equal(sc, x, y);
  for (s7_int i = 0; i < len; i++)
    if (complex_vector(x, i) != complex_vector(y, i))
      return(false);
  return(true);
}

static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */
  s7_int len;
  if (x == y)
    return(true);
  if (!is_any_vector(y))
    {
      check_equivalent_method(sc, y, x);
      return(false);
    }
  len = vector_length(x);
  if (len != vector_length(y)) return(false);
  if (len == 0) return(true); /* different from vector_equal, (equal? (make-vector '(0 1)) (make-vector '(1 0))): #f, but #t if equivalent? */
  if (!vector_rank_match(sc, x, y)) return(false);

  if (type(x) != type(y))
    {
      /* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t
       * (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t
       */
      if ((is_int_vector(x)) && (is_byte_vector(y)))
	return(biv_equivalent(y, x));
      if ((is_byte_vector(x)) && (is_int_vector(y)))
	return(biv_equivalent(x, y));
      for (s7_int i = 0; i < len; i++)
	if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */
	  return(false);
      return(true);
    }
  if (is_float_vector(x))
    return(fv_equivalent(sc, x, y, len));
  if (is_int_vector(x))
    return(iv_equivalent(int_vector_ints(x), int_vector_ints(y), len));
  if (is_byte_vector(x))
    return(byte_vector_equal_1(sc, x, y));
  if (is_complex_vector(x))
    return(cv_equivalent(sc, x, y, len));
  {
    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);
}

static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent)
{
  s7_pointer x_seq, y_seq;

  if (x == y) return(true);
  if (!is_iterator(y)) return(false);
  x_seq = iterator_sequence(x);
  y_seq = iterator_sequence(y);

  switch (type(x_seq))
    {
    case T_STRING:
      return((is_string(y_seq)) &&
	     (iterator_position(x) == iterator_position(y)) &&
	     (iterator_length(x) == iterator_length(y)) &&
	     (string_equal(sc, x_seq, y_seq, ci)));

    case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR:
      return((is_any_vector(y_seq)) &&
	     (iterator_position(x) == iterator_position(y)) &&
	     (iterator_length(x) == iterator_length(y)) &&
	     ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) :
	      ((is_t_vector(x_seq)) ? (vector_equal(sc, x_seq, y_seq, ci)) :
	       ((is_float_vector(x_seq)) ? (float_vector_equal(sc, x_seq, y_seq, ci)) :
		((is_int_vector(x_seq)) ? (int_vector_equal(sc, x_seq, y_seq, ci)) :
		 ((is_byte_vector(x_seq)) ? (byte_vector_equal(sc, x_seq, y_seq, ci)) :
		  (complex_vector_equal(sc, x_seq, y_seq, ci))))))));

      /* iterator_next is a function (pair_iterate, iterator_finished etc) */
    case T_PAIR:
      if (iterator_next(x) != iterator_next(y)) return(false);     /* even if seqs are equal, one might be at end */
      if (equivalent)
	{
	  if (!pair_equivalent(sc, x_seq, y_seq, ci))
	    return(false);
	}
      else
	if (!pair_equal(sc, x_seq, y_seq, ci))
	  return(false);
      {
	s7_pointer xs, ys;
	for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); xs = cdr(xs), ys = cdr(ys))
	  if (xs == iterator_current(x))
	    return(ys == iterator_current(y));
	return(is_null(xs) && is_null(ys));
      }
    case T_NIL:                                                    /* (make-iterator #()) works, so () should too */
      return(is_null(y_seq));   /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */

    case T_C_OBJECT:
      if ((is_c_object(y_seq)) &&
	  (iterator_position(x) == iterator_position(y)) &&
	  (iterator_length(x) == iterator_length(y)))
	{
	  if (equivalent)
	    return(c_objects_are_equivalent(sc, x_seq, y_seq, ci));
	  return(c_objects_are_equal(sc, x_seq, y_seq, ci));
	}
      return(false);

    case T_LET:
      if (!is_let(y_seq)) return(false);
      if (x_seq == sc->rootlet)
	{
	  if (y_seq != sc->rootlet) return(false);
	  return(iterator_position(x) == iterator_position(y));
	}
      if (x_seq == sc->starlet)
	{
	  if (y_seq != sc->starlet) return(false);
	  return(iterator_position(x) == iterator_position(y));
	}
      if (equivalent)
	{
	  if (!let_equivalent(sc, x_seq, y_seq, ci))
	    return(false);
	}
      else
	if (!let_equal(sc, x_seq, y_seq, ci))
	  return(false);

      /* let_iterator_slot will be NULL at end */
      if (is_slot_end(let_iterator_slot(x))) return(is_slot_end(let_iterator_slot(y)));
      if (is_slot_end(let_iterator_slot(y))) return(false); /* not needed but seems clearer */
      {
	s7_pointer xs, ys;
	for (xs = let_slots(x_seq), ys = let_slots(y_seq); is_slot_checked(xs) && is_slot_checked(ys); xs = next_slot(xs), ys = next_slot(ys))
	  if (xs == let_iterator_slot(x))
	    return(ys == let_iterator_slot(y));
	return(is_slot_end(xs) && is_slot_end(ys));
      }
    case T_HASH_TABLE:
      if (!is_hash_table(y_seq)) return(false);
      if (hash_table_entries(x_seq) != hash_table_entries(y_seq)) return(false);
      if (hash_table_entries(x_seq) == 0) return(true);
      if (iterator_position(x) != iterator_position(y)) return(false);
      if (!equivalent) return(hash_table_equal(sc, x_seq, y_seq, ci));
      return(hash_table_equivalent(sc, x_seq, y_seq, ci));

    case T_CLOSURE: case T_CLOSURE_STAR:
      return(x_seq == y_seq); /* or closure_equal/equivalent? */

    default: break;
    }
  return(false);
}

static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)      {return(iterator_equal_1(sc, x, y, ci, false));}
static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, true));}

#if With_Gmp
static bool big_integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  /* (equal? 1 1.0) -> #f */
  if (is_t_big_integer(y))
    return(mpz_cmp(big_integer(x), big_integer(y)) == 0);
  return((is_t_integer(y)) && (mpz_cmp_si(big_integer(x), integer(y)) == 0));
}

static bool big_ratio_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  if (is_t_big_ratio(y))
    return(mpq_equal(big_ratio(x), big_ratio(y)));
  if (is_t_ratio(y))
    return((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) &&
	   (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x)))));
  return(false);
}

static bool big_real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  if (is_t_big_real(y))
    return(mpfr_equal_p(big_real(x), big_real(y)));
  if (is_t_real(y))
    {
      if (mpfr_nan_p(big_real(x))) return(false);
      return((!is_NaN(real(y))) &&
	     (mpfr_cmp_d(big_real(x), real(y)) == 0));
    }
  return(false);
}

static bool big_complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))))
    return(false);
  if (is_t_big_complex(y))
    return((!mpfr_nan_p(mpc_realref(big_complex(y)))) &&
	   (!mpfr_nan_p(mpc_imagref(big_complex(y)))) &&
	   (mpc_cmp(big_complex(x), big_complex(y)) == 0));
  if (is_t_complex(y))
    return((!is_NaN(real_part(y))) &&
	   (!is_NaN(imag_part(y))) &&
	   (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == 0) &&
	   (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) == 0));
  return(false);
}
#endif

static bool integer_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  if (is_t_integer(y))
    return(integer(x) == integer(y));
#if With_Gmp
  if (is_t_big_integer(y))
    return(mpz_cmp_si(big_integer(y), integer(x)) == 0);
#endif
  return(false);
}

/* apparently ratio_equal is predefined in g++ -- name collision on mac */
static bool fraction_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  if (is_t_ratio(y))
    return((numerator(x) == numerator(y)) &&
	   (denominator(x) == denominator(y)));
#if With_Gmp
  if (is_t_big_ratio(y))
    return((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) &&
	   (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y)))));
#endif
  return(false);
}

static bool real_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  if (is_t_real(y))
    return(real(x) == real(y));
#if With_Gmp
  if (is_t_big_real(y))
    return((!is_NaN(real(x))) &&
	   (!mpfr_nan_p(big_real(y))) &&
	   (mpfr_cmp_d(big_real(y), real(x)) == 0));
#endif
  return(false);
}

static bool complex_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  if (is_t_complex(y))
    return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y)));
#if With_Gmp
  if (is_t_big_complex(y))
    {
      if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) ||
	  (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y)))))
	return(false);
      return((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) == 0) &&
	     (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) == 0));
    }
#endif
  return(false);
}

#if With_Gmp
static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool int_case)
{
  if (int_case)
    mpfr_set_z(sc->mpfr_1, big_integer(x), Mpfr_Rndn);
  else mpfr_set_q(sc->mpfr_1, big_ratio(x), Mpfr_Rndn);

  switch (type(y))
    {
    case T_INTEGER:
      if (int_case)
	return(mpz_cmp_si(big_integer(x), integer(y)) == 0);
      mpfr_set_si(sc->mpfr_2, integer(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_RATIO:
      mpfr_set_d(sc->mpfr_2, fraction(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_REAL:
      mpfr_set_d(sc->mpfr_2, real(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_COMPLEX:
      mpfr_set_d(sc->mpfr_2, real_part(y), Mpfr_Rndn);
      if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2))
	return(false);
      if (is_NaN(imag_part(y))) return(false);
      mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, imag_part(y), Mpfr_Rndn);
      return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0);
    case T_BIG_INTEGER:
      if (int_case)
	return(mpz_cmp(big_integer(x), big_integer(y)) == 0);
      mpfr_set_z(sc->mpfr_2, big_integer(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_REAL:
      return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
    case T_BIG_COMPLEX:
      if (big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y))))
	{
	  if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false);
	  mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
	  return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0);
	}}
  return(false);
}

static bool big_integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  return(big_integer_or_ratio_equivalent(sc, x, y, ci, true));
}

static bool big_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  return(big_integer_or_ratio_equivalent(sc, x, y, ci, false));
}


static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  switch (type(y))
    {
    case T_INTEGER:
      mpfr_set_si(sc->mpfr_2, integer(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
    case T_RATIO:
      mpfr_set_d(sc->mpfr_2, fraction(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
    case T_REAL:
      mpfr_set_d(sc->mpfr_2, real(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
    case T_COMPLEX:
      mpfr_set_d(sc->mpfr_2, real_part(y), Mpfr_Rndn);
      if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2))
	return(false);
      if (is_NaN(imag_part(y))) return(false);
      mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, imag_part(y), Mpfr_Rndn);
      return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0);
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_2, big_integer(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
    case T_BIG_REAL:
      return(big_floats_are_equivalent(sc, big_real(x), big_real(y)));
    case T_BIG_COMPLEX:
      if (big_floats_are_equivalent(sc, big_real(x), mpc_realref(big_complex(y))))
	{
	  if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false);
	  mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
	  return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0);
	}}
  return(false);
}

static bool big_complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
{
  mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
  switch (type(y))
    {
    case T_INTEGER:
      mpfr_set_si(sc->mpfr_2, integer(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_RATIO:
      mpfr_set_d(sc->mpfr_2, fraction(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_REAL:
      mpfr_set_d(sc->mpfr_2, real(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_COMPLEX:
      mpfr_set_d(sc->mpfr_1, imag_part(y), Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, real_part(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_2, big_integer(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_BIG_RATIO:
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_BIG_REAL:
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), big_real(y))) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
    case T_BIG_COMPLEX:
      return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), mpc_realref(big_complex(y)))) &&
	     (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), mpc_imagref(big_complex(y)))));
    }
  return(false);
}

static bool both_floats_are_equivalent(s7_scheme *sc, s7_pointer y)
{
  if (!big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y))))
    return(false);
  if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false);
  mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, Mpfr_Rndn);
  return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0);
}
#endif

static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  switch (type(y))
    {
    case T_INTEGER:
      return(integer(x) == integer(y));
    case T_RATIO:
      return(floats_are_equivalent(sc, (double)integer(x), (s7_double)fraction(y)));
    case T_REAL:
      return(floats_are_equivalent(sc, (double)integer(x), real(y)));
    case T_COMPLEX:
      return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) &&
	     (floats_are_equivalent(sc, (double)integer(x), real_part(y))));
#if With_Gmp
    case T_BIG_INTEGER:
      return(mpz_cmp_si(big_integer(y), integer(x)) == 0);
    case T_BIG_RATIO:
      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_REAL:
      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
    case T_BIG_COMPLEX:
      mpfr_set_si(sc->mpfr_1, integer(x), Mpfr_Rndn);
      return(both_floats_are_equivalent(sc, y));
#endif
    }
  return(false);
}

static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_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, (double)fraction(x), real_part(y))));
#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(y), Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, fraction(x), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_RATIO:
      mpfr_set_d(sc->mpfr_1, fraction(x), Mpfr_Rndn);
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_REAL:
      mpfr_set_d(sc->mpfr_1, fraction(x), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
    case T_BIG_COMPLEX:
      mpfr_set_d(sc->mpfr_1, fraction(x), Mpfr_Rndn);
      return(both_floats_are_equivalent(sc, y));
#endif
    }
  return(false);
}

static bool real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  switch (type(y))
    {
    case T_INTEGER:
      return(floats_are_equivalent(sc, real(x), integer(y)));
    case T_RATIO:
      return(floats_are_equivalent(sc, real(x), (s7_double)fraction(y)));
    case T_REAL:
      return(floats_are_equivalent(sc, real(x), real(y)));
    case T_COMPLEX:
      return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) &&
	     (floats_are_equivalent(sc, real(x), real_part(y))));
#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(y), Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, real(x), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_RATIO:
      mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
    case T_BIG_REAL:
      mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
      return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
    case T_BIG_COMPLEX:
      mpfr_set_d(sc->mpfr_1, real(x), Mpfr_Rndn);
      return(both_floats_are_equivalent(sc, y));
#endif
    }
  return(false);
}

static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  switch (type(y))
    {
    case T_INTEGER:
      return((floats_are_equivalent(sc, real_part(x), integer(y))) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_RATIO:
      return((floats_are_equivalent(sc, real_part(x), (s7_double)fraction(y))) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_REAL:
      return((floats_are_equivalent(sc, real_part(x), real(y))) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_COMPLEX:
      return((floats_are_equivalent(sc, real_part(x), real_part(y))) &&
	     (floats_are_equivalent(sc, imag_part(x), imag_part(y))));
#if With_Gmp
    case T_BIG_INTEGER:
      mpfr_set_z(sc->mpfr_1, big_integer(y), Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, real_part(x), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_BIG_RATIO:
      mpfr_set_d(sc->mpfr_1, real_part(x), Mpfr_Rndn);
      mpfr_set_q(sc->mpfr_2, big_ratio(y), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_BIG_REAL:
      mpfr_set_d(sc->mpfr_1, real_part(x), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) &&
	     (floats_are_equivalent(sc, imag_part(x), 0.0)));
    case T_BIG_COMPLEX:
      mpfr_set_d(sc->mpfr_1, real_part(x), Mpfr_Rndn);
      mpfr_set_d(sc->mpfr_2, imag_part(x), Mpfr_Rndn);
      return((big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) &&
	     (big_floats_are_equivalent(sc, sc->mpfr_2, mpc_imagref(big_complex(y)))));
#endif
    }
  return(false);
}

static bool random_state_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
#if With_Gmp
  return(x == y);
#else
  return((x == y) ||
	 ((is_random_state(y)) &&
	  (random_seed(x) == random_seed(y)) &&
	  (random_carry(x) == random_carry(y))));
#endif
}

static bool c_function_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  return((is_c_function(y)) && (c_function_data(x) == c_function_data(y)));
}

static bool c_macro_equal(s7_scheme *unused_sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci)
{
  return((is_c_macro(y)) && (c_macro_data(x) == c_macro_data(y)));
}

static void init_equals(void)
{
  for (int32_t i = 0; i < Num_Types; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;}
  equals[T_BACRO] =             closure_equal;
  equals[T_BACRO_STAR] =        closure_equal;
#if With_Gmp
  equals[T_BIG_COMPLEX] =       big_complex_equal;
  equals[T_BIG_INTEGER] =       big_integer_equal;
  equals[T_BIG_RATIO] =         big_ratio_equal;
  equals[T_BIG_REAL] =          big_real_equal;
#endif
  equals[T_BYTE_VECTOR] =       byte_vector_equal;
  equals[T_CLOSURE] =           closure_equal;
  equals[T_CLOSURE_STAR] =      closure_equal;
  equals[T_COMPLEX] =           complex_equal;
  equals[T_C_MACRO] =           c_macro_equal;
  equals[T_C_FUNCTION] =        c_function_equal;
  equals[T_C_RST_NO_REQ_FUNCTION] = c_function_equal;
  equals[T_C_OBJECT] =          c_objects_are_equal;
  equals[T_C_POINTER] =         c_pointer_equal;
  equals[T_FLOAT_VECTOR] =      float_vector_equal;
  equals[T_COMPLEX_VECTOR] =    complex_vector_equal;
  equals[T_HASH_TABLE] =        hash_table_equal;
  equals[T_INPUT_PORT] =        port_equal;
  equals[T_INTEGER] =           integer_equal;
  equals[T_INT_VECTOR] =        int_vector_equal;
  equals[T_ITERATOR] =          iterator_equal;
  equals[T_LET] =               let_equal;
  equals[T_MACRO] =             closure_equal;
  equals[T_MACRO_STAR] =        closure_equal;
  equals[T_OUTPUT_PORT] =       port_equal;
  equals[T_PAIR] =              pair_equal;
  equals[T_RANDOM_STATE] =      random_state_equal;
  equals[T_RATIO] =             fraction_equal;
  equals[T_REAL] =              real_equal;
  equals[T_STRING] =            string_equal;
  equals[T_SYMBOL] =            eq_equal;
  equals[T_SYNTAX] =            syntax_equal;
  equals[T_UNDEFINED] =         undefined_equal;
  equals[T_UNSPECIFIED] =       unspecified_equal;
  equals[T_VECTOR] =            vector_equal;

  equivalents[T_BACRO] =        closure_equivalent;
  equivalents[T_BACRO_STAR] =   closure_equivalent;
#if With_Gmp
  equivalents[T_BIG_COMPLEX] =  big_complex_equivalent;
  equivalents[T_BIG_INTEGER] =  big_integer_equivalent;
  equivalents[T_BIG_RATIO] =    big_ratio_equivalent;
  equivalents[T_BIG_REAL] =     big_real_equivalent;
#endif
  equivalents[T_BYTE_VECTOR] =  vector_equivalent;
  equivalents[T_CLOSURE] =      closure_equivalent;
  equivalents[T_CLOSURE_STAR] = closure_equivalent;
  equivalents[T_COMPLEX] =      complex_equivalent;
  equivalents[T_C_MACRO] =      c_macro_equal;
  equivalents[T_C_FUNCTION] =   c_function_equal;
  equivalents[T_C_RST_NO_REQ_FUNCTION] = c_function_equal;
  equivalents[T_C_OBJECT] =     c_objects_are_equivalent;
  equivalents[T_C_POINTER] =    c_pointer_equivalent;
  equivalents[T_FLOAT_VECTOR] = vector_equivalent;
  equivalents[T_COMPLEX_VECTOR] = vector_equivalent;
  equivalents[T_HASH_TABLE] =   hash_table_equivalent;
  equivalents[T_INPUT_PORT] =   port_equivalent;
  equivalents[T_INTEGER] =      integer_equivalent;
  equivalents[T_INT_VECTOR] =   vector_equivalent;
  equivalents[T_ITERATOR] =     iterator_equivalent;
  equivalents[T_LET] =          let_equivalent;
  equivalents[T_MACRO] =        closure_equivalent;
  equivalents[T_MACRO_STAR] =   closure_equivalent;
  equivalents[T_OUTPUT_PORT] =  port_equivalent;
  equivalents[T_PAIR] =         pair_equivalent;
  equivalents[T_RANDOM_STATE] = random_state_equal;
  equivalents[T_RATIO] =        fraction_equivalent;
  equivalents[T_REAL] =         real_equivalent;
  equivalents[T_STRING] =       string_equal;
  equivalents[T_SYMBOL] =       symbol_equivalent;
  equivalents[T_SYNTAX] =       syntax_equal;
  equivalents[T_UNDEFINED] =    undefined_equal;
  equivalents[T_UNSPECIFIED] =  unspecified_equal;
  equivalents[T_VECTOR] =       vector_equivalent;
}

bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equals[type(x)]))(sc, x, y, NULL));}
bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equivalents[type(x)]))(sc, x, y, NULL));}

static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2"
  #define Q_is_equal sc->pcl_bt
  return(make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL)));
}

static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args)
{
  #define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2."
  #define Q_is_equivalent sc->pcl_bt
  return(make_boolean(sc, is_equivalent_1(sc, car(args), cadr(args), NULL)));
}

static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b)      {return((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);}
static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);}


/* ---------------------------------------- length, copy, fill ---------------------------------------- */
static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */

static s7_pointer any_length(s7_scheme *sc, s7_pointer unused_obj) {return(sc->F);}

static s7_pointer pair_length(s7_scheme *sc, s7_pointer a)
{
  s7_int i = 0;
  s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */
  while (true)
    {
      Loop_4(fast = cdr(fast); i++; if (!is_pair(fast)) return(make_integer(sc, (is_null(fast)) ? i : -i)));
      slow = cdr(slow);
      if (fast == slow)	return(Real_Infinity);
    }
  return(Real_Infinity);
}

static s7_pointer nil_length(s7_scheme *unused_sc, s7_pointer unused_lst) {return(Int_Zero);}
static s7_pointer v_length(s7_scheme *sc, s7_pointer vec)        {return(make_integer(sc, vector_length(vec)));}
static s7_pointer str_length(s7_scheme *sc, s7_pointer str)      {return(make_integer(sc, string_length(str)));}
static s7_pointer bv_length(s7_scheme *sc, s7_pointer bv)        {return(make_integer(sc, byte_vector_length(bv)));}
static s7_pointer h_length(s7_scheme *sc, s7_pointer table)      {return(make_integer(sc, hash_table_size(table)));}
static s7_pointer iter_length(s7_scheme *sc, s7_pointer iter)    {return(s7_length(sc, iterator_sequence(iter)));}
static s7_pointer rs_length(s7_scheme *sc, s7_pointer unused_rs) {return((With_Gmp) ? sc->F : Int_Two);}

static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer cobj)
{
  if (!is_global(sc->length_symbol))
    if_c_object_method_exists_return_value(sc, cobj, sc->length_symbol, set_plist_1(sc, cobj));
  return(c_object_length(sc, cobj));
}

static s7_pointer 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)));
}

static s7_pointer fnc_length(s7_scheme *sc, s7_pointer func)
{
  return((has_active_methods(sc, func)) ? make_integer(sc, closure_length(sc, func)) : sc->F);
}

static s7_pointer ip_length(s7_scheme *sc, s7_pointer port)
{
  if (port_is_closed(port))
    return(sc->F);             /* or 0? */
  if (is_string_port(port))
    return(make_integer(sc, port_data_size(port))); /* length of string we're reading */
#if !MS_Windows
  if (is_file_port(port))
    {
      long len;
      const 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 */
}

#define Num_Length_Functions 256
static s7_pointer (*length_functions[Num_Length_Functions])(s7_scheme *sc, s7_pointer obj);

static void init_length_functions(void)
{
  for (int32_t i = 0; i < Num_Length_Functions; 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)));
}


/* -------------------------------- 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 *unused_sc, s7_pointer str, s7_int loc)
{
  return(chars[(uint8_t)(string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */
}

static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer cobj, s7_int loc, s7_pointer val)
{
  return((*(c_object_set(sc, cobj)))(sc, with_list_t3(sc, cobj, wrap_mutable_integer(sc, loc), val))); /* was make_integer 14-Nov-23 */
}

static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer cobj, s7_int loc)
{
  return((*(c_object_ref(sc, cobj)))(sc, set_plist_2(sc, cobj, wrap_mutable_integer(sc, loc)))); /* was make_integer 14-Nov-23 */
}

static s7_pointer let_setter(s7_scheme *sc, s7_pointer let, s7_int unused_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 unused_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, Vector_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));

    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);
#if With_Gmp
    case T_BIG_INTEGER: return(mpz_to_big_integer(sc, big_integer(source)));
    case T_BIG_RATIO:   return(mpq_to_big_ratio(sc, big_ratio(source)));
    case T_BIG_REAL:    return(mpfr_to_big_real(sc, big_real(source)));
    case T_BIG_COMPLEX: return(mpc_to_number(sc, big_complex(source)));
#endif

    case T_C_POINTER:
      dest = s7_make_c_pointer_with_type(sc, c_pointer(source), c_pointer_type(source), c_pointer_info(source));
      c_pointer_weak1(dest) = c_pointer_weak1(source);
      c_pointer_weak2(dest) = c_pointer_weak2(source);
      return(dest);
      /* default here it to return the source without comment */
    }
  return(source);
}

static s7_pointer copy_p_p(s7_scheme *sc, s7_pointer source) {return(copy_source_no_dest(sc, source, set_plist_1(sc, source)));}

static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start)
{
  s7_pointer (*cref)(s7_scheme *sc, s7_pointer args) = c_object_ref(sc, source);
  s7_pointer (*cset)(s7_scheme *sc, s7_pointer args) = c_object_set(sc, dest);
  if ((is_safe_c_function(c_object_getf(sc, source))) &&
      (is_safe_c_function(c_object_setf(sc, dest)))) /* maybe not worth the extra code */
    {
      const s7_pointer mi = wrap_mutable_integer(sc, 0);
      const 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
    {
      const s7_pointer mi = make_mutable_integer(sc, 0);
      const s7_int gc_loc1 = gc_protect_1(sc, mi);
      const 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);
      }

    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
	{
	  if ((s7_Debugging) && (type(dest) != T_BYTE_VECTOR))
	    fprintf(stderr, "%s[%d]: byte-vector dest is %s\n", __func__, __LINE__, type_name(sc, dest, No_Article));
	  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
	{
	  if ((s7_Debugging) && (type(dest) != T_BYTE_VECTOR))
	    fprintf(stderr, "%s[%d]: string dest is %s\n", __func__, __LINE__, type_name(sc, dest, No_Article));
	  memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len);
	}
      return(dest);

    case T_RANDOM_STATE:
#if !With_Gmp
      random_seed(dest) = random_seed(source);
      random_carry(dest) = random_carry(source);
#endif
      return(dest);

    case T_C_OBJECT:
      return(copy_c_object_to_same_type(sc, dest, source, dest_start, dest_end, source_start));

    case T_LET:
      return(NULL);

    case T_HASH_TABLE:
      {
	s7_pointer new_table;
	gc_protect_via_stack(sc, source);
	new_table = hash_table_copy(sc, source, dest, source_start, source_start + source_len);
	unstack_gc_protect(sc);
	if ((hash_table_checker(source) != hash_table_checker(dest)) &&
	    (hash_table_mapper(dest) == default_hash_map))
	  {
	    if (hash_table_checker(dest) == hash_empty)
	      hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */
	    else
	      {
		hash_table_checker(dest) = hash_equal;
		hash_set_chosen(dest);
	      }}
	return(new_table);
      }

    default:
      return(dest);
    }
  return(NULL);
}

static no_return void copy_element_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, int32_t desired_type)
{
  set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42),
	      caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]);
  error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6);
}

static no_return void copy_element_error_with_type_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, s7_pointer desired_type)
{
  set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42),
	      caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type);
  error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6);
}

static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
{
  #define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end."
  /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */
  /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence,
   *   but it can provide a copy method.  So, I think I'll just use #t
   */
  #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol)

  const s7_pointer source = car(args);
  s7_pointer dest;
  s7_int dest_len, start, end, source_len;
  s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) = NULL;
  s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_int loc) = NULL;
  bool have_indices;

  if (is_null(cdr(args)))                  /* (copy obj) */
    return(copy_source_no_dest(sc, source, args));
  dest = T_Ext(cadr(args));
  if ((dest == sc->readable_keyword) && (!is_pair(source)))
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_1(sc, wrap_string(sc, "copy argument 2, :readable, only works if the source is a pair", 62)));
  if ((is_immutable(dest)) &&
      (dest != sc->readable_keyword) &&
      (dest != sc->nil))                 /* error_hook copies with cadr(args) :readable, so it's currently NULL */
    wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a mutable object", 16)); /* so this segfaults if not checking for :readable */

  have_indices = (is_pair(cddr(args)));
  if ((source == dest) && (!have_indices)) return(dest);
  /* gc_protect_via_stack(sc, args); */ /* why is this problematic? */
  sc->w = args;

  switch (type(source))
    {
    case T_PAIR:
      if (dest == sc->readable_keyword)  /* a kludge, but I can't think of anything less stupid */
	{
	  if (have_indices)              /* it seems to me that the start/end args here don't make any sense so... */
	    error_nr(sc, sc->wrong_number_of_args_symbol,
		     set_elist_3(sc, wrap_string(sc, "~S: start/end indices make no sense with :readable: ~S", 54), caller, args));
	  return(copy_body(sc, source));
	}
      end = s7_list_length(sc, source);
      if (end == 0)
	end = circular_list_entries(source);
      else
	if (end < 0) end = -end;
      break;

    case T_INT_VECTOR:  case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR:
      get = vector_getter(source);
      end = vector_length(source);
      break;

    case T_STRING:
      get = string_getter;
      end = string_length(source);
      break;

    case T_HASH_TABLE:
      if (source == dest) return(dest);
      end = hash_table_entries(source);
      break;

    case T_RANDOM_STATE:
      get = random_state_getter;
      end = 2;
      break;

    case T_C_OBJECT:
      if (c_object_copy(sc, source))
	{
	  s7_pointer 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_slot_checked(slot); slot = next_slot(slot))
	      s7_make_slot(sc, sc->rootlet, slot_symbol(slot), slot_value(slot));
	  else
	    if ((has_let_fallback(source)) &&
		(has_let_fallback(dest)))
	      {
		update_let(sc, dest);
		for (slot = let_slots(source); is_slot_checked(slot); slot = next_slot(slot))
		  if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) &&
		      (slot_symbol(slot) != sc->let_set_fallback_symbol))
		    {
		      if (let_id(dest) == symbol_id(slot_symbol(slot)))
			error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S (of a let): '~S", 42), caller, slot_symbol(slot)));
		      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 */
		update_let(sc, dest);
		for (slot = let_slots(source); is_slot_checked(slot); slot = next_slot(slot))
		  {
		    if (let_id(dest) == symbol_id(slot_symbol(slot)))
		      error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S (of a let): '~S", 42), caller, slot_symbol(slot)));
		    add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
		  }}
	  return(dest);
	}
      end = let_length(sc, source);
      break;

    case T_NIL:
      end = 0;
      if (is_sequence(dest))
	break;

    default:
      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest));
    }

  start = 0;
  if (have_indices)
    {
      s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
      if (p != sc->unused) return(p);
    }
  if ((start == 0) && (source == dest))
    return(dest);

  source_len = end - start;
  if (source_len == 0)
    {
      if (!is_sequence(dest))
	wrong_type_error_nr(sc, caller, 2, dest, A_Sequence_String);
      return(dest);
    }

  switch (type(dest))
    {
    case T_PAIR:
      dest_len = source_len;
      break;

    case T_INT_VECTOR: case T_BYTE_VECTOR:
      if (is_float_vector(source))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)]));
    case T_FLOAT_VECTOR:
      if (is_complex_vector(source))
	error_nr(sc, sc->wrong_type_arg_symbol,
		 set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)]));
    case T_COMPLEX_VECTOR:
      set = vector_setter(dest);
      dest_len = vector_length(dest);
      break;

    case T_VECTOR:
      set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest);
      dest_len = vector_length(dest);
      break;

    case T_STRING:
      set = string_setter;
      dest_len = string_length(dest);
      set_cadr(sc->elist_3, caller);   /* for possible error handling in string_setter */
      break;

    case T_HASH_TABLE:
      set = hash_table_setter;
      dest_len = source_len;
      set_cadr(sc->elist_3, caller);   /* for possible error handling in hash_table_setter */
      break;

    case T_C_OBJECT:
      /* if source or dest is c_object, call its copy function before falling back on the get/set functions */
      if (c_object_copy(sc, dest))
	{
	  s7_pointer 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;
      set_cadr(sc->elist_3, caller);  /* for possible error handling in let_setter */
      break;

    case T_NIL:
      return(sc->nil);

    case T_RANDOM_STATE:
      set = random_state_setter;
      dest_len = 2;
      break;

    default:
      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest));
    }

  if (dest_len == 0)
    return(dest);

  /* end is source_len if not set explicitly */
  if (dest_len < source_len)
    {
      end = dest_len + start;
      source_len = dest_len;
    }

  if ((source != dest) &&
      ((type(source) == type(dest)) ||
       ((is_string_or_byte_vector(source)) &&
	(is_string_or_byte_vector(dest)))))
    {
      s7_pointer result = copy_to_same_type(sc, dest, source, 0, source_len, start);
      if (result) return(result);
    }

  switch (type(source))
    {
    case T_PAIR:
      {
	s7_pointer p = source;
	if (start > 0)
	  for (s7_int i = 0; i < start; i++)
	    p = cdr(p);
	/* dest won't be a pair here if source != dest -- the pair->pair case was caught above */
	if (source == dest)
	  {
	    s7_pointer dp = source;
	    for (s7_int i = start; i < end; i++, p = cdr(p), dp = cdr(dp))
	      set_car(dp, car(p));
	  }
	else
	  if (is_string(dest))
	    {
	      char *dst = string_value(dest);
	      for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p))
		{
		  if (!is_character(car(p)))
		    copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER);
		  dst[j] = character(car(p));
		}}
	  else
	    if ((is_t_vector(dest)) && (set != typed_vector_setter))
	      {
		s7_pointer *els = vector_elements(dest);
		for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p))
		  els[j] = car(p);
	      }
	    else
	      {
		gc_protect_via_stack(sc, source);
		for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p))
		  set(sc, dest, j, car(p));
		unstack_gc_protect(sc);
	      }
	return(dest);
      }

    case T_LET:
      if (source == sc->starlet) /* *s7* */ /* this could be more direct via starlet_make_iterator, but it hardly matters */
	{
	  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 */
	      {
		update_let(sc, dest);
		if ((has_let_fallback(source)) &&
		    (has_let_fallback(dest)))
		  {
		    for (slot = let_slots(source); is_slot_checked(slot); slot = next_slot(slot))
		      if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) &&
			  (slot_symbol(slot) != sc->let_set_fallback_symbol))
			{
			  if (let_id(dest) == symbol_id(slot_symbol(slot)))
			    error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S (of a let): '~S", 42), caller, slot_symbol(slot)));
			  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))
		    {
		      if (let_id(dest) == symbol_id(slot_symbol(slot)))
			error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in ~S (of a let): '~S", 42), caller, slot_symbol(slot)));
		      add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
		    }}
	    else
	      if (is_hash_table(dest))
		for (s7_int i = start; i < end; i++, slot = next_slot(slot))
		  s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */
	      else
		if ((is_t_vector(dest)) && (set != typed_vector_setter))
		  {
		    s7_pointer *els = vector_elements(dest);
		    check_free_heap_size(sc, end - start);
		    for (s7_int i = start, j = 0; i < end; i++, j++, slot = next_slot(slot))
		      els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot));
		  }
		else
		  for (s7_int i = start, j = 0; i < end; i++, j++, slot = next_slot(slot))
		    set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot)));
	}
      return(dest);

    case T_HASH_TABLE:
      {
	s7_int loc = -1, skip = start;
	hash_entry_t **elements = hash_table_elements(source);
	hash_entry_t *entry = NULL;

	while (skip > 0)
	  {
	    while (!entry) entry = elements[++loc];
	    skip--;
	    entry = hash_entry_next(entry);
	  }
	if (is_pair(dest))
	  {
	    s7_pointer p = dest;
	    check_free_heap_size(sc, end - start);
	    for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p))
	      {
		while (!entry) entry = elements[++loc];
		set_car(p, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry)));
		entry = hash_entry_next(entry);
	      }}
	else
	  if (is_let(dest))
	    {
	      update_let(sc, 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))
		    {
		      if (let_id(dest) == symbol_id(symbol)) /* (copy (hash-table 'a 1) (inlet :a 2)) */
			error_nr(sc, sc->duplicate_identifier_symbol, set_elist_4(sc, wrap_string(sc, "duplicate identifier '~S in ~S ~S", 33), symbol, caller, args));
		      add_slot_no_local(sc, dest, symbol, hash_entry_value(entry)); /* ...unchecked... if size ok */
		    }
		  entry = hash_entry_next(entry);
		}}
	  else
	    {
	      check_free_heap_size(sc, end - start);
	      for (s7_int i = start, j = 0; i < end; i++, j++)
		{
		  while (!entry) entry = elements[++loc];
		  set(sc, dest, j, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry)));
		  entry = hash_entry_next(entry);
		}}
        return(dest);
      }

    case T_VECTOR:
      {
	s7_pointer *vals = vector_elements(source);
	if (is_float_vector(dest))
	  {
	    s7_double *dst = float_vector_floats(dest);
	    for (s7_int i = start, j = 0; i < end; i++, j++)
	      dst[j] = real_to_double(sc, vals[i], symbol_name(caller));
	    return(dest);
	  }
	if (is_int_vector(dest))
	  {
	    s7_int *dst = int_vector_ints(dest);
	    for (s7_int i = start, j = 0; i < end; i++, j++)
	      {
		if (!s7_is_integer(vals[i]))
		  copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER);
		dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]);
	      }
	    return(dest);
	  }
	if (is_complex_vector(dest))
	  {
	    s7_complex *dst = complex_vector_complexes(dest);
	    for (s7_int i = start, j = 0; i < end; i++, j++)
	      {
		if (!s7_is_number(vals[i]))
		  copy_element_error_nr(sc, caller, i + 1, vals[i], T_COMPLEX);
		dst[j] = s7_to_c_complex(vals[i]);
	      }
	    return(dest);
	  }
	if (is_string(dest))
	  {
	    char *dst = string_value(dest);
	    for (s7_int i = start, j = 0; i < end; i++, j++)
	      {
		if (!is_character(vals[i]))
		  copy_element_error_nr(sc, caller, i + 1, vals[i], T_CHARACTER);
		dst[j] = character(vals[i]);
	      }
	    return(dest);
	  }
	if (is_byte_vector(dest))
	  {
	    uint8_t *dst = (uint8_t *)byte_vector_bytes(dest);
	    for (s7_int i = start, j = 0; i < end; i++, j++)
	      {
		s7_int byte;
		if (!s7_is_integer(vals[i]))
		  copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], An_Unsigned_Byte_String);
		byte = s7_integer_clamped_if_gmp(sc, vals[i]);
		if ((byte >= 0) && (byte < 256))
		  dst[j] = (uint8_t)byte;
		else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], An_Unsigned_Byte_String);
	      }
	    return(dest);
	  }
	if (is_pair(dest))
	  {
	    s7_pointer p = dest;
	    for (s7_int i = start; (i < end) && (is_pair(p)); p = cdr(p), i++)
	      set_car(p, vals[i]);
	    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);
	}
      if (is_pair(dest))
	{
	  s7_pointer p = dest;
	  const s7_double *src = float_vector_floats(source);
	  check_free_heap_size(sc, end - start);
	  for (s7_int i = start; (i < end) && (is_pair(p)); p = cdr(p), i++)
	    set_car(p, 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_pair(dest))
	  {
	    s7_pointer p = dest;
	    /* const s7_int *src = int_vector_ints(source); */
	    check_free_heap_size(sc, end - start);
	    for (s7_int i = start; (i < end) && (is_pair(p)); p = cdr(p), i++)
	      set_car(p, make_integer_unchecked(sc, src[i]));
	    return(dest);
	  }
	if (is_byte_vector(dest))
	  {
	    uint8_t *dst = byte_vector_bytes(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);
		dst[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);
	}
      if (is_pair(dest))
	{
	  s7_pointer p = dest;
	  for (s7_int i = start; (i < end) && (is_pair(p)); p = cdr(p), i++)
	    set_car(p, chars[(uint8_t)string_value(source)[i]]);
	  return(dest);
	}
      break;
      /* default (random_state, simple_block etc) is to let "set" handle it below */
    }

  if (is_pair(dest))
    {
      s7_pointer p = dest;
      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 currently:
   *   (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error
   */
  return(dest);
}

s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));}
#define g_copy s7_copy


/* -------------------------------- reverse -------------------------------- */
s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */
{
  /* reverse list -- produce new list (other code assumes this function does not return the original!) */
  s7_pointer lst, p;

  if (is_null(a)) return(a);
  if (!is_pair(cdr(a)))
    return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a)));  /* don't return 'a' itself */
  begin_temp(sc->y, list_1(sc, car(a)));
  for (lst = cdr(a), p = a; is_pair(lst); lst = cdr(lst), p = cdr(p))
    {
      sc->y = cons(sc, car(lst), sc->y);
      if (is_pair(cdr(lst)))
	{
	  lst = cdr(lst);
	  sc->y = cons_unchecked(sc, car(lst), sc->y);
	}
      if (lst == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */
	break;
    }
  sc->y = (is_null(lst)) ? sc->y : cons(sc, lst, sc->y);    /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */
  return_with_end_temp(sc->y);
}

/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late)
 *  (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0)
 */

static s7_pointer string_reverse(s7_scheme *sc, s7_pointer str)
{
  const char *source = string_value(str);
  const s7_int len = string_length(str);
  if (len == 0) return(nil_string);
  {
    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 = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, iv)), Int_Zero), sc->make_int_vector_symbol);
  else new_iv = make_simple_int_vector(sc, len);
  dest = (s7_int *)(int_vector_ints(new_iv) + len);
  while (source < end) *(--dest) = *source++;
  return(new_iv);
}

static s7_pointer float_vector_reverse(s7_scheme *sc, s7_pointer fv)
{
  s7_pointer new_fv;
  s7_double *dest;
  const s7_double *source = float_vector_floats(fv);
  const s7_int len = vector_length(fv);
  const s7_double *end = (s7_double *)(source + len);
  if (vector_rank(fv) > 1)
    new_fv = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, fv)), Real_Zero), sc->make_float_vector_symbol);
  else new_fv = make_simple_float_vector(sc, len);
  dest = (s7_double *)(float_vector_floats(new_fv) + len);
  while (source < end) *(--dest) = *source++;
  return(new_fv);
}

static s7_pointer complex_vector_reverse(s7_scheme *sc, s7_pointer cv)
{
  s7_pointer new_cv;
  s7_complex *dest;
  const s7_complex *source = complex_vector_complexes(cv);
  const s7_int len = vector_length(cv);
  const s7_complex *end = (s7_complex *)(source + len);
  if (vector_rank(cv) > 1)
    new_cv = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, cv)), Real_Zero), sc->make_complex_vector_symbol);
  else new_cv = make_simple_complex_vector(sc, len);
  dest = (s7_complex *)(complex_vector_complexes(new_cv) + len);
  while (source < end) *(--dest) = *source++;
  return(new_cv);
}

static s7_pointer vector_reverse(s7_scheme *sc, s7_pointer vect)
{
  s7_pointer new_vect;
  s7_pointer *dest;
  const s7_pointer *source = vector_elements(vect);
  const s7_int len = vector_length(vect);
  const s7_pointer *end = (s7_pointer *)(source + len);
  if (vector_rank(vect) > 1)
    new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, vect))));
  else new_vect = make_simple_vector(sc, len);
  dest = (s7_pointer *)(vector_elements(new_vect) + len);
  while (source < end) *(--dest) = *source++;
  if (is_typed_vector(vect))
    {
      set_typed_vector(new_vect);
      typed_vector_set_typer(new_vect, typed_vector_typer(vect));
      if (has_simple_elements(vect)) set_has_simple_elements(new_vect);
    }
  return(new_vect);
}

static s7_pointer 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)));
}

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
}

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->unused);
}

static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args)
{
  #define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order.  reverse \
also accepts a string or vector argument."
  #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)
  return(reverse_p_p(sc, car(args)));
}

static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list)
{
  s7_pointer p, result;
  if (is_null(list)) return(term);
  p = list;
  result = term;
  while (true)
    {
      const s7_pointer q = cdr(p);
      if (is_null(q))
	{
	  set_cdr(p, result);
	  return(p);
	}
      if ((is_pair(q)) && (!is_immutable_pair(q)))
	{
	  set_cdr(p, result);
	  result = p;
	  p = q;
	}
      else return(sc->nil); /* improper or immutable */
    }
  return(result);
}

static s7_pointer string_or_byte_vector_reverse_in_place(s7_scheme *sc, s7_pointer str)
{
  s7_int len;
  uint8_t *bytes;
  if (is_string(str))
    {
      len = string_length(str);
      bytes = (uint8_t *)string_value(str);
    }
  else
    {
      len = byte_vector_length(str);
      bytes = byte_vector_bytes(str);
    }
  if (len < 2) return(str);
  if (is_immutable(str)) /* "" might be immutable but we want (reverse! "") to return "" */
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->reverseb_symbol, str));

#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */
  /* this code (from StackOverflow with changes) is much faster: */
#include <byteswap.h>
  if ((len & 0x7f) == 0)
    {
      uint32_t *dst = (uint32_t *)(bytes + len - 4);
      uint32_t *src = (uint32_t *)bytes;
      while (src < dst)
	{
	  uint32_t a, b;
	  Loop_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a));
	  Loop_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a));
	  Loop_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a));
	  Loop_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a));
	}}
  else
    if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */
      {
	uint32_t *dst = (uint32_t *)(bytes + len - 4);
	uint32_t *src = (uint32_t *)bytes;
	while (src < dst)
	  {
	    uint32_t a, b;
	    Loop_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a));
	  }}
    else
#endif
      {
	char *s1 = (char *)bytes;
	char *s2 = (char *)(s1 + len - 1);
	while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;}
      }
  return(str);
}

static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer vec)
{
  const s7_int len = vector_length(vec);
  if (len < 2)
    return(vec); /* (reverse! #i()) -> #i() independent of immutable bit */
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->reverseb_symbol, vec));
  {
    s7_int *ints1 = int_vector_ints(vec);
    s7_int *ints2 = (s7_int *)(ints1 + len - 1);
    if ((len & 0x3f) == 0) /* 63 for 2 32's */
      while (ints1 < ints2)
	{
	  s7_int c;
	  Loop_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c);
	  Loop_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c);
	  Loop_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c);
	  Loop_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c);
	}
    else
      if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed (we're moving 2 at a time) */
	while (ints1 < ints2)
	  {
	    s7_int c;
	    Loop_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c);
	  }
      else while (ints1 < ints2) {s7_int c = *ints1; *ints1++ = *ints2; *ints2-- = c;}
  }
  return(vec);
}

static s7_pointer float_vector_reverse_in_place(s7_scheme *sc, s7_pointer fv)
{
  const s7_int len = vector_length(fv);
  if (len < 2) return(fv);
  if (is_immutable_vector(fv))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->reverseb_symbol, fv));
  {
    s7_double *flts1 = float_vector_floats(fv);
    s7_double *flts2 = (s7_double *)(flts1 + len - 1);
    if ((len & 0x3f) == 0) /* 63 for 2 32's */
      while (flts1 < flts2)
	{
	  s7_double x;
	  Loop_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x);
	  Loop_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x);
	  Loop_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x);
	  Loop_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x);
	}
    else
      if ((len & 0xf) == 0)
	while (flts1 < flts2)
	  {
	    s7_double x;
	    Loop_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x);
	  }
      else while (flts1 < flts2) {s7_double x = *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 = *cmplx1; *cmplx1++ = *cmplx2; *cmplx2-- = z;}
  return(cv);
}

static s7_pointer vector_reverse_in_place(s7_scheme *sc, s7_pointer vec)
{
  const s7_int len = vector_length(vec);
  if (len < 2) return(vec);
  if (is_immutable_vector(vec))
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->reverseb_symbol, vec));
  {
    s7_pointer *vect1 = vector_elements(vec);
    s7_pointer *vect2 = (s7_pointer *)(vect1 + len - 1);
    if ((len & 0x3f) == 0) /* 63 for 2 32's */
      while (vect1 < vect2)
	{
	  s7_pointer c;
	  Loop_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c);
	  Loop_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c);
	  Loop_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c);
	  Loop_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c);
	}
    else
      if ((len & 0xf) == 0)
	while (vect1 < vect2)
	  {
	    s7_pointer c;
	    Loop_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c);
	  }
      else while (vect1 < vect2) {s7_pointer c = *vect1; *vect1++ = *vect2; *vect2-- = c;}
  }
  return(vec);
}

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))
	  sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, car(args), wrap_string(sc, "a proper list", 13));
	sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, 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_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, A_Sequence_String);
    }
  if ((is_simple_sequence(obj)) &&
      (!has_active_methods(sc, obj)))
    sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, wrap_string(sc, "a vector, string, or list", 25));
  return(method_or_bust_p(sc, obj, sc->reverseb_symbol, A_Sequence_String));
}

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);
}


/* -------------------------------- fill! -------------------------------- */
static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) /* args=(list tree-to-fill fill-val start end) */
{
  /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */
  const s7_pointer obj = car(args);
  const s7_pointer val = cadr(args);
  s7_int i, start = 0, end, len;

#if With_History
  if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) && (obj != sc->eval_history2))
#else
  if (is_immutable_pair(obj))
#endif
    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->fill_symbol, obj));
  if (obj == global_value(sc->features_symbol)) /* (let_id(sc->curlet) == symbol_id(sc->features_symbol)) && (obj == local_value(sc->features_symbol))) */
    error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *features*", 22)));
  if (obj == global_value(sc->libraries_symbol))
    error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *libraries*", 23)));

  len = s7_list_length(sc, obj);
  end = len;
  if (end < 0) end = -end; else {if (end == 0) end = 123123123;}
  if (!is_null(cddr(args)))
    {
      s7_pointer p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, &end);
      if (p != sc->unused) return(p);
      if (start == end) return(val);
    }
  if (len > 0)
    {
      s7_pointer p;
      if (end < len) len = end;
      for (i = 0, p = obj; i < start; p = cdr(p), i++);
      for (; i < len; p = cdr(p), i++)
	{
	  if (is_immutable_pair(p))
	    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->fill_symbol, p));
	  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)
	{
	  if (is_immutable_pair(lst))
	    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->fill_symbol, lst));
	  set_car(lst, val);
	}
      if (!is_pair(cdr(lst)))
	{
	  if (!is_null(cdr(lst)))
	    {
	      if (is_immutable_pair(lst))
		immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->fill_symbol, lst));
	      set_cdr(lst, val);
	    }
	  return(val);
	}
      lst = cdr(lst);
      if ((i & 1) != 0) slow = cdr(slow);
      if (lst == slow)
	return(val);
    }
  return(val);
}

s7_pointer s7_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_fill "(fill! obj val (start 0) end) fills obj with val"
  #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol)

  /* individual functions below check for immutable objects (rather than checking once for all here) because
   *   they are used elsewhere, and there are complications (the history lists in pair_fill for example).
   * However, obj might have a setter which disallows val -- I guess we'll run that setter using val,
   *   to get the fill value to use (or raise an error).  But here we have the value not the symbol/slot!
   */
  const s7_pointer obj = car(args);
  switch (type(obj))
    {
    case T_STRING:     return(g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */
    case T_PAIR:       return(pair_fill(sc, args));
    case T_HASH_TABLE: return(hash_table_fill(sc, args));

    case T_NIL:
      if (!is_null(cddr(args)))  /* (fill! () 1 21 #\a)? */
	syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args));
      return(cadr(args));        /* this parallels the empty vector case */

    case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR:
      return(g_vector_fill_1(sc, sc->fill_symbol, args));

    case T_LET:
      if_let_method_exists_return_value(sc, obj, sc->fill_symbol, args);
      return(let_fill(sc, args));

    case T_C_OBJECT:
      if_c_object_method_exists_return_value(sc, obj, sc->fill_symbol, args);
      if (!c_object_fill(sc, obj)) /* default is NULL (s7_make_c_type) */
	syntax_error_nr(sc, "attempt to fill ~S?", 19, obj);
      return((*(c_object_fill(sc, obj)))(sc, args));

    default:
      if_method_exists_return_value(sc, obj, sc->fill_symbol, args);
    }
  wrong_type_error_nr(sc, sc->fill_symbol, 1, obj, A_Sequence_String); /* (fill! 1 0) */
  return(NULL);
}

#define g_fill s7_fill


/* -------------------------------- append -------------------------------- */
static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, uint8_t typ)
{
  s7_pointer seqs = args;
  s7_int len = 0;
  for (s7_int i = 1; is_pair(seqs); seqs = cdr(seqs), i++)
    {
      const s7_pointer seq = car(seqs);
      const s7_int n = sequence_length(sc, seq);
      if ((n > 0) &&
	  (typ != T_FREE) &&
	  ((type(seq) == T_HASH_TABLE) ||  /* can't append hash-tables (no obvious meaning to the operation) */
	   ((type(seq) == T_LET) &&        /*   similarly for lets, unless this is a mock-string or something similar */
	    ((!has_active_methods(sc, seq)) || (find_method(sc, seq, caller) == sc->undefined)))))
	wrong_type_error_nr(sc, caller, i, seq, sc->type_names[typ]);
      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);
}

static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller)
{
  s7_pointer new_vec, p = args, pargs, vtyper = NULL;
  s7_pointer *v_elements = NULL;
  s7_double *fv_elements = NULL;
  s7_complex *cv_elements = NULL;
  s7_int *iv_elements = NULL;
  uint8_t *byte_elements = NULL;
  s7_int len;
  bool typed;

  gc_protect_via_stack(sc, args);
  len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_COMPLEX_VECTOR) ? T_COMPLEX : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER)));
  if (len > sc->max_vector_length)
    {
      unstack_gc_protect(sc);
      error_nr(sc, sc->out_of_range_symbol,
	       set_elist_4(sc, wrap_string(sc, "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", 70),
			   caller,
			   wrap_integer(sc, len),
			   wrap_integer(sc, sc->max_vector_length)));
    }
  new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? Vector_Filled : Vector_Not_Filled, typ);  /* might hit GC in loop below so we can't use Vector_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);
  /* how to check that nothing went wrong in all that mischief with the data? */
  return(new_vec);
}

static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer new_table, key_typer = NULL, value_typer = NULL;
  bool typed = true;
  gc_protect_via_stack(sc, args);
  check_stack_size(sc);
  new_table = s7_make_hash_table(sc, sc->default_hash_table_length);
  set_gc_protected2(sc, new_table);
  for (s7_pointer seqs = args; is_pair(seqs); seqs = cdr(seqs))
    {
      const s7_pointer seq = car(seqs);
      if (!sequence_is_empty(sc, seq))
	{
	  /* perhaps check seq-length+hash_table_entries(new_table) > sc->max_vector_length here? */
	  s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_table));
	  if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq)))
	    {
	      if (!key_typer)
		{ /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */
		  key_typer = hash_table_key_typer(seq);
		  value_typer = hash_table_value_typer(seq);
		}
	      else
		if ((hash_table_key_typer(seq) != key_typer) ||
		    (hash_table_value_typer(seq) != value_typer))
		  typed = false;
	    }
	  else typed = false;
	}}
  if ((typed) && (key_typer))
    {
      hash_table_set_procedures(new_table, make_hash_table_procedures(sc));
      set_is_typed_hash_table(new_table);
      hash_table_set_key_typer(new_table, key_typer);
      hash_table_set_value_typer(new_table, value_typer);
    }
  if (is_weak_hash_table(car(args))) /* 16-May-23, args gc protected above, should we limit weak-hash result to pure weak-hash args? */
    {
      set_weak_hash_table(new_table);
      weak_hash_iters(new_table) = 0;
    }
  set_plist_2(sc, sc->unused, sc->unused);
  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->unused, sc->unused);
  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)

  s7_pointer obj;
  if (is_null(args)) return(sc->nil);   /* (append) -> () */
  obj = car(args);
  if (is_null(cdr(args))) return(obj);  /* (append <anything>) -> <anything> */
  sc->value = args;
  args = copy_proper_list(sc, args);    /* copied since other args might invoke methods */
  sc->value = args;
  switch (type(obj))
    {
    case T_NIL:        return(list_append(sc, cdr(args)));
    case T_PAIR:       return(list_append(sc, args));
    case T_STRING:     return(string_append_1(sc, args, sc->append_symbol));
      /* should this work in the generic append: (append "12" #\3) -- currently an error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */
    case T_HASH_TABLE: return(hash_table_append(sc, args));
    case T_LET:        return(let_append(sc, args));
    case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR:
      return(vector_append(sc, args, type(obj), sc->append_symbol));
    case T_C_OBJECT:
      if_c_object_method_exists_return_value(sc, obj, sc->append_symbol, args); break;
    default:
      if_method_exists_return_value(sc, obj, sc->append_symbol, args);
    }
  wrong_type_error_nr(sc, sc->append_symbol, 1, obj, 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(list_append(sc, list_2(sc, a, b)));
      sc->temp9 = a; /* tempx? */
      q = list_1(sc, car(a));
      begin_temp(sc->temp6, q);
      p = cdr(a);
      np = q;
      for (s7_pointer op = a; (is_pair(p)) && (p != op); p = cdr(p), np = cdr(np), op = cdr(op))
	{
	  set_cdr(np, list_1_unchecked(sc, car(p))); p = cdr(p); np = cdr(np);
	  if (!is_pair(p)) break;
	  set_cdr(np, list_1(sc, car(p)));
	}
      end_temp(sc->temp6);
      if (!is_null(p))
	wrong_type_error_nr(sc, sc->append_symbol, 1, a, A_Proper_List_String);
      sc->temp9 = sc->unused;
      set_cdr(np, b);
      return(q);
    }
  if (is_null(a)) return(b);
  return(g_append(sc, set_plist_2(sc, a, b)));
}

static s7_pointer g_append_2(s7_scheme *sc, s7_pointer args) {return(s7_append(sc, car(args), cadr(args)));}

static s7_pointer append_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr)
{
  if (args == 2) return(sc->append_2);
  return(func);
}


/* -------------------------------- object->list -------------------------------- */
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, s7_Warn_Bufsize, "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->unused);
  sc->temp7 = result;
  ref_index = wrap_mutable_integer(sc, 0); /* was make_mutable_integer 17-Nov-23 */
  lst2 = list_2_unchecked(sc, obj, ref_index);
  gc_lst2 = gc_protect_1(sc, lst2);
  lst = result;
  for (s7_int i = 0; i < len; i++, lst = cdr(lst))
    {
      set_integer(ref_index, i);
      set_car(lst, (*(c_object_ref(sc, obj)))(sc, lst2));
    }
  s7_gc_unprotect_at(sc, gc_lst2);
  sc->temp7 = sc->unused;
  return(result);
}

static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */
{
  switch (type(obj))
    {
    case T_STRING:      return(string_to_list(sc, string_value(obj), string_length(obj)));
    case T_BYTE_VECTOR: return(byte_vector_to_list(sc, byte_vector_bytes(obj), byte_vector_length(obj)));
    case T_HASH_TABLE:  return(hash_table_to_list(sc, obj));
    case T_ITERATOR:    return(iterator_to_list(sc, obj));
    case T_C_OBJECT:    return(c_obj_to_list(sc, obj));
    case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR:
      return(s7_vector_to_list(sc, obj));
    case T_LET:
#if !With_Pure_s7
      if_let_method_exists_return_value(sc, obj, sc->let_to_list_symbol, set_plist_1(sc, obj));
#endif
      return(s7_let_to_list(sc, obj));
    }
  return(obj);
}


/* ---------------- object->let ---------------- */
static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer sym)
{
  const s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, sym,
					sc->type_symbol, (is_keyword(sym)) ? sc->is_keyword_symbol :
					((is_gensym(sym)) ? sc->is_gensym_symbol : sc->is_symbol_symbol));
  if (!is_keyword(sym))
    {
      const s7_int gc_loc = gc_protect_1(sc, let);
      const s7_pointer val = s7_symbol_value(sc, sym);
      if (!sc->current_value_symbol)
	sc->current_value_symbol = make_symbol(sc, "current-value", 13);
      s7_varlet(sc, let, sc->current_value_symbol, val);
      s7_varlet(sc, let, sc->setter_symbol, setter_p_pp(sc, sym, sc->curlet));
      s7_varlet(sc, let, sc->is_mutable_symbol, make_boolean(sc, !is_immutable_symbol(sym)));
      if (!is_undefined(val))
	{
	  const char *doc = s7_documentation(sc, sym);
	  if (doc)
	    s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc));
	}
      s7_gc_unprotect_at(sc, gc_loc);
    }
  return(let);
}

static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer rs)
{
#if With_Gmp
  return(internal_inlet(sc, 4, sc->value_symbol, rs, sc->type_symbol, sc->is_random_state_symbol));
#else
  if (!sc->seed_symbol)
    {
      sc->seed_symbol = make_symbol(sc, "seed", 4);
      sc->carry_symbol = make_symbol(sc, "carry", 5);
    }
  return(internal_inlet(sc, 8, sc->value_symbol, rs,
			sc->type_symbol, sc->is_random_state_symbol,
			sc->seed_symbol, make_integer(sc, random_seed(rs)),
			sc->carry_symbol, make_integer(sc, random_carry(rs))));
#endif
}

static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer vec)
{
  s7_pointer let;
  if (!sc->dimensions_symbol) sc->dimensions_symbol = make_symbol(sc, "dimensions", 10);
  if (!sc->original_vector_symbol) sc->original_vector_symbol = make_symbol(sc, "original-vector", 15);
  let = internal_inlet(sc, 10, sc->value_symbol, vec,
		       sc->type_symbol, (is_subvector(vec)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(vec))) : s7_type_of(sc, vec),
		       sc->size_symbol, s7_length(sc, vec),
		       sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, vec)),
		       sc->is_mutable_symbol, make_boolean(sc, !is_immutable_vector(vec)));
  gc_protect_via_stack(sc, let);
  if (is_subvector(vec))
    {
      s7_int pos = 0;
      switch (type(vec)) /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */
	{
	  case T_VECTOR:         pos = (s7_int)((intptr_t)(vector_elements(vec) - vector_elements(subvector_vector(vec))));         break;
	  case T_INT_VECTOR:     pos = (s7_int)((intptr_t)(int_vector_ints(vec) - int_vector_ints(subvector_vector(vec))));         break;
	  case T_FLOAT_VECTOR:   pos = (s7_int)((intptr_t)(float_vector_floats(vec) - float_vector_floats(subvector_vector(vec)))); break;
	  case T_COMPLEX_VECTOR: pos = (s7_int)((intptr_t)(complex_vector_complexes(vec) - complex_vector_complexes(subvector_vector(vec)))); break;
	  case T_BYTE_VECTOR:    pos = (s7_int)((intptr_t)(byte_vector_bytes(vec) - byte_vector_bytes(subvector_vector(vec))));     break;
	}
      s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos));
      s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(vec));
    }
  if (is_typed_t_vector(vec))
    s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, vec)));

#if s7_Debugging
  if ((is_t_vector(vec)) && (is_symbol_table(vec))) /* (object->let (symbol-table)) */
    {
      s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0;
      for (s7_int i = 0; i < Symbol_Table_Size; i++)
	{
	  s7_int entries;
	  s7_pointer syms = vector_element(sc->symbol_table, i);
	  for (entries = 0; is_pair(syms); syms = cdr(syms), entries++);
	  if (entries == 0) zeros++; else
	    if (entries == 1) ones++;  else
	      if (entries == 2) twos++; else
		biggies++;
	  if (entries > max_len) max_len = entries;
	}
      s7_varlet(sc, let, make_symbol(sc, "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 void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer table)
{
  if ((hash_table_checker(table) == hash_eq) ||
      (hash_table_checker(table) == hash_c_function) ||
      (hash_table_checker(table) == hash_closure) ||
      (hash_table_checker(table) == hash_equal_eq) ||
      (hash_table_checker(table) == hash_equal_syntax) ||
      (hash_table_checker(table) == hash_symbol))
    s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol);
  else
    if (hash_table_checker(table) == hash_eqv)
      s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol);
    else
      if ((hash_table_checker(table) == hash_equal) ||
	  (hash_table_checker(table) == hash_empty))
	s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol);
      else
	if (hash_table_checker(table) == hash_equivalent)
	  s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol);
	else
	  if ((hash_table_checker(table) == hash_number_num_eq) ||
	      (hash_table_checker(table) == hash_int) ||
	      (hash_table_checker(table) == hash_float))
	    s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol);
	  else
	    if (hash_table_checker(table) == hash_string)
	      s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol);
	    else
	      if (hash_table_checker(table) == hash_char)
		s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol);
#if !With_Pure_s7
	      else
		if (hash_table_checker(table) == hash_ci_char)
		  s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol);
		else
		  if (hash_table_checker(table) == hash_ci_string)
		    s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol);
#endif
}

static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer table)
{
  s7_pointer let;
  s7_int gc_loc;
  if (!sc->entries_symbol)
    {
      sc->entries_symbol = make_symbol(sc, "entries", 7);
      sc->weak_symbol = make_symbol(sc, "weak", 4);
    }
  let = internal_inlet(sc, 10, sc->value_symbol, table,
		       sc->type_symbol, sc->is_hash_table_symbol,
		       sc->size_symbol, s7_length(sc, table),
		       sc->entries_symbol, make_integer(sc, hash_table_entries(table)),
		       sc->is_mutable_symbol, make_boolean(sc, !is_immutable_hash_table(table)));
  gc_loc = gc_protect_1(sc, let);
  if (is_weak_hash_table(table))
    s7_varlet(sc, let, sc->weak_symbol, sc->T);

  if (is_typed_hash_table(table))
    {
      const s7_pointer checker = hash_table_procedures_checker(table);
      if (checker == sc->T)  /* perhaps typed because typers were set, but not checker/mapper */
	hash_table_checker_to_let(sc, let, table);
      else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(table)));
      s7_varlet(sc, let, sc->signature_symbol,
	            (is_typed_hash_table(table)) ?
		      list_3(sc,
			     hash_table_typer_symbol(sc, hash_table_value_typer(table)),
			     sc->is_hash_table_symbol,
			     hash_table_typer_symbol(sc, hash_table_key_typer(table))) :
 	              sc->hash_table_signature);
    }
  else hash_table_checker_to_let(sc, let, table);

#if s7_Debugging
  if (hash_table_entries(table) > 0)
    {
      s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0;
      const s7_int hash_len = (s7_int)hash_table_size(table);
      for (s7_int i = 0; i < hash_len; i++)
	{
	  hash_entry_t *entry = hash_table_element(table, i);
	  s7_int entries;
	  for (entries = 0; entry; entry = hash_entry_next(entry), entries++);
	  if (entries == 0) zeros++; else
	    if (entries == 1) ones++;  else
	      if (entries == 2) twos++; else
		biggies++;
	  if (entries > max_len) max_len = entries;
	}
      s7_varlet(sc, let, make_symbol(sc, "hash-stats:empty|1|2|n|most", 27),
		cons(sc, make_integer(sc, zeros),
		     cons(sc, make_integer(sc, ones),
			  cons(sc, make_integer(sc, twos),
			       cons(sc, make_integer(sc, biggies),
				    cons(sc, make_integer(sc, max_len), sc->nil))))));
    }
#endif
  s7_gc_unprotect_at(sc, gc_loc);
  return(let);
}

static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer iter)
{
  s7_pointer let;
  const s7_pointer seq = iterator_sequence(iter);
  if (!sc->at_end_symbol)
    {
      sc->at_end_symbol = make_symbol(sc, "at-end", 6);
      sc->sequence_symbol = make_symbol(sc, "sequence", 8);
    }
  let = internal_inlet(sc, 8, sc->value_symbol, iter,
		       sc->type_symbol, sc->is_iterator_symbol,
		       sc->at_end_symbol, make_boolean(sc, iterator_is_at_end(iter)),
		       sc->sequence_symbol, iterator_sequence(iter));
  gc_protect_via_stack(sc, let);
  if (is_pair(seq))
    s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq));
  else
    if (is_hash_table(seq))
      s7_varlet(sc, let, sc->size_symbol, make_integer(sc, hash_table_entries(seq)));
    else s7_varlet(sc, let, sc->size_symbol, s7_length(sc, iter));
  if ((is_string(seq)) ||
      (is_any_vector(seq)) ||
      (seq == sc->rootlet) ||
      (is_c_object(seq)) ||
      (is_hash_table(seq)))
    s7_varlet(sc, let, sc->position_symbol, make_integer(sc, iterator_position(iter)));
  else
    if (is_pair(seq))
      s7_varlet(sc, let, sc->position_symbol, iterator_current(iter));
  unstack_gc_protect(sc);
  return(let);
}

static s7_pointer let_to_let(s7_scheme *sc, s7_pointer let)
{
  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);
      sc->setters_symbol = make_symbol(sc, "setters", 7);
    }
  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 ((s7_Debugging) && (let == sc->owlet)) fprintf(stderr, "%s[%d]: got owlet?\n", __func__, __LINE__);
  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);
	}
  {
    s7_int setter_loc = -1;
    s7_pointer setter_list = sc->nil;
    for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
      if (slot_has_setter(slot))
	{
	  if (is_bool_function(slot_setter(slot)))
	    setter_list = cons(sc, slot_symbol(slot), cons(sc, c_function_setter(slot_setter(slot)), setter_list));
 	                                                    /* initial_value(c_function_symbol(slot_setter(slot))) */
	  else setter_list = cons(sc, slot_symbol(slot), cons(sc, slot_setter(slot), setter_list));
	  if (setter_loc == -1)
	    setter_loc = s7_gc_protect(sc, setter_list);
	  else s7_gc_protect_via_location(sc, setter_list, setter_loc);
	}
    if (setter_loc != -1)
      {
	s7_varlet(sc, new_let, sc->setters_symbol, setter_list);
	s7_gc_unprotect_at(sc, setter_loc);
      }}

  if (has_active_methods(sc, let))
    {
      s7_pointer func = find_method(sc, let, sc->object_to_let_symbol);
      if (func != sc->undefined)
	s7_apply_function(sc, func, set_plist_2(sc, let, new_let));
    }
  s7_gc_unprotect_at(sc, gc_loc);
  return(new_let);
}

static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer cobj)
{
  s7_pointer let;
  const s7_pointer clet = c_object_let(cobj);
  if (!sc->class_symbol)
    sc->class_symbol = make_symbol(sc, "class", 5);
  let = internal_inlet(sc, 8, sc->value_symbol, cobj,
		       sc->type_symbol, sc->is_c_object_symbol,
		       sc->c_object_type_symbol, make_integer(sc, c_object_type(cobj)),
		       sc->c_object_let_symbol, clet);
  gc_protect_via_stack(sc, let);
  g_varlet(sc, set_plist_3(sc, let, sc->class_symbol, c_object_type_to_let(sc, cobj)));
  if ((is_let(clet)) &&
      ((has_active_methods(sc, clet)) || (has_active_methods(sc, cobj))))
    {
      s7_pointer func = find_method(sc, clet, sc->object_to_let_symbol);
      if (func != sc->undefined)
	s7_apply_function(sc, func, set_plist_2(sc, cobj, let));
    }
  unstack_gc_protect(sc);
  return(let);
}

static s7_pointer port_to_let(s7_scheme *sc, s7_pointer port) /* note the underbars! */
{
  s7_pointer let;
  s7_int gc_loc;
  if (!sc->data_symbol)
    {
      sc->data_symbol = make_symbol(sc, "data", 4);
      sc->port_type_symbol = make_symbol(sc, "port-type", 9);
      sc->closed_symbol = make_symbol(sc, "closed", 6);
      sc->file_info_symbol = make_symbol(sc, "file-info", 9);
      sc->fileno_symbol = make_symbol(sc, "fileno", 6);
    }
  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->fileno_symbol, make_integer(sc, fileno(port_file(port))));
	  if (fstat(fileno(port_file(port)), &sb) != -1)
	    {
	      #define Time_Bufsize 64
	      #define Str_Bufsize 512
	      char c1[Time_Bufsize], c2[Time_Bufsize], str[Str_Bufsize];
	      int32_t bytes;
	      strftime(c1, Time_Bufsize, "%a %d-%b-%Y %H:%M", localtime(&sb.st_atime));
	      strftime(c2, Time_Bufsize, "%a %d-%b-%Y %H:%M", localtime(&sb.st_mtime));
	      bytes = snprintf(str, Str_Bufsize, "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))
    {
      const 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);
	#define S_Bufsize 24
	char data_str[24], str[S_Bufsize];
	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, S_Bufsize, "%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)))
    {
      const 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 continuation_to_let(s7_scheme *sc, s7_pointer cont)
{
  const s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, cont, sc->type_symbol, sc->is_continuation_symbol);
  gc_protect_via_stack(sc, let);
  if (is_symbol(continuation_name(cont)))
    s7_varlet(sc, let, sc->name_symbol, continuation_name(cont));
  if (continuation_key(cont) != Not_Baffled)
    s7_varlet(sc, let, make_symbol(sc, "key", 3), make_integer(sc, continuation_key(cont)));
  unstack_gc_protect(sc);
  return(let);
}

static s7_pointer string_to_let(s7_scheme *sc, s7_pointer obj)
{
  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))));
}

static s7_pointer pair_to_let(s7_scheme *sc, s7_pointer obj)
{
  return(internal_inlet(sc, 6, sc->value_symbol, obj,
			sc->type_symbol, sc->is_pair_symbol,
			sc->size_symbol, pair_length(sc, obj)));
}

static s7_pointer syntax_to_let(s7_scheme *sc, s7_pointer obj)
{
  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))));
}

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_PAIR:         return(pair_to_let(sc, obj));
    case T_CHARACTER:    return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_char_symbol));
    case T_STRING:       return(string_to_let(sc, obj));
    case T_SYMBOL:       return(symbol_to_let(sc, obj));
    case T_SYNTAX:       return(syntax_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_CONTINUATION: return(continuation_to_let(sc, obj));
    case T_C_POINTER:    return(c_pointer_to_let(sc, obj));
    case T_ITERATOR:     return(iterator_to_let(sc, obj));
    case T_HASH_TABLE:   return(hash_table_to_let(sc, obj));
    case T_LET:          return(let_to_let(sc, obj));
    case T_C_OBJECT:     return(c_object_to_let(sc, obj));
    case T_INPUT_PORT:
    case T_OUTPUT_PORT:  return(port_to_let(sc, obj));

    case T_INTEGER: case T_BIG_INTEGER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol));
    case T_RATIO:   case T_BIG_RATIO:   return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol));
    case T_REAL:    case T_BIG_REAL:    return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol));
    case T_COMPLEX: case T_BIG_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol));

    case T_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_CLOSURE: case T_CLOSURE_STAR: case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR:
      return(closure_to_let(sc, obj));

    case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION:
      return(c_function_to_let(sc, obj));

    default:
      return(sc->F);
    }
  return(sc->F);
}

static s7_pointer g_object_to_let(s7_scheme *sc, s7_pointer args)
{
  #define H_object_to_let "(object->let obj) returns a let (namespace) describing obj."
  #define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T)
  return(object_to_let_p_p(sc, car(args)));
}


/* ---------------- stacktrace ---------------- */
static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer 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 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_int stacktrace_find_error_hook_quit(s7_scheme *sc)
{
  for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4)
    if (stack_op(sc->stack, op_loc) == OP_ERROR_HOOK_QUIT)
      return(op_loc);
  return(-1);
}

static bool stacktrace_in_error_handler(s7_scheme *sc, s7_int loc)
{
  return((let_outlet(sc->owlet) == sc->curlet) ||
	 (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) ||
	 (stacktrace_find_error_hook_quit(sc) > 0));
}

static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym)
{
  if (is_symbol(sym))
    {
      const 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);
  }
}

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);
		    }}}}}
  end_small_symbol_set(sc);
  return((strp) ? block_to_string(sc, strp, safe_strlen((char *)block_data(strp))) : nil_string);
}

s7_pointer s7_stacktrace(s7_scheme *sc)
{
  return(stacktrace_1(sc,
		      s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)),
		      s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)),
		      s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)),
		      s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)),
		      s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4))));
}

static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args)
{
  #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 45) (total-cols 80) (note-col 45) as-comment) returns \
a stacktrace as a string.  Each line has two portions, the code being evaluated and a note giving \
the value of local variables in that code.  The first argument sets how many lines are displayed. \
The next three arguments set the length and layout of those lines.  'as-comment' if #t causes each \
line to be preceded by a semicolon."
  #define Q_stacktrace s7_make_signature(sc, 6, \
                         sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, \
                         sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol)

  /* now: 30, 45, 80, 45, #f and applied here as well as in s7_stacktrace, 22-Jan-25 */
  #define St_Max_Frames 30
  #define St_Code_Cols 45
  #define St_Total_Cols 80
  #define St_Notes_Start_Col 45
  #define St_As_Comment false

  s7_int max_frames = s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults));
  s7_int code_cols = s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults));
  s7_int total_cols = s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults));
  s7_int notes_start_col = s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults));
  bool as_comment = s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4));

  if (!is_null(args))
    {
      if (!s7_is_integer(car(args)))
	return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1));
      max_frames = s7_integer_clamped_if_gmp(sc, car(args));
      if ((max_frames <= 0) || (max_frames > s7_Int32_Max))
	max_frames = St_Max_Frames;
      args = cdr(args);
      if (!is_null(args))
	{
	  if (!s7_is_integer(car(args)))
	    wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]);
	  code_cols = s7_integer_clamped_if_gmp(sc, car(args));
	  if ((code_cols <= 8) || (code_cols > 1024))
	    code_cols = St_Code_Cols;
	  args = cdr(args);
	  if (!is_null(args))
	    {
	      if (!s7_is_integer(car(args)))
		wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]);
	      total_cols = s7_integer_clamped_if_gmp(sc, car(args));
	      if ((total_cols <= code_cols) || (total_cols > s7_Int32_Max))
		total_cols = St_Total_Cols;
	      args = cdr(args);
	      if (!is_null(args))
		{
		  if (!s7_is_integer(car(args)))
		    wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]);
		  notes_start_col = s7_integer_clamped_if_gmp(sc, car(args));
		  if ((notes_start_col <= 0) || (notes_start_col > s7_Int32_Max))
		    notes_start_col = St_Notes_Start_Col;
		  args = cdr(args);
		  if (!is_null(args))
		    {
		      if (!is_boolean(car(args)))
			wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]);
		      as_comment = s7_boolean(sc, car(args));
		    }}}}}
  return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment));
}


/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */

s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry)
{
#if With_History
  set_current_code(sc, entry);
#endif
  return(entry);
}

s7_pointer s7_history(s7_scheme *sc)
{
#if With_History
  if (sc->cur_code == sc->history_sink)
    return(sc->old_cur_code);
#endif
  return(sc->cur_code);
}

bool s7_history_enabled(s7_scheme *sc)
{
#if With_History
  return(sc->cur_code != sc->history_sink);
#else
  return(false);
#endif
}

bool s7_set_history_enabled(s7_scheme *sc, bool enabled)
{
#if With_History
  const bool old_enabled = (sc->cur_code == sc->history_sink);
  if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */
    sc->cur_code = sc->old_cur_code;
  else
    if (sc->cur_code != sc->history_sink)
      {
	sc->old_cur_code = sc->cur_code;
	sc->cur_code = sc->history_sink;
      }
  return(old_enabled);
#else
  return(false);
#endif
}

#if With_History
static s7_pointer history_cons(s7_scheme *sc, s7_pointer code, s7_pointer args)
{
  const 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


/* -------------------------------- 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
  if ((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")));
#endif
  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;
}

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);
}

#define Pd_Initial_Size 16
enum {Pd_Calls = 0, Pd_Recur, Pd_Start, Pd_Itotal, Pd_Etotal, Pd_Block_Size};

static s7_pointer g_profile_out(s7_scheme *sc, s7_pointer args)
{
  const s7_int pos = integer(car(args)) * Pd_Block_Size;
  profile_data_t *pd = sc->profile_data;
  s7_int *v = (s7_int *)(pd->timing_data + pos);
  v[Pd_Recur]--;
  if (v[Pd_Recur] == 0)
    {
      const s7_int cur_time = (my_clock() - v[Pd_Start]);
      v[Pd_Itotal] += cur_time;
      v[Pd_Etotal] += (cur_time - pd->excl[pd->excl_top]);
      pd->excl_top--;
      pd->excl[pd->excl_top] += cur_time;
    }
  return(sc->F);
}

static s7_pointer g_profile_in(s7_scheme *sc, s7_pointer args) /* only external func -- added to each profiled func by add_profile above */
{
  #define H_profile_in "(profile-in e) is the profiler's hook into closures"
  #define Q_profile_in s7_make_signature(sc, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol)

  s7_pointer 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);
	    }}
      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]++;

      /* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks).
       *   swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth.
       */
      if (sc->stack_end >= sc->stack_resize_trigger)
	{
	  #define Profile_Max_Stack_Size 10000000  /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */
	  if (sc->stack_size > Profile_Max_Stack_Size)
	    error_nr(sc, make_symbol(sc, "stack-too-big", 13),
		     set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_integer(sc, Profile_Max_Stack_Size)));
	  /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is
	   *   a very rare problem, and the results will be confusing anyway.
	   */
	  resize_stack(sc);
	}
      swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, car(args));
    }
  return(sc->F);
}

static s7_pointer profile_info_out(s7_scheme *sc)
{
  s7_pointer new_list, vs, vi, vn, vf, vl, matches;
  profile_data_t *pd = sc->profile_data;
  if ((!pd) || (pd->top == 0)) return(sc->F);
  new_list = make_list(sc, 7, sc->unused);
  set_car(sc->elist_7, new_list); /* protect new_list */
  set_car(new_list, vs = make_simple_vector(sc, pd->top));
  set_cadr(new_list, vi = make_simple_int_vector(sc, pd->top * Pd_Block_Size));
  set_caddr(new_list, make_integer(sc, ticks_per_second()));
  {
    const s7_pointer mid_list = cdddr(new_list);
    set_car(mid_list, vn = make_simple_vector(sc, pd->top));
    set_cadr(mid_list, vf = make_simple_vector(sc, pd->top));
    set_caddr(mid_list, vl = make_simple_int_vector(sc, pd->top));
    matches = cdddr(mid_list);
  }
  set_car(matches, sc->nil);
  for (s7_int i = 0; i < pd->top; i++)
    {
      if (pd->funcs[i])
	{
	  vector_element(vs, i) = pd->funcs[i];
	  if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */
	      (!direct_memq(pd->funcs[i], car(matches))))
	    set_car(matches, cons(sc, pd->funcs[i], car(matches)));
	  set_match_symbol(pd->funcs[i]);
	}
      else vector_element(vs, i) = sc->F;
      vector_element(vn, i) = (!pd->let_names[i]) ? sc->F : pd->let_names[i];
      vector_element(vf, i) = (!pd->files[i]) ? sc->F : pd->files[i];
    }
  for (s7_int i = 0; i < pd->top; i++) if (pd->funcs[i]) clear_match_symbol(pd->funcs[i]);
  memcpy((void *)int_vector_ints(vl), (void *)pd->lines, pd->top * sizeof(s7_int));
  memcpy((void *)int_vector_ints(vi), (void *)pd->timing_data, pd->top * Pd_Block_Size * sizeof(s7_int));
  set_car(sc->elist_7, sc->unused);
  return(new_list);
}

static s7_pointer clear_profile_info(s7_scheme *sc)
{
  if (sc->profile_data)
    {
      profile_data_t *pd = sc->profile_data;
      memclr(pd->timing_data, pd->top * Pd_Block_Size * sizeof(s7_int));
      memclr(pd->funcs, pd->top * sizeof(s7_pointer));
      memclr(pd->let_names, pd->top * sizeof(s7_pointer));
      memclr(pd->files, pd->top * sizeof(s7_pointer));
      memclr(pd->lines, pd->top * sizeof(s7_int));
      pd->top = 0;
      for (int32_t i = 0; i < pd->excl_top; i++)
	pd->excl[i] = 0;
      pd->excl_top = 0;
      sc->profiling_gensyms = false;
    }
  return(sc->F);
}

static s7_pointer make_profile_info(s7_scheme *sc)
{
  if (!sc->profile_data)
    {
      profile_data_t *pd = (profile_data_t *)Malloc(sizeof(profile_data_t));
      pd->size = Pd_Initial_Size;
      pd->excl_size = Pd_Initial_Size;
      pd->top = 0;
      pd->excl_top = 0;
      pd->funcs = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
      pd->let_names = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
      pd->files = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
      pd->lines = (s7_int *)Calloc(pd->size, sizeof(s7_int));
      pd->excl = (s7_int *)Calloc(pd->excl_size, sizeof(s7_int));
      pd->timing_data = (s7_int *)Calloc(pd->size * Pd_Block_Size, sizeof(s7_int));
      sc->profile_data = pd;
    }
  return(sc->F);
}


/* -------------------------------- dynamic-unwind -------------------------------- */
static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer args)
{
  return(s7_apply_function(sc, func, set_plist_2(sc, args, sc->value))); /* s7_apply_function returns sc->value */
}

static s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args) /* not fool-proof!! */
{
  #define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds."
  #define Q_dynamic_unwind s7_make_signature(sc, 4, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T, sc->is_boolean_symbol)

  const s7_pointer func = car(args);
  const s7_pointer dw_call = (is_pair(cddr(args))) ? caddr(args) : sc->F;
  if (!is_boolean(dw_call))
    wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 2, dw_call, A_Boolean_String);
  if (((is_closure(func)) && (closure_arity_to_int(sc, func) == 2))           ||
      ((is_c_function(func)) && (c_function_is_aritable(func, 2)))            ||
      ((is_closure_star(func)) && (closure_star_arity_to_int(sc, func) == 2)) ||
      ((is_c_function_star(func)) && (c_function_max_args(func) == 2)))
    swap_stack(sc, OP_DYNAMIC_UNWIND, func, copy_proper_list(sc, cdr(args)));
  else wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 1, func, wrap_string(sc, "a procedure of two arguments", 28));
  return(cadr(args)); /* ?? */
}


/* -------------------------------- catch -------------------------------- */
static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
{
  #define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called"
  #define Q_catch s7_make_signature(sc, 4, sc->values_symbol, \
                    s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), \
                    sc->is_procedure_symbol, sc->is_procedure_symbol)
  s7_pointer proc, err;

  /* Guile sets up the catch before looking for arg errors: (catch #t log (lambda args "hiho")) -> "hiho"
   *   which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...)
   *   but what if the error handler arg is messed up?  Seems weird to handle args in reverse order with an intervening let etc.
   *   I think log as the second arg is an outer error (we don't wait until the catch is called, then fall into
   *   the local error handler).
   */
  /* if ((is_let(err)) && (is_openlet(err))) if_let_method_exists_return_value(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */
  if (Eval_Print) fprintf(stderr, "  %s[%d]\n", __func__, __LINE__);

  if (!is_pair(cdr(args))) /* (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) -- this is a special case, avoid calling this everywhere */
    error_nr(sc, sc->syntax_error_symbol,
	     set_elist_2(sc, wrap_string(sc, "catch: function missing: ~S", 27), set_ulist_1(sc, sc->catch_symbol, args)));
  proc = cadr(args);
  if (!is_thunk(sc, proc))
    {
      if (is_any_procedure(proc))        /* i.e. c_function, lambda, macro, etc */
	{
	  s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc));
	  error_nr(sc, sc->wrong_type_arg_symbol,
		   set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but catch's second argument should be a thunk", 72), proc, req_args, req_args));
	}
      else wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, A_Thunk_String);
    }
  if (!is_pair(cddr(args)))
    error_nr(sc, sc->syntax_error_symbol,
	     set_elist_2(sc, wrap_string(sc, "catch: error handler missing: ~S", 32), set_ulist_1(sc, sc->catch_symbol, args)));
  err = caddr(args);
  if (!is_applicable(err))
    wrong_type_error_nr(sc, sc->catch_symbol, 3, err, Something_Applicable_String);
  /* should we check here for (aritable? err 2)?  (catch #t (lambda () 1) "hiho") -> 1
   * currently this is checked only if the error handler is called
   */
  {
    s7_pointer new_catch;
    new_cell(sc, new_catch, T_CATCH);
    catch_tag(new_catch) = car(args);
    catch_goto_loc(new_catch) = stack_top(sc);
    catch_op_loc(new_catch) = (int32_t)(sc->op_stack_now - sc->op_stack);
    catch_set_handler(new_catch, err);
    catch_cstack(new_catch) = sc->Goto_Start;
    push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, new_catch);
  }
  if (is_closure(proc))                        /* not also lambda* here because we need to handle the arg defaults */
    {
      /* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=()
       *    the case that caught this: (catch #t make-hook ...)
       */
      sc->code = closure_body(proc);
      if (is_symbol(closure_pars(proc)))
	set_curlet(sc, make_let_with_slot(sc, closure_let(proc), closure_pars(proc), sc->nil));
      else set_curlet(sc, inline_make_let(sc, closure_let(proc)));
      push_stack_no_args_direct(sc, sc->begin_op);
    }
  else push_stack(sc, OP_APPLY, sc->nil, proc);
  return(sc->F);
}

s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler)
{
  s7_pointer new_catch, result;
  if (sc->stack_end == sc->stack_start) /* no stack! */
    push_stack_direct(sc, OP_EVAL_DONE);

  if (Eval_Print) 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 Eval_Print
    fprintf(stderr, "jump_loc: %s\n", jump_string[(int)jump_loc]);
#endif
    if (jump_loc == No_Jump)
      {
	catch_cstack(new_catch) = &new_goto_start;
	if (Eval_Print) 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 Eval_Print
	fprintf(stderr, "  jump back with %s (%d)\n", jump_string[(int)jump_loc], (sc->stack_end == sc->stack_start));
#endif
	if (jump_loc != Error_Jump)
	  eval(sc, sc->cur_op);
	if ((jump_loc == Catch_Jump) &&    /* we're returning from an error in catch */
	    ((sc->stack_end == sc->stack_start) ||
	     (((sc->stack_end - 4) == sc->stack_start) && (stack_top_op(sc) == OP_GC_PROTECT)))) /* s7_apply_function probably */
	  push_stack_op(sc, OP_ERROR_QUIT);
	result = sc->value;
      }
    restore_jump_info(sc);
  }
  return(result);
}

static void op_c_catch(s7_scheme *sc)
{
  /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args))
   *    code is (catch #t (lambda () ....) (lambda args ....))
   */
  s7_pointer new_catch, tag;
  const s7_pointer ptag = cadr(sc->code), args = cddr(sc->code);

  /* defer making the error lambda */
  if (!is_pair(ptag))                      /* (catch #t ...) or (catch sym ...) */
    tag = (is_symbol(ptag)) ? lookup_checked(sc, ptag) : ptag;
  else tag = cadr(ptag);                   /* (catch 'sym ...) */

  new_cell(sc, new_catch, T_CATCH);                /* the catch object sitting on the stack */
  catch_tag(new_catch) = tag;
  catch_goto_loc(new_catch) = stack_top(sc);
  catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack;
  catch_set_handler(new_catch, cdadr(args));       /* not yet a closure... */
  catch_cstack(new_catch) = sc->Goto_Start;
  push_stack(sc, OP_CATCH_1, sc->code, new_catch); /* code ignored here, except by GC */
  set_curlet(sc, inline_make_let(sc, sc->curlet));
  sc->code = T_Pair(cddar(args));
}

static void op_c_catch_all(s7_scheme *sc)
{
  s7_pointer new_catch;
  new_cell(sc, new_catch, T_CATCH);
  catch_tag(new_catch) = sc->T;
  catch_goto_loc(new_catch) = stack_top(sc);
  catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack;
  catch_set_handler(new_catch, sc->nil);
  catch_cstack(new_catch) = sc->Goto_Start;
  push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), new_catch);  /* push_stack: op args code */
  sc->code = T_Pair(opt1_pair(cdr(sc->code)));                  /* the body of the first lambda (or car of it if catch_all_o) */
}

static void op_c_catch_all_a(s7_scheme *sc)
{
  op_c_catch_all(sc);
  sc->value = fx_call(sc, sc->code);
}


/* -------------------------------- owlet -------------------------------- */
/* error reporting info -- save filename and line number */

static s7_pointer init_owlet(s7_scheme *sc)
{
  s7_pointer p = set_elist_7(sc,
			     make_symbol(sc, "error-type", 10),
			     make_symbol(sc, "error-data", 10),
			     make_symbol(sc, "error-code", 10),
			     make_symbol(sc, "error-line", 10),
			     make_symbol(sc, "error-file", 10),
			     make_symbol(sc, "error-position", 14),
			     make_symbol(sc, "error-history", 13));
  const s7_pointer let = make_semipermanent_let(sc, p); /* all values are sc->F */
  s7_pointer slot = let_slots(let);
  sc->error_type = slot;     /* the error type or tag ('division-by-zero) */
  slot = next_slot(slot);
  sc->error_data = slot;     /* the message or information passed by the error function */
  slot = next_slot(slot);
  sc->error_code = slot;     /* the code that s7 thinks triggered the error */
  slot = next_slot(slot);
  sc->error_line = slot;     /* the line number of that code */
  slot_set_value(slot, make_permanent_integer(0));
  add_saved_pointer(sc, slot_value(slot));
  slot = next_slot(slot);
  sc->error_file = slot;     /* the file name of that code */
  slot = next_slot(slot);
  sc->error_position = slot; /* file-byte position of that code */
  slot_set_value(slot, make_permanent_integer(0));
  add_saved_pointer(sc, slot_value(slot));
#if With_History
  slot = next_slot(slot);
  sc->error_history = slot;  /* buffer of previous evaluations */
#endif
  let_set_outlet(let, sc->rootlet);
  return(let);
}

#if With_History
static s7_pointer sanitize_history(s7_scheme *sc, s7_pointer code)
{
  begin_small_symbol_set(sc); /* make a list of words banned from the history */
  add_symbol_to_small_symbol_set(sc, sc->starlet_symbol);
  add_symbol_to_small_symbol_set(sc, sc->eval_symbol);
  add_symbol_to_small_symbol_set(sc, make_symbol(sc, "debug", 5));
  add_symbol_to_small_symbol_set(sc, sc->trace_in_symbol);
  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

static s7_pointer g_owlet(s7_scheme *sc, s7_pointer args)
{
#if With_History
  #define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history."
#else
  #define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, and error-file."
#endif
  #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol)
  /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */

  s7_pointer let;
  const bool old_gc = sc->gc_off;
  if (is_pair(args))
    error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, Too_Many_Arguments_String, sc->owlet_symbol, args));
#if With_History
  slot_set_value(sc->error_history, sanitize_history(sc, slot_value(sc->error_history)));
#endif
  let = let_copy(sc, sc->owlet);
  gc_protect_via_stack(sc, let);

  /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */
  sc->gc_off = true;
  for (s7_pointer slot = let_slots(let); is_slot_checked(slot); slot = next_slot(slot))
    if (is_pair(slot_value(slot)))
      {
	const s7_pointer new_list = copy_any_list(sc, slot_value(slot));
	slot_set_value(slot, new_list);
	for (s7_pointer p = new_list, sp = p; is_pair(p); p = cdr(p), sp = cdr(sp))
	  {
	    s7_pointer val = car(p);
	    if (is_t_real(val))
	      set_car(p, make_real(sc, real(val)));
	    else
	      if (is_string(val))
		set_car(p, make_string_with_length(sc, string_value(val), string_length(val)));
	      else
		if (is_t_integer(val))
		  set_car(p, make_integer(sc, integer(val)));
	    p = cdr(p);
	    if ((!is_pair(p)) || (p == sp)) break;
	    val = car(p);
	    if (is_t_real(val))
	      set_car(p, make_real(sc, real(val)));
	    else
	      if (is_string(val))
		set_car(p, make_string_with_length(sc, string_value(val), string_length(val)));
	  }}
  sc->gc_off = old_gc;
  unstack_gc_protect(sc);
  return(let);
}


/* -------- 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 unused_info)
{
  const s7_pointer catcher = T_Cat(stack_code(sc->stack, catch_loc));
  if (Eval_Print) 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 (Eval_Print) 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 (Eval_Print) 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 = cons(sc, type, info); /* was list_2 21-Apr-26, (lambda args args) as handler */
	      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 Eval_Print && s7_Debugging
	      if (loc > 4) {fprintf(stderr, "  about to pop_stack: \n"); s7_show_stack(sc);}
#endif
	      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 unused_type, s7_pointer unused_info)
{
  const s7_pointer dw = T_Dyn(stack_code(sc->stack, catch_loc));
  if (Eval_Print) 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 unused_type, s7_pointer unused_info)
{
  s7_pointer port = T_Pro(stack_code(sc->stack, catch_loc));   /* "code" = port that we opened */
  if (Eval_Print) 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 #<unused> */
  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 unused_type, s7_pointer unused_info)
{
  s7_pointer port = T_Pri(stack_code(sc->stack, catch_loc));   /* "code" = port that we opened */
  if (Eval_Print) 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 #<unused> */
  if (port != sc->unused)
    set_current_input_port(sc, port);
  return(false);
}

static bool catch_read_function(s7_scheme *sc, s7_int unused_catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  pop_input_port(sc);
  return(false);
}

static bool catch_eval_function(s7_scheme *sc, s7_int unused_catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) 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 unused_type, s7_pointer unused_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 (Eval_Print || 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 unused_type, s7_pointer unused_info)
{ /* from op_error_hook_quit */
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, catch_loc));
  /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */
  sc->reset_error_hook = true;
  /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */
  return(false);
}

static bool catch_goto_function(s7_scheme *sc, s7_int catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  call_exit_active(stack_args(sc->stack, catch_loc)) = false;
  return(false);
}

static bool catch_map_unwind_function(s7_scheme *sc, s7_int unused_catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  sc->map_call_ctr--;
  if ((s7_Debugging) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;}
  return(false);
}

static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Let(stack_let(sc->stack, catch_loc)));
  return(false);
}

static bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  const s7_pointer slot = stack_code(sc->stack, catch_loc);
  const s7_pointer val = stack_args(sc->stack, catch_loc);
  if (Eval_Print) 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 unused_type, s7_pointer unused_info)
{
  const s7_pointer symbol = stack_code(sc->stack, catch_loc);
  if (Eval_Print) 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 unused_type, s7_pointer unused_info)
{
  if (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  sc->has_openlets = (stack_args(sc->stack, catch_loc) != sc->F);
  return(false);
}

static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer unused_type, s7_pointer unused_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 (Eval_Print) fprintf(stderr, "catcher: %s\n", __func__);
  set_stack_op(sc->stack, catch_loc, OP_GC_PROTECT);

  /* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug)
   *    stack_let is the trace-in let at the point of the dynamic_unwind call
   */
  if (sc->debug > 0)
    {
      s7_pointer spaces = lookup_slot_with_let(sc, make_symbol(sc, "*debug-spaces*", 14), T_Let(stack_let(sc->stack, catch_loc)));
      if (is_slot(spaces))
	slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */
    }
  return(false);
}

static bool catch_load_close_function(s7_scheme *sc, s7_int unused_catch_loc, s7_pointer unused_type, s7_pointer unused_info)
{
  if (Eval_Print) 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 (Eval_Print) fprintf(stderr, "%s closing %s\n", __func__, display(current_input_port(sc)));

  /* this looks like catch_eval_function */
  s7_close_input_port(sc, current_input_port(sc));
  pop_input_port(sc);
  /* sc->current_file = NULL; */
  return(false);
}

typedef bool (*catch_function_t)(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info);
static catch_function_t catchers[Num_Ops];

static void init_catchers(void)
{
  for (int32_t i = 0; i < Num_Ops; i++) catchers[i] = NULL;
  catchers[OP_BARRIER] =            catch_barrier_function;
  catchers[OP_CATCH] =              catch_1_function;
  catchers[OP_CATCH_1] =            catch_1_function;
  catchers[OP_CATCH_2] =            catch_2_function;
  catchers[OP_CATCH_ALL] =          catch_all_function;
  catchers[OP_DEACTIVATE_GOTO] =    catch_goto_function;
  catchers[OP_DYNAMIC_UNWIND] =     catch_dynamic_unwind_function;
  catchers[OP_DYNAMIC_WIND] =       catch_dynamic_wind_function;
  catchers[OP_ERROR_HOOK_QUIT] =    catch_error_hook_function;
  catchers[OP_EVAL_STRING] =        catch_eval_function;
  catchers[OP_GET_OUTPUT_STRING] =  catch_out_function;
  catchers[OP_LET_TEMP_DONE] =      catch_let_temporarily_function;
  catchers[OP_LET_TEMP_S7_OPENLETS_UNWIND] = catch_let_temp_s7_openlets_unwind_function;
  catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function;
  catchers[OP_LET_TEMP_UNWIND] =    catch_let_temp_unwind_function;
  catchers[OP_MAP_UNWIND] =         catch_map_unwind_function;
  catchers[OP_READ_DONE] =          catch_read_function;      /* perhaps an error during (read) */
  catchers[OP_UNWIND_INPUT] =       catch_in_function;
  catchers[OP_UNWIND_OUTPUT] =      catch_out_function;
  catchers[OP_LOAD_CLOSE_AND_POP_IF_EOF] = catch_load_close_function;
  /* do we need one for load_return_if_eof? */
}

/* -------------------------------- throw -------------------------------- */
static s7_pointer g_throw(s7_scheme *sc, s7_pointer args)
{
  #define H_throw "(throw tag . info) is like (error ...) but it does not affect owlet. \
It looks for an existing catch with a matching tag, and jumps to it if found.  Otherwise it raises an error."
  #define Q_throw s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)

  const s7_pointer type = car(args), info = cdr(args);
  gc_protect_via_stack(sc, args);
  /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and sc->value not good here for gc protection */

  for (s7_int op_loc = stack_top(sc) - 5; op_loc >= 3; op_loc -= 4) /* look for a catcher */
    {
      const catch_function_t catcher = catchers[stack_op(sc->stack, op_loc)];
      if ((catcher) &&
	  (catcher(sc, op_loc, type, info)))
	{
	  if (sc->longjmp_ok) LongJmp(*(sc->Goto_Start), Throw_Jump);
	  return(sc->value);
	}}
  if (is_let(car(args)))
    if_let_method_exists_return_value(sc, car(args), sc->throw_symbol, args);
  error_nr(sc, make_symbol(sc, "uncaught-throw", 14),
	   set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info));
  return(sc->F);
}


/* -------------------------------- warn -------------------------------- */
#if WITH_GCC
static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...)
#else
static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */
#endif
{
  if ((current_error_port(sc) != sc->F) && (!sc->muffle_warnings))
    {
      int32_t bytes;
      va_list ap;
      block_t *b = mallocate(sc, len);
      char *str = (char *)block_data(b);
      str[0] = '\0';
      va_start(ap, ctrl);
      bytes = vsnprintf(str, len, ctrl, ap);
      va_end(ap);
      if (port_is_closed(current_error_port(sc)))
	set_current_error_port(sc, sc->standard_error);
      if ((bytes > 0) && (current_error_port(sc) != sc->F))
	port_write_string(current_error_port(sc))(sc, str, bytes, current_error_port(sc));
      liberate(sc, b);
    }
}


/* -------------------------------- error -------------------------------- */
static void fill_error_location(s7_scheme *sc)
{
  const s7_pointer port = current_input_port(sc);
  if (((is_input_port(port)) && (is_loader_port(port))) ||
      (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE))))
    {
      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)));
    }
  else
    {
      set_integer(slot_value(sc->error_line), 0);
      set_integer(slot_value(sc->error_position), 0);
      slot_set_value(sc->error_file, sc->F);
    }
}

static void format_to_error_port(s7_scheme *sc, const char *str, s7_pointer args, s7_int len)
{
  if (current_error_port(sc) != sc->F)
    format_to_port_1(sc, current_error_port(sc), str, args, NULL, Without_Result, Columnized /* is_columnizing(str) */, len, NULL);
  /* is_columnizing on every call is much slower than ignoring the issue */
}

static no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info)
{ /* half the reported compute time here is in the longjmp after the catcher runs */
  s7_pointer cur_code = current_code(sc);
#if With_History
  if ((is_free(cur_code)) || (cur_code == sc->unused)) cur_code = sc->F;
#endif

  sc->format_depth = -1;
  sc->object_out_locked = false;  /* possible error in obj->str method after object_out has set this flag */
  sc->has_openlets = true;        /*   same problem -- we need a cleaner way to handle this, op_?_unwind */
  sc->do_body_p = NULL;
#if s7_Debugging
  sc->small_symbol_set_state = Set_Ignore;
  sc->big_symbol_set_state = Set_Ignore;
  sc->v = sc->unused;
  sc->x = sc->unused;
  sc->y = sc->unused;
  sc->temp3 = sc->unused;
  sc->temp6 = sc->unused;
  sc->temp7 = sc->unused;
  sc->temp9 = sc->unused;
#endif
  sc->value = info;               /* feeble GC protection (otherwise info is sometimes freed in this function), throw also protects type */

  if (sc->current_safe_list > 0)
    clear_safe_list_in_use(sc, 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_unchecked(sc->error_code, cur_code); /* if mv here, evalable code has the mv bit set, maybe from c-macro that uses s7_values, so use _unchecked */

#if With_History
  slot_set_value(sc->error_history, sc->cur_code);
  if (sc->cur_code != sc->history_sink)
    {
      int32_t i = 0;
      sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1;
      sc->using_history1 = (!sc->using_history1);
      for (s7_pointer p = sc->cur_code; i < sc->history_size; i++, p = cdr(p)) car(p) = sc->nil;
    }
#endif
  if (is_pair(cur_code)) /* not redundant -- maybe use type_unchecked here */
    {
      s7_int line = -1, file = 0, position = 0;
      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 Eval_Print && s7_Debugging
      if (catcher) {fprintf(stderr, "before catch:\n"); s7_show_stack(sc);}
#endif
      if ((catcher) &&
	  (catcher(sc, op_loc, type, info)))
	{
#if Eval_Print && s7_Debugging
	  fprintf(stderr, "  after catch: \n"); s7_show_stack(sc);
	  if (!sc->longjmp_ok) fprintf(stderr, "s7_error jump not available?\n");
#endif
	  LongJmp(*(sc->Goto_Start), Catch_Jump);
	}}
  /* error not caught (but catcher might have been called and returned false) */

  if ((!(sc->reset_error_hook)) &&
      (hook_has_functions(sc->error_hook)))
    {
      const s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook);
      /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'data))))) */
      let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil);
      let_set_2(sc, closure_let(sc->temp_error_hook), sc->body_symbol, error_hook_funcs);
      /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */

      /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */
      push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_funcs); /* restore *error-hook* upon successful (or any!) evaluation */
      sc->code = sc->temp_error_hook;
      sc->args = list_2(sc, type, info);
      /* if we drop into the longjmp below, the hook functions are not called!
       *   OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval.
       */
      set_curlet(sc, make_let(sc, closure_let(sc->code)));
      eval(sc, OP_APPLY_LAMBDA); /* PERHAPS: apply_lambda unchecked or apply_lambda_2 */
      /* we'll longjmp below -- is that really what we want? */
    }
  else
    {
      const s7_int op = sc->print_length;
      if (op < 32) sc->print_length = 32;

      if ((!is_output_port(current_error_port(sc))) || /* error-port can be #f */
	  (port_is_closed(current_error_port(sc))))
	set_current_error_port(sc, sc->standard_error);
      /* if info is not a list, send object->string to current error port,
       *   else assume car(info) is a format control string, and cdr(info) are its args
       * if at all possible, get some indication of where we are!
       */

      if ((!is_pair(info)) ||
	  (!is_string(car(info))))
	format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7);
      else
	{
	  /* it's possible that the error string is just a string -- not intended for format */
	  if ((type != sc->format_error_symbol) &&      /* avoid an infinite loop of format errors */
	      (strchr(string_value(car(info)), '~')))
	    {
	      const s7_int len = string_length(car(info)) + 8;
	      block_t *b = mallocate(sc, len);
	      char *errstr = (char *)block_data(b);
	      s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL);
	      format_to_error_port(sc, errstr, cdr(info), str_len);
	      liberate(sc, b);
	    }
	  else format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); /* 7 = ctrl str len */
	}
      if (op < 32) sc->print_length = op;

      /* now display location at end */
      if (is_string(slot_value(sc->error_file)))
	{
	  s7_newline(sc, current_error_port(sc));
	  format_to_error_port(sc, ";    ~A\n", set_plist_1(sc, object_to_string_truncated(sc, cur_code)), 8);
	  format_to_error_port(sc, ";    ~A, line ~D, position: ~D\n",
			 set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), 31);
	}
      else
	{
	  if ((is_input_port(current_input_port(sc))) &&
	      (port_file(current_input_port(sc)) != stdin) &&
	      (!port_is_closed(current_input_port(sc))))
	    {
	      const char *filename = port_filename(current_input_port(sc));
	      int32_t line = port_line_number(current_input_port(sc));

	      if (filename)
		format_to_error_port(sc, "\n;  ~A[~D]",
			       set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))),
					   wrap_integer(sc, line)), 10);
	      else
		if ((line > 0) &&
		    (integer(slot_value(sc->error_line)) > 0))
		  format_to_error_port(sc, "\n;  line ~D", set_plist_1(sc, wrap_integer(sc, line)), 11);
		else
		  if (sc->input_port_stack_loc > 0)
		    {
		      s7_pointer port = sc->input_port_stack[sc->input_port_stack_loc - 1];
		      if ((is_input_port(port)) &&
			  (port_file(port) != stdin) &&
			  (!port_is_closed(port)))
			{
			  filename = port_filename(port);
			  line = port_line_number(port);
			  if (filename)
			    format_to_error_port(sc, "\n;  ~A[~D]",
					   set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))),
						       wrap_integer(sc, line)), 10);
			}}}
	  else
	    {
	      const char *call_name = sc->s7_call_name;
	      if (call_name)
		{
		  sc->s7_call_name = NULL;
		  if ((sc->s7_call_file) &&
		      (sc->s7_call_line >= 0))
		    format_to_error_port(sc, "\n;  ~A ~A[~D]",
				   set_plist_3(sc,
					       s7_make_string_wrapper(sc, call_name),
					       s7_make_string_wrapper(sc, sc->s7_call_file),
					       wrap_integer(sc, sc->s7_call_line)), 13);
		}}
	  s7_newline(sc, current_error_port(sc));
	}
      /* look for __func__ in the error environment etc */
      if (current_error_port(sc) != sc->F)
	{
	  s7_pointer errp = s7_stacktrace(sc);
	  if (string_length(errp) > 0)
	    {
	      port_write_string(current_error_port(sc))(sc, string_value(errp), string_length(errp), current_error_port(sc));
	      port_write_character(current_error_port(sc))(sc, '\n', current_error_port(sc));
	    }}
      else
	if (is_pair(slot_value(sc->error_code)))
	  {
	    format_to_error_port(sc, ";    ~S", set_plist_1(sc, slot_value(sc->error_code)), 7);
	    s7_newline(sc, current_error_port(sc));
	  }
      /* if (is_continuation(type))
       *   go into repl here with access to continuation?  Or expect *error-handler* to deal with it?
       */
      sc->value = type;
      sc->cur_op = OP_ERROR_QUIT;
      sc->reset_error_hook = false; /* ?? */
    }
  if (sc->Goto_Start) /* calls from C into s7 might not have this set up */
    LongJmp(*(sc->Goto_Start), Error_Jump);
  fprintf(stderr, "no toplevel catch! must abort.\n"); /* what else can we do? */
  abort();
}

s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */
{
  error_nr(sc, type, info);
  /* info is a temporary value -- do not expect it to be useful beyond the error handler procedure itself */
  return(type);
}

static no_return void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool string_error)
{
  /* read errors happen before the evaluator gets involved, so forms such as:
   *   (catch #t (lambda () (car '( . ))) (lambda arg 'error))
   * do not catch the error if we simply signal an error when we encounter it.
   */
  const s7_pointer port = current_input_port(sc);

  if (!string_error)
    {
      /* make an heroic effort to find where we slid off the tracks */
      if (is_string_port(current_input_port(sc)))
	{
          #define Quote_Size 40
	  s7_int start, end, slen, size;
	  char *recent_input = NULL;

	  /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */
	  if (port_position(port) >= port_data_size(port))
	    port_position(port) = port_data_size(port) - 1;

	  /* start at current position and look back a few chars */
	  start = port_position(port);
	  for (s7_int j = 0; (start > 0) && (j < Quote_Size); start--, j++)
	    if ((port_data(port)[start] == '\0') || (port_data(port)[start] == '\n') || (port_data(port)[start] == '\r'))
	      break;

	  /* start at current position and look ahead a few chars */
	  size = port_data_size(port);
	  end = port_position(port);
	  for (s7_int j = 0; (end < size) && (j < Quote_Size); end++, j++)
	    if ((port_data(port)[end] == '\0') || (port_data(port)[end] == '\n') || (port_data(port)[end] == '\r'))
	      break;

	  slen = end - start;  /* hopefully this is more or less the current line where the read error happened */
	  if (slen > 0)
	    {
	      recent_input = (char *)Calloc(slen + 9, 1);
	      for (s7_int i = 0; i < (slen + 8); i++) recent_input[i] = '.';
	      recent_input[3] = ' ';
	      recent_input[slen + 4] = ' ';
	      for (s7_int i = 0; i < slen; i++) recent_input[i + 4] = port_data(port)[start + i];
	    }

	  if ((port_line_number(port) > 0) &&
	      (port_filename(port)))
	    {
	      const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 64;
	      const s7_pointer str = make_empty_string(sc, len, '\0');
	      char *msg = string_value(str);
	      string_length(str) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]",
					    errmsg, (recent_input) ? recent_input : "", port_filename(port), port_line_number(port),
					    sc->current_file, sc->current_line);
	      if (recent_input) free(recent_input);
	      error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str));
	    }
	  else
	    {
	      const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64;
	      const s7_pointer str = make_empty_string(sc, len, '\0');
	      char *msg = string_value(str);
	      if ((sc->current_file) &&
		  (sc->current_line >= 0))
		string_length(str) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]",
					      errmsg, (recent_input) ? recent_input : "",
					      sc->current_file, sc->current_line);
	      else string_length(str) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : "");
	      if (recent_input) free(recent_input);
	      error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str));
	    }}}

  if ((port_line_number(port) > 0) &&
      (port_filename(port)))
    {
      s7_int nlen;
      const s7_int len = safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 128;
      const s7_pointer str = make_empty_string(sc, len, '\0');
      char *msg = string_value(str);
      if (string_error)
	nlen = snprintf(msg, len, "%s %s[%u],\n;  possible culprit: \"%s...\"\n;  last top-level form at %s[%" ld64 "]",
		       errmsg, port_filename(port), port_line_number(port),
		       sc->strbuf, sc->current_file, sc->current_line);
      else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" ld64 "]",
			  errmsg, port_filename(port), port_line_number(port),
			  sc->current_file, sc->current_line);
      string_length(str) = nlen;
      error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str));
    }
  error_nr(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol,
	   set_elist_1(sc, s7_make_string_wrapper(sc, errmsg)));
}

static no_return void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);}
static no_return void string_read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, true);}

static s7_pointer g_error(s7_scheme *sc, s7_pointer args)
{
  #define H_error "(error type ...) signals an error.  The 'type' can be used with catch to trap \
particular errors.  If the error is not caught, s7 treats the second argument as a format control string, \
and applies it to the rest of the arguments."
  #define Q_error s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)

  if (is_string(car(args)))  /* a CL-style error -- use tag='no-catch */
    error_nr(sc, make_symbol(sc, "no-catch", 8), args);
  error_nr(sc, car(args), cdr(args));
  return(sc->unspecified);
}

static char *truncate_string(char *form, s7_int len, use_write_t use_write)
{
  const uint8_t *f = (uint8_t *)form;
  s7_int i;
  if (use_write != p_Display)
    {
      /* I guess we need to protect the outer double quotes in this case */
      for (i = len - 5; i >= (len / 2); i--)
	if (is_white_space((int32_t)f[i]))
	  return(form);
      i = len - 5;
      if (i > 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '"'; form[i + 4] = '\0';}
      else
	if (len >= 2)
	  {
	    form[len - 1] = '"';
	    form[len] = '\0';
	  }}
  else
    {
      for (i = len - 4; i >= (len / 2); i--)
	if (is_white_space((int32_t)f[i]))
	  {
	    form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';
	    return(form);
	  }
      i = len - 4;
      if (i >= 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';}
      else form[len] = '\0';
    }
  return(form);
}

static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer obj)
{
  const s7_int len = sc->print_length;
  const s7_int old_max_len = sc->objstr_max_len;
  sc->objstr_max_len = len + 2;
  {
    const 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);
  }
}

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))
    {
      const 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 no_return void missing_close_paren_error_nr(s7_scheme *sc)
{
  char *syntax_msg = NULL;
  const s7_pointer port = current_input_port(sc);

  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 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)
   */
  const 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 '#<unspecified> or whatever
   *   is simply treated as the (non-error) return value, and the higher level evaluations
   *   get confused.
   */
  stack_reset(sc);                                 /* is this necessary? is it a good idea?? */
  push_stack_op(sc, OP_ERROR_QUIT);                /* added 3-Dec-16: try to make sure we actually exit! */
  sc->cur_op = OP_ERROR_QUIT;
  if (sc->longjmp_ok)
    LongJmp(*(sc->Goto_Start), Error_Quit_Jump);
}


/* -------------------------------- 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)
  const s7_pointer hook = car(args);
  s7_pointer slot;
  if (!is_any_closure(hook)) /* closure* -> closure if no args */
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "hook-functions hook must be a procedure created by make-hook: ~S", 64), hook));
  slot = lookup_slot_from(sc->body_symbol, closure_let(hook));
  return((is_slot(slot)) ? slot_value(slot) : sc->nil);
}

static s7_pointer g_hook_set_functions(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer hook = car(args);
  s7_pointer lst, p;
  if (!is_any_closure(hook)) /* closure* -> closure if no args */
    error_nr(sc, sc->wrong_type_arg_symbol,
	     set_elist_2(sc, wrap_string(sc, "set! hook-functions hook must be a procedure created by make-hook: ~S", 69), hook));
  lst = cadr(args);
  for (p = lst; is_pair(p); p = cdr(p))
    if ((!is_any_procedure(car(p))) || (!s7_is_aritable(sc, car(p), 1)))
      error_nr(sc, sc->wrong_type_arg_symbol,
	       set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a list of functions, each accepting one argument: ~S", 92), lst));
  if (!is_null(p))
      error_nr(sc, sc->wrong_type_arg_symbol,
	       set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a a proper list: ~S", 59), lst));
  {
    s7_pointer slot = lookup_slot_from(sc->body_symbol, closure_let(hook));
    if (is_slot(slot)) slot_set_value(slot, lst);
  }
  return(lst);
}


/* -------------------------------- begin_hook -------------------------------- */
void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val) {return(sc->begin_hook);}

void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val))
{
  sc->begin_hook = hook;
  sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK;
}

static bool call_begin_hook(s7_scheme *sc)
{
  bool result = false;
  /* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly,
   *   rather than going through a *bool arg (&result below).  That works in gcc (Linux/OSX),
   *   but does not work in MS Visual C++.  In the latter, the compiler apparently completely
   *   eliminates any local, returning (for example) a thread-relative stack-allocated value
   *   directly, but then by the time we get here, that variable has vanished, and we get
   *   garbage.  We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...);
   *   So, in the new form (26-Jun-13), the value is passed directly into an s7 variable
   *   that I hope can't be optimized out of existence.
   *
   * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think)
   *   originally this facility was aimed at interrupting infinite loops, and the expected usage was:
   *     set begin_hook, eval-string(...), unset begin_hook
   */
  const opcode_t op = sc->cur_op;
  push_stack_direct(sc, OP_BARRIER);
  sc->begin_hook(sc, &result);
  if (result)
    {
      const s7_pointer cur_code = current_code(sc);
      /* set (owlet) in case we were interrupted and need to see why something was hung */
      slot_set_value(sc->error_type, sc->F);
      slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */
      slot_set_value(sc->error_code, cur_code);
      if (has_location(cur_code))
	{
	  set_integer(slot_value(sc->error_line), (s7_int)pair_line_number(cur_code));
	  slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]);
	  set_integer(slot_value(sc->error_position), (s7_int)pair_position(cur_code));
	}
      else
	{
	  set_integer(slot_value(sc->error_line), 0);
	  set_integer(slot_value(sc->error_position), 0);
	  slot_set_value(sc->error_file, sc->F);
	}
#if With_History
      slot_set_value(sc->error_history, sc->F);
#endif
      let_set_outlet(sc->owlet, sc->curlet);
      sc->value = make_symbol(sc, "begin-hook-interrupt", 20);
      /* otherwise the evaluator returns whatever random thing is in sc->value (normally #<closure>)
       *   which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool*
       */
      s7_quit(sc);     /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */
      return(true);
    }
  pop_stack_no_op(sc);
  sc->cur_op = op;     /* for better error handling.  otherwise we get "barrier" as the offending function name in syntax_error */
  return(false);
}


/* -------------------------------- apply -------------------------------- */
static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
{
  /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */
  s7_pointer p;
  gc_protect_via_stack(sc, d);
  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 */
                                          /* car(next_arg) can be a safe_list! */
      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(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 inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t start_arg, int32_t n_args, s7_pointer par)
{
  s7_pointer *df = c_function_arg_defaults(func);
  if (c_func_has_simple_defaults(func))
    for (int32_t i = start_arg; i < n_args; i++, par = cdr(par))
      set_car(par, df[i]);
  else
    for (int32_t i = start_arg; i < n_args; i++, par = cdr(par))
      {
	s7_pointer defval = df[i];
	if (is_symbol(defval))
	  set_car(par, lookup_checked(sc, defval));
	else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval);
      }
}

static s7_pointer set_c_function_star_args(s7_scheme *sc)
{
  int32_t i;
  s7_pointer arg, par, call_args;
  const s7_pointer func = sc->code;
  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_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);
}

static s7_pointer set_c_function_star_defaults(s7_scheme *sc, int32_t num)
{
  s7_pointer call_args, par;
  const s7_pointer func = sc->code;
  const int32_t n_args = c_function_max_args(func);

  if (is_safe_procedure(func))
    call_args = c_function_call_args(func);
  else
    {
      call_args = make_list(sc, c_function_optional_args(func), sc->F);
      gc_protect_via_stack(sc, call_args);
    }
  par = call_args;
  if (num == 1)
    {
      set_car(par, car(sc->args));
      par = cdr(par);
    }
  fill_star_defaults(sc, func, num, n_args, par);
  if (!is_safe_procedure(func)) unstack_gc_protect(sc);
  return(call_args);
}

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;
      sc->value = c_function_call(sc->code)(sc, set_c_function_star_args(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, s7_Warn_Bufsize, "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, s7_Warn_Bufsize, "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;
#if Disable_Deprecated
      if (!is_let(let))
	{
	  s7_warn(sc, s7_Warn_Bufsize, "%s's second argument is not a let: %s\n", __func__, display(let));
	  abort();
	}
      set_curlet(sc, let);
#else
      set_curlet(sc, (is_let(let)) ? let : sc->rootlet); /* ?? this means anything other than a let is rootlet */
#endif
      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;
    }
#if Disable_Deprecated
  if (!is_let(let))
    {
      s7_warn(sc, s7_Warn_Bufsize, "%s's second argument is not a let: %s\n", __func__, display(let));
      abort();
    }
  result = s7_eval(sc, code, let);
#else
  result = s7_eval(sc, code, (let == sc->nil) ? sc->rootlet : let);
#endif
  if (caller)
    {
      sc->s7_call_name = NULL;
      sc->s7_call_file = NULL;
      sc->s7_call_line = -1;
    }
  return(result);
}

static s7_pointer g_eval(s7_scheme *sc, s7_pointer args)
{
  #define H_eval "(eval code (let (curlet))) evaluates code in the environment let. 'let' \
defaults to the curlet; to evaluate something in the top-level environment instead, \
pass (rootlet):\n\
\n\
  (define x 32) \n\
  (let ((x 3))\n\
    (eval 'x (rootlet)))\n\
\n\
  returns 32"
  #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, has_let_signature(sc))

  if (is_pair(cdr(args)))
    {
      s7_pointer 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 (Eval_Print) safe_print(fprintf(stderr, "  %s: %s %s\n", __func__, display_truncated(func), display_truncated(args)));

    sc->temp4 = T_App(func);                  /* this is feeble GC protection */
    sc->temp2 = T_Lst(args);                  /* only use of temp2 */
    store_jump_info(sc);
    set_jump_info(sc, s7_Call_Set_Jump);
    if (jump_loc != No_Jump)
      {
	if (jump_loc != Error_Jump)
	  eval(sc, sc->cur_op);
	if ((jump_loc == Catch_Jump) &&       /* we're returning (back to eval) from an error in catch */
	    (sc->stack_end == sc->stack_start))
	  push_stack_op(sc, OP_ERROR_QUIT);
      }
    else
      {
	if (sc->safety > No_Safety)
	  check_list_validity(sc, __func__, args);
	push_stack_direct(sc, OP_EVAL_DONE);  /* this saves the current evaluation and will eventually finish this (possibly) nested call */
	sc->code = func;
	sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args;
	eval(sc, OP_APPLY);
      }
    restore_jump_info(sc);
    /* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls */
    return(sc->value);
  }
}

s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line)
{
  s7_pointer result;
  if (caller)
    {
      sc->s7_call_name = caller;
      sc->s7_call_file = file;
      sc->s7_call_line = line;
    }
  result = s7_call(sc, func, args);
  if (caller)
    {
      sc->s7_call_name = NULL;
      sc->s7_call_file = NULL;
      sc->s7_call_line = -1;
    }
  return(result);
}


/* -------------------------------- type-of -------------------------------- */
#if !WITH_GCC
static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ)  /* opt3_byte = uint8_t */
{
  return((type(val) == typ) ||
	 ((has_active_methods(sc, val)) &&
	  (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F)));
}
#else
#define gen_type_match(Sc, Val, Typ) \
         ({s7_pointer _val_ = Val; int32_t _typ_ = Typ; \
           ((type(_val_) == _typ_) || \
            ((has_active_methods(Sc, _val_)) && \
             (apply_boolean_method(Sc, _val_, Sc->type_to_typers[_typ_]) != Sc->F)));})
#endif

static void init_typers(s7_scheme *sc)
{
  sc->type_to_typers[T_BACRO] =               sc->is_macro_symbol;
  sc->type_to_typers[T_BACRO_STAR] =          sc->is_macro_symbol;
  sc->type_to_typers[T_BIG_COMPLEX] =         sc->is_complex_symbol;
  sc->type_to_typers[T_BIG_INTEGER] =         sc->is_integer_symbol;
  sc->type_to_typers[T_BIG_RATIO] =           sc->is_rational_symbol;
  sc->type_to_typers[T_BIG_REAL] =            sc->is_float_symbol;
  sc->type_to_typers[T_BOOLEAN] =             sc->is_boolean_symbol;
  sc->type_to_typers[T_BYTE_VECTOR] =         sc->is_byte_vector_symbol;
  sc->type_to_typers[T_CATCH] =               sc->F;
  sc->type_to_typers[T_CHARACTER] =           sc->is_char_symbol;
  sc->type_to_typers[T_CLOSURE] =             sc->is_procedure_symbol;
  sc->type_to_typers[T_CLOSURE_STAR] =        sc->is_procedure_symbol;
  sc->type_to_typers[T_COMPLEX] =             sc->is_complex_symbol;
  sc->type_to_typers[T_CONTINUATION] =        sc->is_continuation_symbol;
  sc->type_to_typers[T_COUNTER] =             sc->F;
  sc->type_to_typers[T_FREE] =                sc->error_symbol;
  sc->type_to_typers[T_C_FUNCTION] =          sc->is_procedure_symbol;
  sc->type_to_typers[T_C_FUNCTION_STAR] =     sc->is_procedure_symbol;
  sc->type_to_typers[T_C_MACRO] =             sc->is_macro_symbol;
  sc->type_to_typers[T_C_OBJECT] =            sc->is_c_object_symbol;
  sc->type_to_typers[T_C_POINTER] =           sc->is_c_pointer_symbol;
  sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol;
  sc->type_to_typers[T_DYNAMIC_WIND] =        sc->F;
  sc->type_to_typers[T_EOF] =                 sc->is_eof_object_symbol;
  sc->type_to_typers[T_FLOAT_VECTOR] =        sc->is_float_vector_symbol;
  sc->type_to_typers[T_COMPLEX_VECTOR] =      sc->is_complex_vector_symbol;
  sc->type_to_typers[T_FREE] =                sc->F;
  sc->type_to_typers[T_GOTO] =                sc->is_goto_symbol;
  sc->type_to_typers[T_HASH_TABLE] =          sc->is_hash_table_symbol;
  sc->type_to_typers[T_INPUT_PORT] =          sc->is_input_port_symbol;
  sc->type_to_typers[T_INTEGER] =             sc->is_integer_symbol;
  sc->type_to_typers[T_INT_VECTOR] =          sc->is_int_vector_symbol;
  sc->type_to_typers[T_ITERATOR] =            sc->is_iterator_symbol;
  sc->type_to_typers[T_LET] =                 sc->is_let_symbol;
  sc->type_to_typers[T_MACRO] =               sc->is_macro_symbol;
  sc->type_to_typers[T_MACRO_STAR] =          sc->is_macro_symbol;
  sc->type_to_typers[T_NIL] =                 sc->is_null_symbol;
  sc->type_to_typers[T_OUTPUT_PORT] =         sc->is_output_port_symbol;
  sc->type_to_typers[T_PAIR] =                sc->is_pair_symbol;
  sc->type_to_typers[T_RANDOM_STATE] =        sc->is_random_state_symbol;
  sc->type_to_typers[T_RATIO] =               sc->is_rational_symbol;
  sc->type_to_typers[T_REAL] =                sc->is_float_symbol;
  sc->type_to_typers[T_SLOT] =                sc->F;
  sc->type_to_typers[T_STACK] =               sc->F;
  sc->type_to_typers[T_STRING] =              sc->is_string_symbol;
  sc->type_to_typers[T_SYMBOL] =              sc->is_symbol_symbol;      /* and keyword? */
  sc->type_to_typers[T_SYNTAX] =              sc->is_syntax_symbol;
  sc->type_to_typers[T_UNDEFINED] =           sc->is_undefined_symbol;
  sc->type_to_typers[T_UNSPECIFIED] =         sc->is_unspecified_symbol;
  sc->type_to_typers[T_UNUSED] =              sc->F;
  sc->type_to_typers[T_VECTOR] =              sc->is_vector_symbol;
}

s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg) {return(sc->type_to_typers[type(arg)]);}

static s7_pointer g_type_of(s7_scheme *sc, s7_pointer args)
{
  #define H_type_of "(type-of obj) returns a symbol describing obj's type: (type-of 1): 'integer?"
  #define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T)

  const s7_pointer obj = car(args);
  s7_pointer func;
  if (!has_active_methods(sc, obj))
    return(sc->type_to_typers[type(obj)]);
  func = find_method_with_let(sc, obj, sc->type_of_symbol);
  if (func == sc->undefined)
    return(sc->type_to_typers[type(obj)]);
  return(s7_apply_function(sc, func, set_mlist_1(sc, obj)));
  /* return(sc->type_to_typers[type(car(args))]); */
}


/* -------------------------------- type-name -------------------------------- */

s7_pointer s7_type_name(s7_scheme *sc, s7_pointer obj)  /* this can double as the p_p function */
{
  uint8_t typ;
  if (has_active_methods(sc, obj))
    {
      s7_pointer func = find_method_with_let(sc, obj, sc->type_name_symbol);
      if (func != sc->undefined)
	return(s7_apply_function(sc, func, set_mlist_1(sc, obj)));
    }
  typ = type(obj);
  if (typ < Num_Types)
    {
      s7_pointer str;
      if (typ == T_C_OBJECT)
	str = c_object_scheme_name(sc, obj);
      else str = sc->type_names[typ];
      if (string_length(str) == 0) return(nil_string);
      return(make_string_with_length(sc, string_value(str), string_length(str)));
    }
  return(make_string_with_length(sc, "unknown type!", 13));
}

static s7_pointer g_type_name(s7_scheme *sc, s7_pointer args)
{
  #define H_type_name "(type-name obj) returns a string describing obj's type: (type-name 1): \"an integer\""
  #define Q_type_name s7_make_signature(sc, 2, sc->is_string_symbol, sc->T)
  return(s7_type_name(sc, car(args)));
}


/* -------------------------------- exit emergency-exit -------------------------------- */
void s7_quit(s7_scheme *sc)
{
  sc->longjmp_ok = false;
  pop_input_port(sc);
  stack_reset(sc);
  push_stack_op_let(sc, OP_EVAL_DONE);
}

#ifndef EXIT_SUCCESS
  #define EXIT_SUCCESS 0
  #define EXIT_FAILURE 1
#endif

static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args)
{
  #define H_emergency_exit "(emergency-exit (obj #t)) exits s7 immediately. 'obj', the value passed to libc's _exit, can be an integer or #t=success (0) or #f=fail (1)."
  #define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T)

  s7_pointer obj;
  if (is_null(args)) _exit(EXIT_SUCCESS);  /* r7rs spec says use _exit here (it 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++)
    {
      const 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 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)
      {
	const 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 cobj = cadr(args);
      if (!is_boolean(cobj))
	wrong_type_error_nr(sc, sc->exit_symbol, 2, cobj, A_Boolean_String);
      if (cobj == sc->T)
	call_c_object_frees(sc);
    }
  s7_quit(sc);
  if (show_gc_stats(sc))
    s7_warn(sc, s7_Warn_Bufsize, "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 */
  {
    const 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));
  }
#ifdef __TINYC__
  return(sc->F); /* never reached, but tcc complains */
#endif
}

#if WITH_GCC
static s7_pointer g_abort(s7_scheme *unused_sc, s7_pointer unused_args) {abort(); return(NULL);}
#endif


/* -------------------------------- optimizer stuff -------------------------------- */
/* There is a problem with cache misses:  a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees).
 *   But how to optimize s7 for cache hits?  The culprits are eval and gc.  Looking at the numbers,
 *   I think the least affected tests are able to use opt_info optimization which makes everything local?
 */

#if s7_Debugging
static s7_pointer s_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  /* if ((curlet_has_slots(sc)) && (symbol == slot_symbol(let_slots(sc->curlet)))) fprintf(stderr, "t: %s in %s %s\n", display(symbol), display(expr), func); */
  return(lookup(sc, symbol));
}

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_slot_checked(let_slots(let))) ? display(let_slots(let)) : "no slots", Unbold_Text);
      abort();
      /* this usually signals a problem with enviroments (or exprlists if optimize_lambda, or a define in a body) */
    }
}

static s7_pointer t_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_t_1(sc, sc->curlet, func, expr, symbol);
  return(slot_value(let_slots(sc->curlet)));
}

static s7_pointer T_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol);
  return(slot_value(let_slots(let_outlet(sc->curlet))));
}

static void check_u_1(s7_scheme *sc, s7_pointer 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_slot_checked(next_slot(let_slots(let)))) ? display(next_slot(let_slots(let))) : "no next slot", Unbold_Text);
      abort();
    }
}

static s7_pointer u_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_u_1(sc, sc->curlet, func, expr, symbol);
  return(slot_value(next_slot(let_slots(sc->curlet))));
}

static s7_pointer U_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol);
  return(slot_value(next_slot(let_slots(let_outlet(sc->curlet)))));
}

static void check_v_1(s7_scheme *sc, s7_pointer 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_slot_checked(next_slot(next_slot(let_slots(let))))) ? display(next_slot(next_slot(let_slots(let)))) : "no next slot", Unbold_Text);
      abort();
    }
}

static s7_pointer v_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_v_1(sc, sc->curlet, func, expr, symbol);
  return(slot_value(next_slot(next_slot(let_slots(sc->curlet)))));
}

static s7_pointer V_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol);
  return(slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))));
}

static void check_o_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var)
{
  const 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_slot_checked(slot)) ? display(slot) : "undefined", Unbold_Text);
      abort();
    }
}

static s7_pointer o_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
{
  check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol);
  return(inline_lookup_from(sc, symbol, let_outlet(sc->curlet)));
}

#define s_lookup(Sc, Symbol, Expr) s_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 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
/* not s7_Debugging */
#define s_lookup(Sc, Symbol, Expr) lookup(Sc, Symbol)
#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 g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym)

/* expr here is the full expression */
static s7_pointer fx_c(s7_scheme *unused_sc, s7_pointer expr) {return(expr);}
static s7_pointer fx_q(s7_scheme *unused_sc, s7_pointer expr) {return(cadr(expr));}
static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer expr) {return(lookup_checked(sc, T_Sym(expr)));}

static s7_pointer fx_s(s7_scheme *sc, s7_pointer expr) {return(lookup(sc, T_Sym(expr)));}
static s7_pointer fx_g(s7_scheme *sc, s7_pointer expr) {return((is_defined_global(expr)) ? global_value(expr) : lookup(sc, expr));}
static s7_pointer fx_o(s7_scheme *sc, s7_pointer expr) {return(o_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_t(s7_scheme *sc, s7_pointer expr) {return(t_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_u(s7_scheme *sc, s7_pointer expr) {return(u_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_v(s7_scheme *sc, s7_pointer expr) {return(v_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_T(s7_scheme *sc, s7_pointer expr) {return(T_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_U(s7_scheme *sc, s7_pointer expr) {return(U_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_V(s7_scheme *sc, s7_pointer expr) {return(V_lookup(sc, T_Sym(expr), expr));}
static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer expr) {return(fn_call(sc, expr));}
static s7_pointer fx_c_0c(s7_scheme *sc, s7_pointer expr) {return(fn_proc(expr)(sc, sc->nil));}
static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer expr) {return(cons(sc, cadr(expr), opt1_con(cdr(expr))));}
static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer unused_expr) {return(s7_curlet(sc));}

#define fx_c_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(fn_proc(expr)(sc, with_list_t1(sc, Lookup(sc, cadr(expr), expr)))); \
  }

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 expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, g_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_o_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, o_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_o_read_char(s7_scheme *sc, s7_pointer expr) {return(read_char_p_p(sc, o_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, u_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, v_lookup(sc, cadr(expr), expr)));}

#define fx_car_any(Name, Lookup) static s7_pointer Name(s7_scheme *sc, s7_pointer expr)	{return(car_p_p(sc, Lookup(sc, cadr(expr), expr)));}

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 expr) {return(cdr_p_p(sc, Lookup(sc, cadr(expr), expr)));}

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 expr) {return(cadr_p_p(sc, Lookup(sc, cadr(expr), expr)));}

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 expr) {return(cddr_p_p(sc, Lookup(sc, cadr(expr), expr)));}

fx_cddr_any(fx_cddr_s, s_lookup)
fx_cddr_any(fx_cddr_t, t_lookup)
fx_cddr_any(fx_cddr_u, u_lookup)
fx_cddr_any(fx_cddr_o, o_lookup)


static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y)
{
  if ((s7_Debugging) && (is_t_integer(val))) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val));
  switch (type(val))
    {
    case T_REAL:    return(make_boolean(sc, real(val) == y));
    case T_RATIO:
    case T_COMPLEX: return(sc->F);
#if With_Gmp
    case T_BIG_INTEGER: return(make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0));
    case T_BIG_REAL:    return(make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0));
    case T_BIG_RATIO:
    case T_BIG_COMPLEX: return(sc->F);
#endif
    default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), A_Number_String, 1));
    }
  return(sc->T);
}

static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = lookup(sc, cadr(expr));
  if (is_t_real(val)) return(make_boolean(sc, real(val) == 0.0));
  return(make_boolean(sc, num_eq_b_7pp(sc, val, Real_Zero)));
}

#define fx_num_eq_si_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer args = cdr(expr); \
    const s7_pointer val = Lookup(sc, car(args), expr); \
    const 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 expr) \
  { \
    s7_pointer val = Lookup(sc, cadr(expr), expr); \
    return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(expr), val, 0)); \
  }

fx_num_eq_s0_any(fx_num_eq_s0, s_lookup)
fx_num_eq_s0_any(fx_num_eq_t0, t_lookup)
fx_num_eq_s0_any(fx_num_eq_u0, u_lookup)
fx_num_eq_s0_any(fx_num_eq_v0, v_lookup)

static s7_pointer fx_num_eq_0s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = lookup(sc, opt3_sym(expr)); /* opt3_sym: caddr(expr) -- 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 expr)
{
#if With_Gmp
  return(g_random_i(sc, cdr(expr)));
#else
  return(make_integer(sc, (s7_int)(integer(cadr(expr)) * next_random(sc->default_random_state))));
#endif
}

static s7_pointer fx_random_i_wrapped(s7_scheme *sc, s7_pointer expr)
{
#if With_Gmp
  return(g_random_i(sc, cdr(expr)));
#else
  return(wrap_integer(sc, (s7_int)(integer(cadr(expr)) * next_random(sc->default_random_state))));
#endif
}

#if !With_Gmp
static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer expr)
{
  s7_int x = integer(cadr(expr));
  s7_int y = opt3_int(cdr(expr)); /* cadadr */
  return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
}
#endif

static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer expr) {return(g_add_xf(sc, lookup(sc, cadr(expr)), real(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer expr) {return(g_add_xf(sc, s_lookup(sc, caddr(expr), expr), real(cadr(expr)), 2));}
static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer expr) {return(g_add_xf(sc, t_lookup(sc, cadr(expr), expr), real(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer expr) {return(g_add_xf(sc, t_lookup(sc, caddr(expr), expr), real(cadr(expr)), 2));}


#define fx_add_s1_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if ((!With_Gmp) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \
    return(g_add_x1_1(sc, x, 1)); /* expr=(+ 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 expr) \
  { \
    const s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if ((!With_Gmp) && (is_t_integer(x))) \
      { \
        if (Have_Overflow_Checks) \
  	  { \
  	    s7_int val = 0; \
  	    if (!add_overflow(integer(x), integer(opt1_con(cdr(expr))), &val)) \
  	      return(make_integer(sc, val)); \
  	  } \
        else return(make_integer(sc, integer(x) + integer(opt1_con(cdr(expr))))); \
      } \
    return(add_p_pp(sc, x, opt1_con(cdr(expr)))); /* caddr(expr) */ \
  }

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 expr) {return(add_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_ts(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_tu(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_ut(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, u_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_uv(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, u_lookup(sc, cadr(expr), expr), v_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_us(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, u_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_add_vu(s7_scheme *sc, s7_pointer expr) {return(add_p_pp(sc, v_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}

#define fx_subtract_s1_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if ((!With_Gmp) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \
    return(minus_c1(sc, x)); \
  }
/* overflow check here slows tleft by about 35 out of ca 750, parallel add case does not check
 * (define most-negative-fixnum (*s7* 'most-negative-fixnum))
 * (display (let ((f (lambda () (let ((S (- most-negative-fixnum 1))) S)))) (f))) (newline)
 * -> 9223372036854775807 or (checked) -9223372036854776000.0
 */

fx_subtract_s1_any(fx_subtract_s1, s_lookup)
fx_subtract_s1_any(fx_subtract_t1, t_lookup)
fx_subtract_s1_any(fx_subtract_u1, u_lookup)
fx_subtract_s1_any(fx_subtract_v1, v_lookup)
fx_subtract_s1_any(fx_subtract_T1, T_lookup)
fx_subtract_s1_any(fx_subtract_U1, U_lookup)


#define fx_subtract_si_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer x = Lookup(sc, cadr(expr), expr);	\
    if ((!With_Gmp) && (is_t_integer(x))) \
      { \
        if (Have_Overflow_Checks) \
  	  { \
  	    s7_int val = 0; \
  	    if (!subtract_overflow(integer(x), integer(opt1_con(cdr(expr))), &val)) \
  	      return(make_integer(sc, val)); \
  	  } \
        else return(make_integer(sc, integer(x) - integer(opt1_con(cdr(expr))))); \
      } \
    return(subtract_p_pp(sc, x, opt1_con(cdr(expr)))); /* caddr(expr) */ \
  }

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 expr) \
  { \
    const s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if (is_t_real(x)) \
      return(make_real(sc, real(x) - real(opt1_con(cdr(expr)))));       /* caddr(expr) */ \
    return(g_subtract_2f(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */ \
  }

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 expr) {return(subtract_p_pp(sc, Lookup1(sc, cadr(expr), expr), Lookup2(sc, opt1_sym(cdr(expr)), expr)));}

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 expr)
{
  const s7_double n = real(cadr(expr));
  const s7_pointer x = lookup(sc, caddr(expr));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, n - integer(x)));
    case T_RATIO:   return(make_real(sc, n - (s7_double)fraction(x)));
    case T_REAL:    return(make_real(sc, n - real(x)));
    case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
#if With_Gmp
    case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
      return(subtract_p_pp(sc, cadr(expr), x));
#endif
    default:
      return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(expr), x, A_Number_String, 2));
    }
  return(x);
}

#define fx_is_eq_sc_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(make_boolean(sc, Lookup(sc, cadr(expr), expr) == opt1_con(cdr(expr)))); /* 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 expr) \
  { \
    s7_pointer a = cdr(expr); \
    s7_pointer lst = Lookup(sc, opt3_sym(a), expr); \
    return(make_boolean(sc, car_p_p(sc, lst) == opt2_con(a))); \
  }

fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup)
fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup)

static s7_pointer fx_is_eq_caar_sq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a = cdr(expr);
  s7_pointer lst = lookup(sc, opt3_sym(a));
  return(make_boolean(sc, caar_p_p(sc, lst) == opt2_con(a)));
}

static s7_pointer fx_not_is_eq_car_sq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer lst = lookup(sc, opt1_sym(cdr(expr)));
  return(make_boolean(sc, car_p_p(sc, lst) != opt3_con(cdr(expr))));
}

#define fx_is_pair_car_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_pair(car_p_p(sc, p)))); \
  }

fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup)
fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup)

#define fx_is_pair_cdr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_pair(cdr_p_p(sc, p)))); \
  }

fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup)
fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup)
fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup)

#define fx_is_pair_cadr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_pair(cadr_p_p(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 expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_pair(cddr_p_p(sc, p)))); \
  }

fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup)
fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup)

#define fx_is_null_cdr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_null(cdr_p_p(sc, p)))); \
  }

fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup)
fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup)

#define fx_is_null_cadr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_null(cadr_p_p(sc, p)))); \
  }

fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup)
fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup)

#define fx_is_null_cddr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_null(cddr_p_p(sc, p)))); \
  }

fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup)
fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup)

#define fx_is_symbol_cadr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p = Lookup(sc, opt3_sym(expr), expr); \
    return(make_boolean(sc, is_symbol(cadr_p_p(sc, p)))); \
  }

fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup)
fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup)

static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = t_lookup(sc, opt3_sym(expr), expr);
  return(make_boolean(sc, is_symbol(car_p_p(sc, val))));
}

static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = lookup(sc, opt3_sym(expr));
#if With_Gmp
  if ((is_t_big_integer(p)) &&
      (mpz_cmp_ui(big_integer(p), 0) >= 0)) /* p >= 0 */
    {
      mpz_sqrt(sc->mpz_1, big_integer(p));
      return(mpz_to_integer(sc, sc->mpz_1));
    }
#else
  if (!is_negative_b_7p(sc, p))
    return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol)))));
#endif
  return(floor_p_p(sc, sqrt_p_p(sc, p)));
}


static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer num = u_lookup(sc, cadr(expr), expr);
  if (is_t_integer(num)) return(make_boolean(sc, integer(num) > 0));
  return(make_boolean(sc, is_positive_b_7p(sc, num)));
}

static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer expr) {return(make_boolean(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(expr), expr))));}

#define fx_real_part_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    return((is_t_complex(x)) ? make_real(sc, real_part(x)) : real_part_p_p(sc, x)); \
  }

fx_real_part_s_any(fx_real_part_s, s_lookup)
fx_real_part_s_any(fx_real_part_t, t_lookup)

#define fx_imag_part_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    return((is_t_complex(x)) ? make_real(sc, imag_part(x)) : imag_part_p_p(sc, x)); \
  }

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 expr) \
  { \
    const s7_pointer iter = Lookup(sc, cadr(expr), expr); \
    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 unused_expr)
{
  const 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 expr) {return(s7_length(sc, s_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer expr) {return(s7_length(sc, t_lookup(sc, cadr(expr), expr)));}

static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer expr)
{
  /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */
  const s7_int ilen = integer(opt3_con(expr)); /* is_t_integer checked in fx_choose */
  const s7_pointer val = lookup(sc, opt3_sym(cdr(expr)));

  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 expr)
{
  const s7_int ilen = integer(opt3_con(expr));    /* caddr(expr) */
  const s7_pointer val = lookup(sc, opt3_sym(cdr(expr)));  /* cadadr(expr) */

  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 expr)   {return((is_null(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_null_o(s7_scheme *sc, s7_pointer expr)   {return((is_null(o_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);} /* very few hits */
static s7_pointer fx_is_null_t(s7_scheme *sc, s7_pointer expr)   {return((is_null(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_null_u(s7_scheme *sc, s7_pointer expr)   {return((is_null(u_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_null_v(s7_scheme *sc, s7_pointer expr)   {return((is_null(v_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_null_T(s7_scheme *sc, s7_pointer expr)   {return((is_null(T_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_symbol_s(s7_scheme *sc, s7_pointer expr) {return((is_symbol(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer expr) {return((is_symbol(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_symbol_u(s7_scheme *sc, s7_pointer expr) {return((is_symbol(u_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer expr)    {return((lookup(sc, cadr(expr)) == eof_object) ? sc->T : sc->F);}
static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer expr)    {return((t_lookup(sc, cadr(expr), expr) == eof_object) ? sc->T : sc->F);}
static s7_pointer fx_is_eof_u(s7_scheme *sc, s7_pointer expr)    {return((u_lookup(sc, cadr(expr), expr) == eof_object) ? sc->T : sc->F);}

static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer expr)   {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == type(lookup(sc, cadr(expr)))));}
static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer expr)   {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == type(t_lookup(sc, cadr(expr), expr))));}
static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer expr)   {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == type(u_lookup(sc, cadr(expr), expr))));}

#if With_Gmp
static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer expr) {return((s7_is_integer(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer expr) {return((s7_is_integer(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
#else
static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer expr) {return((is_t_integer(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer expr) {return((is_t_integer(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
#endif

static s7_pointer fx_is_string_s(s7_scheme *sc, s7_pointer expr)    {return((is_string(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_string_t(s7_scheme *sc, s7_pointer expr)    {return((is_string(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_procedure_s(s7_scheme *sc, s7_pointer expr) {return((is_procedure(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_procedure_t(s7_scheme *sc, s7_pointer expr) {return((is_procedure(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_pair_s(s7_scheme *sc, s7_pointer expr)      {return((is_pair(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_pair_t(s7_scheme *sc, s7_pointer expr)      {return((is_pair(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_pair_u(s7_scheme *sc, s7_pointer expr)      {return((is_pair(u_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}
static s7_pointer fx_is_pair_v(s7_scheme *sc, s7_pointer expr)      {return((is_pair(v_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_keyword_s(s7_scheme *sc, s7_pointer expr)   {return((is_symbol_and_keyword(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}

static s7_pointer fx_is_vector_s(s7_scheme *sc, s7_pointer expr)    {return((is_any_vector(lookup(sc, cadr(expr)))) ? sc->T : sc->F);}
static s7_pointer fx_is_vector_t(s7_scheme *sc, s7_pointer expr)    {return((is_any_vector(t_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_is_proper_list_s(s7_scheme *sc, s7_pointer expr) {return((s7_is_proper_list(sc, s_lookup(sc, cadr(expr), expr))) ? sc->T : sc->F);}

static s7_pointer fx_not_s(s7_scheme *sc, s7_pointer expr) {return(make_boolean(sc, is_false(sc, s_lookup(sc, cadr(expr), expr))));}
static s7_pointer fx_not_t(s7_scheme *sc, s7_pointer expr) {return(make_boolean(sc, is_false(sc, t_lookup(sc, cadr(expr), expr))));}
static s7_pointer fx_not_o(s7_scheme *sc, s7_pointer expr) {return(make_boolean(sc, is_false(sc, o_lookup(sc, cadr(expr), expr))));}

static s7_pointer fx_not_is_pair_s(s7_scheme *sc, s7_pointer expr)  {return((is_pair(lookup(sc, opt3_sym(expr)))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_pair_t(s7_scheme *sc, s7_pointer expr)  {return((is_pair(t_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_pair_u(s7_scheme *sc, s7_pointer expr)  {return((is_pair(u_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_pair_v(s7_scheme *sc, s7_pointer expr)  {return((is_pair(v_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}

static s7_pointer fx_not_is_null_s(s7_scheme *sc, s7_pointer expr)  {return((is_null(lookup(sc, opt3_sym(expr)))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_null_t(s7_scheme *sc, s7_pointer expr)  {return((is_null(t_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_null_u(s7_scheme *sc, s7_pointer expr)  {return((is_null(u_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}

static s7_pointer fx_not_is_symbol_s(s7_scheme *sc, s7_pointer expr) {return((is_symbol(lookup(sc, opt3_sym(expr)))) ? sc->F : sc->T);}
static s7_pointer fx_not_is_symbol_t(s7_scheme *sc, s7_pointer expr) {return((is_symbol(t_lookup(sc, opt3_sym(expr), expr))) ? sc->F : sc->T);}

#define fx_c_sc_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_1, Lookup(sc, cadr(expr), expr)); \
    set_car(sc->t2_2, opt1_con(cdr(expr))); \
    return(fn_proc(expr)(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 expr) {return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_c_si_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr)))));}
static s7_pointer fx_c_ti_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr)))));}
static s7_pointer fx_c_ti_remainder(s7_scheme *sc, s7_pointer expr) {return(remainder_p_pi(sc, t_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr)))));}
static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_vector_ref_tc(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pi(sc, t_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr)))));}
  /* tc happens a lot, but others almost never */

static s7_pointer fx_memq_sc(s7_scheme *sc, s7_pointer expr)   {return(memq_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_memq_sc_3(s7_scheme *sc, s7_pointer expr) {return(memq_3_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_memq_tc(s7_scheme *sc, s7_pointer expr)   {return(memq_p_pp(sc, t_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}

static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer expr)    {return(leq_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer expr)     {return(lt_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer expr)     {return(gt_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}
static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer expr)    {return(geq_p_pp(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}

static s7_pointer fx_list_sc(s7_scheme *sc, s7_pointer expr)   {return(list_2(sc, s_lookup(sc, cadr(expr), expr), opt1_con(cdr(expr))));}

#define fx_char_eq_sc_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer c = Lookup(sc, cadr(expr), expr); \
    if (c == opt1_con(cdr(expr))) return(sc->T); \
    if (is_character(c)) return(sc->F); \
    return(method_or_bust(sc, cadr(expr), sc->char_eq_symbol, cdr(expr), 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 expr) \
  { \
    set_car(sc->t2_1, opt1_con(cdr(expr)));                  /* cadr(expr) or cadadr */ \
    set_car(sc->t2_2, Lookup(sc, caddr(expr), expr)); \
    return(fn_proc(expr)(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 expr)
{
  return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, opt1_con(cdr(expr)), t_lookup(sc, caddr(expr), expr)));
}

static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer expr) {return(cons(sc, opt1_con(cdr(expr)), s_lookup(sc, caddr(expr), expr)));}
static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer expr) {return(cons(sc, opt1_con(cdr(expr)), t_lookup(sc, caddr(expr), expr)));}


#define fx_c_ss_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_1, Lookup1(sc, cadr(expr), expr)); \
    set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(expr)), expr)); \
    return(fn_proc(expr)(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 expr) {return(memq_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_memq_tu(s7_scheme *sc, s7_pointer expr) {return(memq_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_assq_ss(s7_scheme *sc, s7_pointer expr) {return(assq_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_ss(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_st(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_ts(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_tu(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_ot(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, o_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_vref_gt(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, g_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_sref_ss(s7_scheme *sc, s7_pointer expr) {return(string_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_sref_su(s7_scheme *sc, s7_pointer expr) {return(string_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_cons_ss(s7_scheme *sc, s7_pointer expr) {return(cons(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_cons_st(s7_scheme *sc, s7_pointer expr) {return(cons(sc, s_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer expr) {return(cons(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_cons_tu(s7_scheme *sc, s7_pointer expr) {return(cons(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer expr) {return(cons(sc, t_lookup(sc, cadr(expr), expr), U_lookup(sc, opt1_sym(cdr(expr)), expr)));}
/* static s7_pointer fx_cons_Ts(s7_scheme *sc, s7_pointer expr) {return(cons(sc, T_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr((expr)), expr)));} */

#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, Lookup1(sc, cadr(expr), expr), Lookup2(sc, opt1_sym(cdr(expr)), expr))); \
  }

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 expr) {return(multiply_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_multiply_ts(s7_scheme *sc, s7_pointer expr) {return(multiply_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
/* static s7_pointer fx_multiply_Ts(s7_scheme *sc, s7_pointer expr) {return(multiply_p_pp(sc, T_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));} */
static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer expr) {return(g_mul_xf(sc, s_lookup(sc, caddr(expr), expr), real(cadr(expr)), 2));}
static s7_pointer fx_multiply_ft(s7_scheme *sc, s7_pointer expr) {return(g_mul_xf(sc, t_lookup(sc, caddr(expr), expr), real(cadr(expr)), 2));}
static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer expr) {return(g_mul_xf(sc, s_lookup(sc, cadr(expr), expr), real(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_multiply_tf(s7_scheme *sc, s7_pointer expr) {return(g_mul_xf(sc, t_lookup(sc, cadr(expr), expr), real(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer expr) {return(g_mul_xi(sc, s_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_multiply_ti(s7_scheme *sc, s7_pointer expr) {return(g_mul_xi(sc, t_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_multiply_ui(s7_scheme *sc, s7_pointer expr) {return(g_mul_xi(sc, u_lookup(sc, cadr(expr), expr), integer(opt1_con(cdr(expr))), 1));}
static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer expr) {return(g_mul_xi(sc, s_lookup(sc, caddr(expr), expr), integer(cadr(expr)), 2));}
static s7_pointer fx_multiply_it(s7_scheme *sc, s7_pointer expr) {return(g_mul_xi(sc, t_lookup(sc, caddr(expr), expr), integer(cadr(expr)), 2));}
static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer expr) {return(multiply_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}

static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(make_real(sc, real(x) * real(x)));

#if With_Gmp
  return(multiply_p_pp(sc, x, x));
#else
  switch (type(x))
    {
#if Have_Overflow_Checks
    case T_INTEGER:
      {
	s7_int val;
	if (multiply_overflow(integer(x), integer(x), &val))
	  {
	    if (With_Warnings) s7_warn(sc, s7_Warn_Bufsize, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x));
	    return(make_real(sc, (long_double)integer(x) * (long_double)integer(x)));
	  }
	return(make_integer(sc, val));
      }
    case T_RATIO:
      {
	s7_int num, den;
	if ((multiply_overflow(numerator(x), numerator(x), &num)) ||
	    (multiply_overflow(denominator(x), denominator(x), &den)))
	  return(make_real(sc, fraction(x) * fraction(x)));
	return(make_ratio_with_div_check(sc, sc->multiply_symbol, num, den));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) * integer(x)));
    case T_RATIO:   return(make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x)));
#endif
    case T_REAL:    return(make_real(sc, real(x) * real(x)));
    case T_COMPLEX: return(make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
    default:        return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, x, A_Number_String, 1));
    }
  return(x);
#endif
}

static s7_pointer fx_sqr_wrapped(s7_scheme *sc, s7_pointer x)
{
  if (is_t_real(x)) return(wrap_real(sc, real(x) * real(x)));
#if With_Gmp
  return(multiply_p_pp(sc, x, x));
#else
  if (is_t_integer(x))
    return(multiply_if_overflow_to_real_wrapped(sc, integer(x), integer(x)));
  if (is_t_complex(x))
    return(wrap_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
  return(fx_sqr_1(sc, x));
#endif
}

static s7_pointer fx_sqr_s(s7_scheme *sc, s7_pointer expr) {return(fx_sqr_1(sc, s_lookup(sc, cadr(expr), expr)));}
static s7_pointer fx_sqr_t(s7_scheme *sc, s7_pointer expr) {return(fx_sqr_1(sc, t_lookup(sc, cadr(expr), expr)));}

static s7_pointer fx_add_sqr_sqr(s7_scheme *sc, s7_pointer expr)  /* tbig -- need t case here, expr=(+ (* x x) (* y y)) */
{
  sc->temp5 = fx_sqr_wrapped(sc, s_lookup(sc, car(opt1_pair(cdr(expr))), expr));                 /* cadadr(expr) */
  return(add_p_pp(sc, sc->temp5, fx_sqr_wrapped(sc, s_lookup(sc, car(opt3_pair(expr)), expr)))); /* cadaddr(expr) */
}

static s7_pointer fx_hypot(s7_scheme *sc, s7_pointer expr) /* (sqrt (+ (* x x) (* y y))) */
{
  sc->temp5 = fx_sqr_wrapped(sc, s_lookup(sc, opt1_sym(cdr(expr)), expr));                       /* cadadadr(expr) ! -> x */
  return(sqrt_p_p(sc, add_p_pp_wrapped(sc, sc->temp5, fx_sqr_wrapped(sc, s_lookup(sc, opt3_sym(cdr(expr)), expr))))); /* cadaddadr(expr) ->  y */
}

static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer expr) /* call */
{
  set_car(sc->t2_1, s_lookup(sc, cadr(expr), expr));
  set_car(sc->t2_2, fx_sqr_wrapped(sc, s_lookup(sc, opt2_sym(cdr(expr)), expr))); /* cadaddr(expr) */
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer expr) /* fb */
{
  set_car(sc->t2_2, fx_sqr_wrapped(sc, s_lookup(sc, opt1_sym(cdr(expr)), expr))); /* cadaddr(expr) */
  set_car(sc->t2_1, cadr(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_geq_ss(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_st(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, s_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, u_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_vs(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, v_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, t_lookup(sc, cadr(expr), expr), T_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_TU(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, T_lookup(sc, cadr(expr), expr), U_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_to(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, t_lookup(sc, cadr(expr), expr), o_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_vo(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, v_lookup(sc, cadr(expr), expr), o_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_geq_ot(s7_scheme *sc, s7_pointer expr) {return(geq_p_pp(sc, o_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}

static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_gt_to(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, t_lookup(sc, cadr(expr), expr), o_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_gt_ut(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, u_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer expr) {return(gt_p_pp(sc, t_lookup(sc, cadr(expr), expr), global_value(opt1_sym(cdr(expr)))));}

static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer num1 = t_lookup(sc, cadr(expr), expr);
  s7_pointer num2 = T_lookup(sc, opt1_sym(cdr(expr)), expr);
  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 expr) \
  { \
    const s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(opt1_con(cdr(expr))))); \
    if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt1_con(cdr(expr))))); \
    return(g_greater_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */ \
  }

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 expr) {return(leq_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_leq_ts(s7_scheme *sc, s7_pointer expr) {return(leq_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_leq_tu(s7_scheme *sc, s7_pointer expr) {return(leq_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}

#define fx_leq_si_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if (is_t_integer(x)) return(make_boolean(sc, integer(x) <= integer(opt1_con(cdr(expr))))); \
    return(g_leq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */ \
  }

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 expr) {return(lt_p_pp(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_lt_sg(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, s_lookup(sc, cadr(expr), expr), g_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_lt_tg(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, t_lookup(sc, cadr(expr), expr), g_lookup(sc, opt1_sym(cdr(expr)), expr)));}

static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer expr) /* gsg is much faster than sss */
{
  const s7_pointer x1 = g_lookup(sc, cadr(expr), expr);
  const s7_pointer x2 = s_lookup(sc, opt1_sym(cdr(expr)), expr); /* caddr(expr) */
  const s7_pointer x3 = g_lookup(sc, opt2_sym(cdr(expr)), expr); /* cadddr(expr) */
  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 expr) {return(lt_p_pp(sc, t_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_lt_tT(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, t_lookup(sc, cadr(expr), expr), T_lookup(sc, opt1_sym(cdr(expr)), cadr(expr))));}
static s7_pointer fx_lt_tu(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_lt_tU(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, t_lookup(sc, cadr(expr), expr), U_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_lt_ut(s7_scheme *sc, s7_pointer expr) {return(lt_p_pp(sc, u_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}

static s7_pointer fx_lt_tf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_real(x)) return(make_boolean(sc, real(x) < real(opt1_con(cdr(expr)))));
  return(g_less_xf(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */
}

#define fx_lt_si_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt1_con(cdr(expr))))); \
    return(g_less_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */ \
  }

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 expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 0));
  return(g_less_xi(sc, set_plist_2(sc, x, Int_Zero)));
}

static s7_pointer fx_lt_t1(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 1));
  return(g_less_xi(sc, set_plist_2(sc, x, Int_One)));
}

static s7_pointer fx_lt_t2(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 2));
  return(g_less_xi(sc, set_plist_2(sc, x, Int_Two)));
}

static s7_pointer fx_geq_tf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_real(x)) return(make_boolean(sc, real(x) >= real(opt1_con(cdr(expr)))));
  return(g_geq_xf(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */
}

#define fx_geq_si_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup(sc, cadr(expr), expr); \
    if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt1_con(cdr(expr))))); \
    return(g_geq_xi(sc, set_plist_2(sc, x, opt1_con(cdr(expr))))); /* caddr(expr) */ \
  }

fx_geq_si_any(fx_geq_si, s_lookup)
fx_geq_si_any(fx_geq_ti, t_lookup)

static s7_pointer fx_geq_t0(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, cadr(expr), expr);
  if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= 0));
  return(g_geq_xi(sc, set_plist_2(sc, x, Int_Zero)));
}

#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup1(sc, cadr(expr), expr); \
    s7_pointer y = Lookup2(sc, opt1_sym(cdr(expr)), expr); \
    return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \
  }

fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup)
fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup)
fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup)
fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup)
fx_num_eq_ss_any(fx_num_eq_tv, t_lookup, v_lookup)
fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup)
fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_uU, u_lookup, U_lookup)
fx_num_eq_ss_any(fx_num_eq_vU, v_lookup, U_lookup)


#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer x = Lookup1(sc, cadr(expr), expr);	      \
    s7_pointer y = Lookup2(sc, opt1_sym(cdr(expr)), expr); \
    return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \
  }

fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup)
fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup)
fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup)
fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup)


static s7_pointer fx_not_is_eq_ss(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = lookup(sc, opt3_sym(expr));
  s7_pointer y = lookup(sc, opt1_sym(cdr(expr)));
  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 expr)
{
  s7_pointer x = lookup(sc, opt3_sym(expr));
  s7_pointer y = opt3_con(cdr(expr));
  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 expr) {return(x_hash_table_ref_ss(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer expr) {return(x_hash_table_ref_ss(sc, s_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr)));}
static s7_pointer fx_hash_table_ref_TV(s7_scheme *sc, s7_pointer expr) {return(x_hash_table_ref_ss(sc, T_lookup(sc, cadr(expr), expr), V_lookup(sc, opt1_sym(cdr(expr)), expr)));}

static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer table = lookup(sc, cadr(expr));
  const s7_pointer lst = lookup(sc, opt2_sym(cdr(expr)));
  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 expr)
{
  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(expr)), 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(expr), sc->type_names[T_INTEGER]);
      hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1));
      return(hash_entry_value(val));
    }
  s7_hash_table_set(sc, table, key, Int_One);
  return(Int_One);
}

static s7_pointer fx_hash_table_increment(s7_scheme *sc, s7_pointer expr)
{
  return(fx_hash_table_increment_1(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, caddr(expr), expr), expr));
}


static s7_pointer fx_cdr_let_ref_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer sym;
  s7_pointer let = s_lookup(sc, opt2_sym(expr), expr);  /* (var-ref local-var) -> local-var, opt_sym2(expr) == cadr(expr) */
  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(expr), 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(expr));                  /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(expr)))); */
  for (s7_pointer slot = let_slots(let); is_slot_checked(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 expr)
{
  s7_pointer p = opt1_con(cdr(expr));
  s7_pointer obj = lookup(sc, cadr(expr));
  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 expr) {return(fn_proc(expr)(sc, with_list_t2(sc, cadr(expr), opt2_con(cdr(expr)))));}

#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t3_1, Lookup1(sc, cadr(expr), expr)); \
    set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(expr)), expr)); /* caddr(expr) */ \
    set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(expr)), expr)); /* cadddr(expr) */ \
    return(fn_proc(expr)(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 expr)
{
  return(((s7_p_ppp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr), s_lookup(sc, opt2_sym(cdr(expr)), expr)));
}

static s7_pointer fx_c_tuv_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_ppp_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr), u_lookup(sc, opt1_sym(cdr(expr)), expr), v_lookup(sc, opt2_sym(cdr(expr)), expr)));
}

static s7_pointer fx_vset_sts(s7_scheme *sc, s7_pointer expr)
{
  return(vector_set_p_ppp(sc, s_lookup(sc, cadr(expr), expr), t_lookup(sc, opt1_sym(cdr(expr)), expr), s_lookup(sc, opt2_sym(cdr(expr)), expr)));
}

#define fx_c_scs_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t3_1, Lookup1(sc, cadr(expr), expr)); \
    set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(expr)), expr)); /* cadddr(expr) */ \
    set_car(sc->t3_2, opt1_con(cdr(expr)));                    /* caddr(expr) */ \
    return(fn_proc(expr)(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 expr) \
  { \
    return(((s7_p_ppp_t)opt3_direct(cdr(expr)))(sc, Lookup1(sc, cadr(expr), expr), opt1_con(cdr(expr)), Lookup2(sc, opt2_sym(cdr(expr)), expr))); \
  }

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 expr)
{
  set_car(sc->t3_1, s_lookup(sc, cadr(expr), expr));
  set_car(sc->t3_2, opt1_con(cdr(expr))); /* caddr(expr) */
  set_car(sc->t3_3, opt2_con(cdr(expr))); /* cadddr(expr) */
  return(fn_proc(expr)(sc, sc->t3_1));
}

#define fx_c_css_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(expr)), expr)); /* caddr(expr) */ \
    set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(expr)), expr)); /* cadddr(expr) */ \
    set_car(sc->t3_1, cadr(expr)); \
    return(fn_proc(expr)(sc, sc->t3_1)); \
  }

fx_c_css_any(fx_c_css, s_lookup, s_lookup)
fx_c_css_any(fx_c_ctv, t_lookup, v_lookup)
fx_c_css_any(fx_c_cTs, T_lookup, s_lookup)

static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_2, s_lookup(sc, opt1_sym(cdr(expr)), expr)); /* caddr(expr) */
  set_car(sc->t3_1, opt3_con(cdr(expr)));             /* cadr(expr) or maybe cadadr if quoted? */
  set_car(sc->t3_3, opt2_con(cdr(expr)));             /* cadddr(expr) */
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_3, s_lookup(sc, opt1_sym(cdr(expr)), expr)); /* cadddr(expr) */
  set_car(sc->t3_1, cadr(expr)); /* maybe opt3_con? */
  set_car(sc->t3_2, opt2_con(cdr(expr)));             /* caddr(expr) */
  return(fn_proc(expr)(sc, sc->t3_1));
}

#define fx_c_ssc_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t3_1, Lookup1(sc, cadr(expr), expr)); \
    set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(expr)), expr)); /* caddr(expr) */ \
    set_car(sc->t3_3, opt2_con(cdr(expr)));             /* cadddr(expr) */ \
    return(fn_proc(expr)(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 expr)
{
  return(fn_proc(expr)(sc, with_list_t1(sc, fn_call(sc, cadr(expr)))));
}

#define fx_c_opsq_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer arg1 = cadr(expr); \
    set_car(sc->t1_1, fn_proc(arg1)(sc, with_list_t1(sc, Lookup(sc, cadr(arg1), arg1)))); \
    return(fn_proc(expr)(sc, sc->t1_1)); \
  }

fx_c_opsq_any(fx_c_opsq, s_lookup)
fx_c_opsq_any(fx_c_optq, t_lookup)

static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, opt1_sym(cdr(expr)), expr))));
}

#define fx_c_car_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer val = Lookup(sc, opt3_sym(expr), expr); \
    set_car(sc->t1_1, car_p_p(sc, val)); \
    return(fn_proc(expr)(sc, sc->t1_1)); \
  }

fx_c_car_s_any(fx_c_car_s, s_lookup)
fx_c_car_s_any(fx_c_car_t, t_lookup)
fx_c_car_s_any(fx_c_car_u, u_lookup)

#define fx_c_cdr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer val = Lookup(sc, opt3_sym(expr), expr); \
    set_car(sc->t1_1, cdr_p_p(sc, val)); \
    return(fn_proc(expr)(sc, sc->t1_1)); \
  }

fx_c_cdr_s_any(fx_c_cdr_s, s_lookup)
fx_c_cdr_s_any(fx_c_cdr_t, t_lookup)

#define fx_is_type_opsq_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t1_1, Lookup(sc, opt3_sym(expr), expr)); \
    return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == type(fn_proc(cadr(expr))(sc, sc->t1_1)))); \
  }

fx_is_type_opsq_any(fx_is_type_opsq, s_lookup)
fx_is_type_opsq_any(fx_is_type_optq, t_lookup)

static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = lookup(sc, opt3_sym(expr));
  return(make_boolean(sc, ((uint8_t)(opt3_byte(cdr(expr)))) == type(car_p_p(sc, val))));
}

static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer func;
  const s7_pointer val = t_lookup(sc, opt3_sym(expr), expr);
  if (is_pair(val))
    return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == type(car(val))));
  if (!has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */
    sole_arg_wrong_type_error_nr(sc, sc->car_symbol, val, sc->type_names[T_PAIR]);
  func = find_method_with_let(sc, val, sc->car_symbol);
  if (func == sc->undefined)
    sole_arg_wrong_type_error_nr(sc, sc->car_symbol, 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(expr))));
}

static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer func;
  const s7_pointer val = lookup(sc, opt3_sym(expr));
  if (is_c_pointer(val))                /* (let? (c-pointer-weak1 val)) etc */
    return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(expr))) == 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 */
    sole_arg_wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, val, sc->type_names[T_C_POINTER]);
  func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol);
  if (func == sc->undefined)
    sole_arg_wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 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(expr))));
}

#define fx_not_opsq_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer arg1 = cadr(expr); \
    set_car(sc->t1_1, Lookup(sc, cadr(arg1), expr)); \
    return((fn_proc(arg1)(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \
  }

fx_not_opsq_any(fx_not_opsq, s_lookup)
fx_not_opsq_any(fx_not_optq, t_lookup)

static s7_pointer fx_not_car_t(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = t_lookup(sc, opt3_sym(expr), expr); /* cadadr */
  return((car_p_p(sc, p) == sc->F) ? sc->T : sc->F);
}


#define fx_c_opssq_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_1, Lookup1(sc, opt3_sym(expr), expr)); \
    set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(expr)), expr)); \
    return(fn_proc(expr)(sc, with_list_t1(sc, fn_proc(cadr(expr))(sc, sc->t2_1)))); \
  }

fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup)
fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup)
fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup)


#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(((s7_p_p_t)opt2_direct(cdr(expr)))(sc, \
              ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, Lookup1(sc, opt3_sym(expr), expr), Lookup2(sc, opt1_sym(cdr(expr)), expr)))); \
  }

fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup)
fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup)
fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup)


#define fx_not_opssq_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer larg = cadr(expr); \
    set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \
    set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(larg)), larg)); \
    return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \
 }

fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup)
fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup)


static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer y = u_lookup(sc, opt3_sym(expr), expr);
  s7_pointer x = t_lookup(sc, opt1_sym(cdr(expr)), expr);
  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 expr)
{
  const s7_pointer t = t_lookup(sc, opt1_sym(cdr(expr)), expr);
  s7_pointer u = u_lookup(sc, opt3_sym(expr), expr);
  u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */
  if ((is_t_integer(u)) && (is_t_integer(t)))
    return(make_boolean(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0));
  return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t))));
}

static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer x = o_lookup(sc, opt3_sym(expr), expr);
  const s7_pointer y = s_lookup(sc, opt1_sym(cdr(expr)), expr);
  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, is_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 expr) \
  { \
    const s7_pointer arg1 = cadr(expr); \
    set_car(sc->t2_1, Lookup(sc, cadr(arg1), arg1)); \
    set_car(sc->t2_2, opt1_con(cdr(arg1))); \
    return(fn_proc(expr)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1)))); \
  }

fx_c_opscq_any(fx_c_opscq, s_lookup)
fx_c_opscq_any(fx_c_optcq, t_lookup)

static s7_pointer fx_is_zero_remainder_ti(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer larg = cdadr(expr);
  const s7_pointer t = t_lookup(sc, car(larg), expr);
  const s7_int u = integer(cadr(larg));
  if (is_t_integer(t)) return(make_boolean(sc, (integer(t) % u) == 0));
  return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pi(sc, t, u))));
}

static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  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 expr)
{
  const s7_pointer arg1 = cadr(expr);
  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(expr)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1))));
}

static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  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(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opcsq_s(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  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(expr)));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  set_car(sc->t2_1, s_lookup(sc, cadr(arg1), expr));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdr(arg1)), expr));
  set_car(sc->t2_1, fn_proc(arg1)(sc, sc->t2_1));
  set_car(sc->t2_2, s_lookup(sc, caddr(expr), expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1_p = opt3_pair(expr); /* cdadr(expr) */
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc,
	   ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, car(arg1_p), expr), s_lookup(sc, opt1_sym(arg1_p), expr)),
	   s_lookup(sc, caddr(expr), expr)));
}

static s7_pointer fx_c_opsuq_s_direct(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1_p = opt3_pair(expr); /* cdadr(expr) */
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc,
	   ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, car(arg1_p), expr), u_lookup(sc, opt1_sym(arg1_p), expr)),
	   s_lookup(sc, caddr(expr), expr)));
}

static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1_p = opt3_pair(expr);   /* cdadr(expr) */
  const s7_pointer a = s_lookup(sc, car(arg1_p), expr);
  const s7_pointer b = s_lookup(sc, opt1_sym(arg1_p), expr);
  const s7_pointer c = s_lookup(sc, caddr(expr), expr);
  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, s7_Warn_Bufsize, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n",
				     integer(a), integer(b), integer(c));
	  return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c)));
	}
      return(make_integer(sc, val));
    }
#else
    return(make_integer(sc, (integer(a) * integer(b)) + integer(c)));
#endif
  return(add_p_pp(sc, multiply_p_pp_wrapped(sc, a, b), c));
}

static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer arg1_p = opt3_pair(expr); /* cdadr(expr) */
  return(cons_unchecked(sc, cons(sc, s_lookup(sc, car(arg1_p), expr), s_lookup(sc, opt1_sym(arg1_p), expr)), s_lookup(sc, caddr(expr), expr)));
}

#define fx_add_sqr_s_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer num1 = Lookup(sc, car(opt3_pair(expr)), expr); \
    const s7_pointer num2 = s_lookup(sc, caddr(expr), expr); \
    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 expr)
{
  const s7_pointer arg1_p = opt3_pair(expr); /* cdadr(expr) */
  const s7_pointer num1 = lookup(sc, car(arg1_p));
  const s7_pointer num2 = lookup(sc, opt1_sym(arg1_p));
  const s7_pointer num3 = lookup(sc, caddr(expr));
  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 expr)
{
  const s7_pointer num1 = t_lookup(sc, car(cdadr(expr)), expr);
  const s7_pointer num2 = u_lookup(sc, cadr(cdadr(expr)), expr);
  const s7_pointer num3 = lookup(sc, caddr(expr));
  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 expr)
{
  const s7_pointer arg1_p = opt3_pair(expr); /* cdadr(expr) */
  const s7_pointer x1 = lookup(sc, car(arg1_p));
  const s7_pointer x2 = lookup(sc, opt1_sym(arg1_p));
  const s7_pointer x3 = lookup(sc, caddr(expr));
  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 expr)
{
  const s7_pointer x1 = t_lookup(sc, car(cdadr(expr)), expr);
  const s7_pointer x2 = u_lookup(sc, cadr(cdadr(expr)), expr);
  const s7_pointer x3 = lookup(sc, caddr(expr));
  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 expr)
{
  return(gt_p_pp(sc, vector_ref_p_pp(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr)), s_lookup(sc, caddr(expr), expr)));
}

static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer expr)
{
  return(geq_p_pp(sc, s_lookup(sc, cadr(expr), expr), vector_ref_p_pp(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer expr)
{
  return(make_boolean(sc, s_lookup(sc, cadr(expr), expr) == vector_ref_p_pp(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer expr)
{
  return(hash_table_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), vector_ref_p_pp(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer expr) /* tbig */
{
  return(let_ref(sc, s_lookup(sc, cadr(expr), expr), vector_ref_p_pp(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer expr)
{
  return(vector_ref_p_pp(sc, s_lookup(sc, cadr(expr), expr), add_p_pp_wrapped(sc, s_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

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(vector_ref_p_pp(sc, 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 expr) \
  { \
    return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(expr)), expr), Lookup2(sc, opt1_sym(opt3_pair(expr)), expr), Lookup3(sc, caddr(expr), expr))); \
  }

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 expr) /* out one level from vref_vref_tu_v */
{
  return(fx_vref_vref_3(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt2_sym(expr), expr), s_lookup(sc, opt3_sym(expr), expr)));
}

static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  set_car(sc->t2_1, s_lookup(sc, cadr(arg1), expr));
  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(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

#if !With_Gmp
static s7_pointer fx_c_optcq_c_ash(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer arg1 = cadr(expr);
  return(make_integer(sc, c_ash(sc, integer(fn_proc(arg1)(sc, with_list_t2(sc, t_lookup(sc, cadr(arg1), expr), opt1_con(cdr(arg1))))), integer(caddr(expr)))));
}

static s7_pointer fx_c_optcq_c(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  set_car(sc->t2_1, t_lookup(sc, cadr(arg1), expr));
  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(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}
#endif

#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer arg1 = cadr(expr); \
    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(expr))); /* caddr */ \
    return(fn_proc(expr)(sc, sc->t2_1)); \
  }

fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup)
fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup)


static s7_pointer fx_c_opstq_c_direct(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer arg1 = cadr(expr);
  return(((s7_p_pp_t)opt3_direct(expr))(sc, fn_proc(arg1)(sc, set_plist_2(sc, s_lookup(sc, cadr(arg1), expr), t_lookup(sc, caddr(arg1), expr))), opt3_con(cdr(expr))));
}

#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer arg1 = cadr(expr); \
    set_car(sc->t2_1, fn_proc(arg1)(sc, with_list_t1(sc, Lookup1(sc, cadr(arg1), expr)))); /* also opt1_sym(cdr(expr)) */ \
    set_car(sc->t2_2, Lookup2(sc, opt3_sym(expr), expr)); /* caddr(expr) */ \
    return(fn_proc(expr)(sc, sc->t2_1)); \
  }

fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup)
fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup)
fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup)


#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, \
	      ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, Lookup1(sc, opt1_sym(cdr(expr)), expr)), \
	      Lookup2(sc, opt3_sym(expr), expr))); \
  }

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 expr) \
  { \
    s7_pointer p = Lookup1(sc, opt1_sym(cdr(expr)), expr); \
    if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(expr), expr))); \
    return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(expr), expr))); \
  }

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)
fx_cons_car_s_s_any(fx_cons_car_T_V, T_lookup, V_lookup)


static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer expr)
{
  return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, u_lookup(sc, opt1_sym(cdr(expr)), expr)), t_lookup(sc, opt3_sym(expr), expr)));
}

#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t3_1, fn_proc(cadr(expr))(sc, with_list_t1(sc, Lookup1(sc, opt3_sym(cdr(expr)), expr))));  /* cadadr(expr) */ \
    set_car(sc->t3_2, opt1_con(cdr(expr)));              /* caddr(expr) or cadaddr(expr) */ \
    set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(expr)), expr));  /* cadddr(expr) */ \
    return(fn_proc(expr)(sc, sc->t3_1)); \
  }

fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup)
fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup)


#define fx_c_opsq_c_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_1, fn_proc(cadr(expr))(sc, with_list_t1(sc, Lookup(sc, opt1_sym(cdr(expr)), expr)))); /* cadadr */ \
    set_car(sc->t2_2, opt2_con(cdr(expr))); \
    return(fn_proc(expr)(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 expr)
{
  return(((s7_p_pp_t)opt3_direct(expr))(sc, ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, opt1_sym(cdr(expr)), expr)), opt2_con(cdr(expr))));
}

static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_ii_t)opt3_direct(expr))(sc, ((s7_i_7p_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, opt1_sym(cdr(expr)), expr)), integer(opt2_con(cdr(expr)))));
}

static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer lst = opt2_con(cdr(expr));
  const s7_pointer obj = car_p_p(sc, lookup(sc, opt1_sym(cdr(expr))));
  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 expr)
{
  const s7_pointer lst = opt2_con(cdr(expr));
  const s7_pointer obj = car_p_p(sc, lookup(sc, opt1_sym(cdr(expr))));
  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 expr)
{
  const s7_pointer arg2 = caddr(expr);
  set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(sc, s_lookup(sc, cadr(arg2), expr), s_lookup(sc, opt1_sym(cdr(arg2)), expr))));
  set_car(sc->t2_1, s_lookup(sc, cadr(expr), expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p_arg2 = opt3_pair(expr); /* cdaddr(expr) */ \
    expr = cdr(expr); \
    return(((s7_p_pp_t)opt2_direct(expr))(sc, Lookup1(sc, car(expr), expr), \
					 ((s7_p_pp_t)opt3_direct(expr))(sc, s_lookup(sc, car(p_arg2), expr), Lookup2(sc, opt1_sym(p_arg2), p_arg2)))); \
  }

fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup)
fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup)
fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup)
fx_c_s_opssq_direct_any(fx_c_s_opsuq_direct, s_lookup, u_lookup)

static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer expr)
{
  return(vector_ref_p_pp(sc, g_lookup(sc, cadr(expr), expr),
			 vector_ref_p_pp(sc, g_lookup(sc, car(opt3_pair(expr)), expr), s_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer expr)
{
  return(vector_ref_p_pp(sc, g_lookup(sc, cadr(expr), expr),
			 vector_ref_p_pp(sc, g_lookup(sc, car(opt3_pair(expr)), expr), t_lookup(sc, opt1_sym(opt3_pair(expr)), expr))));
}

static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg2 = caddr(expr);
  set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(sc, s_lookup(sc, cadr(arg2), expr), s_lookup(sc, opt1_sym(cdr(arg2)), expr))));
  set_car(sc->t2_1, cadr(expr));      /* currently (<safe-f> 'a <opssq>) goes to safe_c_ca so this works by inadvertence */
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, cadr(expr), /* see above */
	   ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, opt3_sym(expr), expr), s_lookup(sc, opt1_sym(cdr(expr)), expr))));
}

static s7_pointer fx_c_nc_opssq_direct(s7_scheme *sc, s7_pointer expr) /* clm2xen (* 1.0 (oscil g2 x2)) */
{
  s7_double x2 = ((s7_d_pd_t)opt3_direct(cdr(expr)))(s_lookup(sc, opt3_sym(expr), expr), real_to_double(sc, s_lookup(sc, opt1_sym(cdr(expr)), expr), __func__));
  return(((s7_p_dd_t)opt2_direct(cdr(expr)))(sc, real_to_double(sc, cadr(expr), __func__), x2));
}

static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer expr) /* (* c=float (* x1 x2))! */
{
  const s7_pointer x1 = s_lookup(sc, opt3_sym(expr), expr);
  const s7_pointer x2 = s_lookup(sc, opt1_sym(cdr(expr)), expr);
  if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(cadr(expr)) * real(x1) * real(x2)));
  return(multiply_p_pp(sc, cadr(expr), 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 expr)		\
  {								\
    const s7_pointer arg2 = caddr(expr);				\
    set_car(sc->t2_1, Lookup2(sc, cadr(arg2), expr));		\
    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(expr), expr));		\
    return(fn_proc(expr)(sc, sc->t2_1));				\
  }

fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup)
fx_c_s_opscq_any(fx_c_u_optcq, u_lookup, t_lookup)
/* also fx_c_T_optcq */

static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr),
            ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, opt3_sym(expr), expr), opt1_con(cdr(expr)))));
}

static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr),
	   ((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, opt3_sym(expr), expr), integer(opt1_con(cdr(expr))))));
}

static s7_pointer fx_c_u_optiq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, u_lookup(sc, cadr(expr), expr),
	   ((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, t_lookup(sc, opt3_sym(expr), expr), integer(opt1_con(cdr(expr))))));
}

static s7_pointer fx_c_t_opoiq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr),
	   ((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, o_lookup(sc, opt3_sym(expr), expr), integer(opt1_con(cdr(expr))))));
}

static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer ind = lookup(sc, opt3_sym(expr));
  const s7_pointer vec = lookup(sc, cadr(expr));
  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(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 expr)
{
  const s7_pointer i1 = lookup(sc, cadr(expr));
  const s7_pointer i2 = lookup(sc, opt3_sym(expr));
  if ((is_t_integer(i1)) && (is_t_integer(i2)))
    return(make_boolean(sc, integer(i1) == (integer(i2) + integer(opt1_con(cdr(expr))))));
  return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_add_xi(sc, i2, integer(opt1_con(cdr(expr))), 2))));
}

static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer i1 = lookup(sc, cadr(expr));
  const s7_pointer i2 = lookup(sc, opt3_sym(expr));
  if ((is_t_integer(i1)) && (is_t_integer(i2)))
    return(make_boolean(sc, integer(i1) == (integer(i2) - integer(opt1_con(cdr(expr))))));
  return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_sub_xi(sc, i2, integer(opt1_con(cdr(expr)))))));
}

#define fx_c_t_opscq_direct_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, t_lookup(sc, cadr(expr), expr), \
	     ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, Lookup(sc, opt3_sym(expr), expr), opt1_con(cdr(expr))))); \
  }

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 expr)
{
  const s7_pointer arg2 = caddr(expr);
  set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(sc, s_lookup(sc, cadr(arg2), expr))));
  set_car(sc->t2_1, s_lookup(sc, cadr(expr), expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    expr = cdr(expr); \
    return(((s7_p_pp_t)opt2_direct(expr))(sc, Lookup1(sc, car(expr), expr), ((s7_p_p_t)opt3_direct(expr))(sc, Lookup2(sc, opt1_sym(expr), expr)))); /* cadadr */ \
  }

fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup)
fx_c_s_opsq_direct_any(fx_c_t_opsq_direct, t_lookup, s_lookup)
fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup)
fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup)
fx_c_s_opsq_direct_any(fx_c_o_opoq_direct, o_lookup, o_lookup)

#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    const s7_pointer val = Lookup2(sc, opt2_sym(cdr(expr)), expr); \
    set_car(sc->t2_2, car_p_p(sc, val)); \
    set_car(sc->t2_1, Lookup1(sc, cadr(expr), expr)); \
    return(fn_proc(expr)(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) /* trec */
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 expr) \
  { \
    s7_pointer val1 = Lookup1(sc, cadr(expr), expr); \
    s7_pointer val2 = car_p_p(sc, Lookup2(sc, opt2_sym(cdr(expr)), expr)); \
    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) /* tshoot */

static s7_pointer fx_add_u_car_t_direct(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val1 = u_lookup(sc, cadr(expr), expr);
  s7_pointer val2 = car(t_lookup(sc, opt2_sym(cdr(expr)), expr));
  return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2));
}

static s7_pointer fx_cons_s_cdr_s(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = cdr_p_p(sc, lookup(sc, opt2_sym(cdr(expr))));
  return(cons(sc, s_lookup(sc, cadr(expr), expr), val));
}

static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer outer = cadr(expr);
  const s7_pointer args = caddr(outer);
  set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(sc, s_lookup(sc, cadr(args), expr))));
  set_car(sc->t2_1, s_lookup(sc, cadr(outer), expr));
  return(fn_proc(expr)(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 expr)
{
  const s7_pointer outer = cadr(expr);
  const s7_pointer args = caddr(outer);
  set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(sc, s_lookup(sc, cadr(args), expr))));
  set_car(sc->t2_1, s_lookup(sc, cadr(outer), expr));
  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 expr)
{
  const s7_pointer outer = cadr(expr);
  const s7_pointer args = cadr(outer);
  set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(sc, s_lookup(sc, cadr(args), expr))));
  set_car(sc->t2_2, s_lookup(sc, caddr(outer), expr));
  return(fn_proc(expr)(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 expr)
{
  const s7_pointer outer = cadr(expr);
  const s7_pointer args = cadr(outer);
  set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(sc, t_lookup(sc, cadr(args), expr))));
  set_car(sc->t2_2, s_lookup(sc, caddr(outer), expr));
  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 expr)
{
  const s7_pointer arg2 = opt3_pair(expr); /* caddr(expr) */
  set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(sc, s_lookup(sc, cadr(arg2), expr))));
  set_car(sc->t2_1, cadr(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_c_opsq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt2_direct(cdr(expr)))(sc, cadr(expr), ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, opt1_sym(cdr(expr)), expr))));
}

/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */

static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer argp = cdr(expr);
  gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(sc, s_lookup(sc, cadar(argp), expr))));
  argp = cadr(argp);
  set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(sc, s_lookup(sc, cadr(argp), expr))));
  set_car(sc->t2_1, gc_protected1(sc));
  unstack_gc_protect(sc);
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt3_direct(expr))(sc,
	    ((s7_p_p_t)opt2_direct(cdr(expr)))(sc, s_lookup(sc, cadadr(expr), expr)),          /* no free field in expr or cdr(expr) */
            ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, opt1_sym(cdr(expr)), expr)))); /* cadaddr(expr) */
}

static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x = t_lookup(sc, opt1_sym(cdr(expr)), expr); /* cadadr and cadaddr */
  return(((s7_p_pp_t)opt3_direct(expr))(sc, ((s7_p_p_t)opt2_direct(cdr(expr)))(sc, x), ((s7_p_p_t)opt3_direct(cdr(expr)))(sc, x)));
}

#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    s7_pointer p1 = Lookup1(sc, opt1_sym(cdr(expr)), expr); \
    s7_pointer p2 = Lookup2(sc, opt2_sym(cdr(expr)), expr);  /* cadaddr(expr) */ \
    return(((s7_p_pp_t)opt3_direct(expr))(sc, car_p_p(sc, p1), car_p_p(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 expr)
{
  s7_pointer p1 = lookup(sc, opt1_sym(cdr(expr)));
  s7_pointer p2 = lookup(sc, opt2_sym(cdr(expr)));  /* cadaddr(expr) */
  return(((s7_p_pp_t)opt3_direct(expr))(sc, cdr_p_p(sc, p1), cdr_p_p(sc, p2)));
}

static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p1 = car_p_p(sc, t_lookup(sc, opt1_sym(cdr(expr)), expr));
  s7_pointer p2 = car_p_p(sc, u_lookup(sc, opt2_sym(cdr(expr)), expr));
  return(make_boolean(sc, (p1 == p2) || ((is_unspecified(p1)) && (is_unspecified(p2)))));
}

static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer argp = cdr(expr);
  gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(sc, s_lookup(sc, cadar(argp), expr))));
  argp = cadr(argp);
  set_car(sc->t2_1, s_lookup(sc, cadr(argp), expr));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdr(argp)), expr)); /* 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(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opsq_optuq_direct(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer argp = cdr(expr);
  return(((s7_p_pp_t)opt3_direct(expr))(sc,
	    ((s7_p_p_t)opt2_direct(argp))(sc, s_lookup(sc, cadar(argp), expr)),
            ((s7_p_pp_t)opt3_direct(argp))(sc, t_lookup(sc, opt2_sym(cdr(argp)), expr), u_lookup(sc, opt1_sym(argp), expr))));
}

static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer expr) /* b, also subtract */
{
  const s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(expr), expr));
  const s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(expr)), expr);
  const s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(expr)), expr);
  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 expr)
{
  const s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(expr), expr));
  const s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(expr)), expr);
  const s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(expr)), expr);
  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 expr)
{
  s7_pointer argp = cdr(expr);
  set_car(sc->t2_1, s_lookup(sc, cadar(argp), expr));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdar(argp)), expr));
  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, s_lookup(sc, cadr(argp), expr))));
  set_car(sc->t2_1, gc_protected1(sc));
  unstack_gc_protect(sc);
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer argp = cdr(expr);
  set_car(sc->t2_1, s_lookup(sc, cadar(argp), expr));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdar(argp)), expr));
  gc_protect_via_stack(sc, fn_proc(car(argp))(sc, sc->t2_1));
  argp = cadr(argp);
  set_car(sc->t2_1, s_lookup(sc, cadr(argp), expr));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdr(argp)), expr));
  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(expr)(sc, sc->t2_1));
}

static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer expr) /* (- (* x1 x2) (* x3 x4)) */
{
  s7_pointer p1 = opt3_pair(expr);      /* cdaddr(expr) */
  s7_pointer x1 = s_lookup(sc, car(p1), expr);
  s7_pointer x2 = s_lookup(sc, cadr(p1), expr);
  s7_pointer p2 = opt1_pair(cdr(expr)); /* cdadr(expr) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */
  s7_pointer x3 = s_lookup(sc, car(p2), expr);
  s7_pointer x4 = s_lookup(sc, cadr(p2), expr);
  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 expr) /* (+ (* x1 x2) (* x3 x4)) */
{
  s7_pointer p1 = opt3_pair(expr);      /* cdaddr(expr) */
  s7_pointer x1 = lookup(sc, car(p1));
  s7_pointer x2 = lookup(sc, cadr(p1));
  s7_pointer p2 = opt1_pair(cdr(expr)); /* cdadr(expr) */
  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 expr) /* (* (- x1 x2) (- x3 x4)) */
{
  s7_pointer p1 = opt3_pair(expr);      /* cdaddr(expr) */
  s7_pointer x1 = lookup(sc, car(p1));
  s7_pointer x2 = lookup(sc, cadr(p1));
  s7_pointer p2 = opt1_pair(cdr(expr)); /* cdadr(expr) */
  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 expr)
{
  s7_pointer p1 = opt3_pair(expr);      /* cdaddr(expr) */
  sc->temp5 = subtract_p_pp_wrapped(sc, s_lookup(sc, car(p1), expr), s_lookup(sc, cadr(p1), expr));
  p1 = opt1_pair(cdr(expr)); /* cdadr(expr) */
  return(lt_p_pp(sc, subtract_p_pp_wrapped(sc, s_lookup(sc, car(p1), expr), s_lookup(sc, cadr(p1), expr)), sc->temp5));
}

static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1p = cdadr(expr);
  const s7_pointer vec = lookup(sc, car(arg1p));
  const s7_pointer num1 = lookup(sc, cadr(arg1p));
  const s7_pointer num2 = lookup(sc, opt3_sym(expr)); /* caddaddr(expr) */
  if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(vec)) && (vector_rank(vec) == 1)))
    {
      s7_int index1 = integer(num1), index2 = integer(num2);
      if ((index1 >= 0) && (index1 <= vector_length(vec)) && (index2 >= 0) && (index2 < vector_length(vec)))
	return(subtract_p_pp(sc, vector_ref_p_pi(sc, vec, index1), vector_ref_p_pi(sc, vec, index2)));
    }
  return(subtract_p_pp(sc, vector_ref_p_pp(sc, vec, num1), vector_ref_p_pp(sc, vec, num2)));
}

static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t1_1, fn_proc(opt3_pair(expr))(sc, with_list_t1(sc, s_lookup(sc, opt3_sym(cdr(expr)), expr))));
  set_car(sc->t1_1, fn_proc(cadr(expr))(sc, sc->t1_1));
  return(fn_proc(expr)(sc, sc->t1_1));
}

static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t1_1, fn_proc(opt3_pair(expr))(sc, with_list_t1(sc, s_lookup(sc, opt3_sym(cdr(expr)), expr))));
  return((fn_proc(cadr(expr))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F);
}

static s7_pointer fx_not_is_pair_opsq(s7_scheme *sc, s7_pointer expr)
{
  return(make_boolean(sc, !is_pair(fn_proc(opt3_pair(expr))(sc, set_plist_1(sc, s_lookup(sc, opt3_sym(cdr(expr)), expr))))));
}

static s7_pointer fx_sref_t_last(s7_scheme *sc, s7_pointer expr) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(expr), expr), Int_Zero));} /* both syms are t_lookup */
static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer expr)         {return(fn_proc(expr)(sc, with_list_t1(sc, fx_call(sc, cdr(expr)))));}
static s7_pointer fx_c_a_direct(s7_scheme *sc, s7_pointer expr)  {return(((s7_p_p_t)opt3_direct(expr))(sc, fx_call(sc, cdr(expr))));}
static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer expr)       {return((fx_call(sc, cdr(expr)) == sc->F) ? sc->T : sc->F);}

static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer result;
  gc_protect_via_stack(sc, fx_call(sc, opt3_pair(expr))); /* opt3_pair=cddr */
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  set_car(sc->t3_1, s_lookup(sc, cadr(expr), expr));
  set_car(sc->t3_2, gc_protected1(sc));
  result = fn_proc(expr)(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 expr) \
  { \
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr)))); \
  set_car(sc->t3_1, Lookup1(sc, cadr(expr), expr));\
  set_car(sc->t3_2, Lookup2(sc, car(opt3_pair(expr)), expr)); \
  return(fn_proc(expr)(sc, sc->t3_1));\
  }

fx_c_ssa_any(fx_c_ssa, s_lookup, s_lookup)
fx_c_ssa_any(fx_c_tsa, t_lookup, s_lookup)
fx_c_ssa_any(fx_c_sta, s_lookup, t_lookup)

static s7_pointer fx_c_ssa_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_ppp_t)opt2_direct(cdr(expr)))(sc, s_lookup(sc, cadr(expr), expr), s_lookup(sc, car(opt3_pair(expr)), expr), fx_call(sc, cdr(opt3_pair(expr)))));
}

static s7_pointer fx_c_ass(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_1, fx_call(sc, cdr(expr)));
  set_car(sc->t3_2, s_lookup(sc, car(opt3_pair(expr)), expr));
  set_car(sc->t3_3, s_lookup(sc, cadr(opt3_pair(expr)), expr));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_agg(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_1, fx_call(sc, cdr(expr)));
  set_car(sc->t3_2, fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_sas(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_2, fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_1, s_lookup(sc, cadr(expr), expr));
  set_car(sc->t3_3, s_lookup(sc, cadr(opt3_pair(expr)), expr));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  set_car(sc->t3_1, s_lookup(sc, cadr(expr), expr));
  set_car(sc->t3_2, car(opt3_pair(expr)));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_Tca(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  set_car(sc->t3_1, T_lookup(sc, cadr(expr), expr));
  set_car(sc->t3_2, car(opt3_pair(expr)));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  set_car(sc->t3_1, cadr(expr));
  set_car(sc->t3_2, s_lookup(sc, car(opt3_pair(expr)), expr));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_2, fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_1, cadr(expr));
  set_car(sc->t3_3, cadr(opt3_pair(expr)));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer result;
  /* check_stack_size(sc); */
  gc_protect_2_via_stack(sc, fx_call(sc, cdr(expr)), fx_call(sc, opt3_pair(expr))); /* opt3_pair = cddr(expr) */
  set_car(sc->t2_1, T_Ext(gc_protected1(sc)));
  set_car(sc->t2_2, gc_protected2(sc));
  result = fn_proc(expr)(sc, sc->t2_1);
  unstack_gc_protect(sc);
  /* (define (f0) (write (vector 1.0) (openlet (inlet 'write for-each)))) or worse,
   *   (define L (openlet (inlet 'write for-each))) (define (f) (write (vector 1.0) L))
   *   will segfault (probably) because the for-each pushes an operator on the stack, expecting to continue in eval, but
   *   write is a safe function that the optimizer thinks can ignore such stuff.  s7.html warns about this -- the signatures should be compatible.
   *   Maybe openlet (or inlet?) should warn about for-each, map, member, and assoc.
   * We could check first that stack_top_op == OP_GC_PROTECT and not unstack if it isn't, but there is nothing special to fx_c_aa in that regard.
   */
  return(result);
}

static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t2_2, fx_call(sc, cddr(expr)));
  set_car(sc->t2_1, opt3_con(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t2_1, fx_call(sc, cdr(expr)));
  set_car(sc->t2_2, opt3_con(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_ac_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, fx_call(sc, cdr(expr)), opt3_con(expr)));}
static s7_pointer fx_c_ai_direct(s7_scheme *sc, s7_pointer expr) {return(((s7_p_pi_t)opt3_direct(cdr(expr)))(sc, fx_call(sc, cdr(expr)), integer(opt3_con(expr))));}

static s7_pointer fx_sub_a1(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer num = fx_call(sc, cdr(expr));
  if (is_t_integer(num)) return(subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1));
  if (is_t_real(num)) return(make_real(sc, real(num) - 1.0));
  return(subtract_p_pp(sc, num, Int_One));
}

static s7_pointer fx_add_a1(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer num = fx_call(sc, cdr(expr));
  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 expr)
{
  s7_pointer num = fx_call(sc, cdr(expr));
  if (is_t_real(num)) return(make_boolean(sc, real(num) < real(opt3_con(expr))));
  if (is_t_integer(num)) return(make_boolean(sc, integer(num) < real(opt3_con(expr))));
  return(make_boolean(sc, lt_b_7pp(sc, num, opt3_con(expr))));
}

static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer y = opt3_con(expr);
  s7_pointer x = fx_call(sc, cdr(expr));
  return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y)))));
}

#define fx_c_sa_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_2, fx_call(sc, cddr(expr))); \
    set_car(sc->t2_1, Lookup(sc, opt3_sym(expr), expr)); \
    return(fn_proc(expr)(sc, sc->t2_1)); \
  }

fx_c_sa_any(fx_c_sa, s_lookup)
fx_c_sa_any(fx_c_ta, t_lookup)
fx_c_sa_any(fx_c_ua, u_lookup)

static s7_pointer fx_vref_ran(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, s_lookup(sc, opt3_sym(expr), expr), fx_random_i_wrapped(sc, caddr(expr))));}
static s7_pointer fx_vref_ran_T(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, T_lookup(sc, opt3_sym(expr), expr), fx_random_i_wrapped(sc, caddr(expr))));}
static s7_pointer fx_vref_ran_U(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, U_lookup(sc, opt3_sym(expr), expr), fx_random_i_wrapped(sc, caddr(expr))));}

#define fx_c_sa_direct_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, Lookup(sc, opt3_sym(expr), expr), fx_call(sc, cddr(expr)))); \
  }

fx_c_sa_direct_any(fx_c_sa_direct, s_lookup)
fx_c_sa_direct_any(fx_c_ua_direct, u_lookup)

static s7_pointer fx_cons_ca(s7_scheme *sc, s7_pointer expr) {return(cons(sc, opt3_con(expr), fx_call(sc, cddr(expr))));}
static s7_pointer fx_cons_ac(s7_scheme *sc, s7_pointer expr) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(expr)), opt3_con(expr)));}
static s7_pointer fx_cons_sa(s7_scheme *sc, s7_pointer expr) {return(cons(sc, s_lookup(sc, opt3_sym(expr), expr), fx_call(sc, cddr(expr))));}
static s7_pointer fx_cons_as(s7_scheme *sc, s7_pointer expr) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(expr)), s_lookup(sc, opt3_sym(expr), expr)));}
static s7_pointer fx_cons_aa(s7_scheme *sc, s7_pointer expr) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(expr)), fx_call(sc, opt3_pair(expr))));}

#define fx_c_as_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    set_car(sc->t2_1, fx_call(sc, cdr(expr))); \
    set_car(sc->t2_2, Lookup(sc, opt3_sym(expr), expr)); \
    return(fn_proc(expr)(sc, sc->t2_1)); \
  }

fx_c_as_any(fx_c_as, s_lookup)
fx_c_as_any(fx_c_at, t_lookup)

static s7_pointer fx_c_as_direct(s7_scheme *sc, s7_pointer expr)
{
  return(((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, fx_call(sc, cdr(expr)), s_lookup(sc, opt3_sym(expr), expr)));
}

static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x1 = fx_call(sc, cdr(expr));
  s7_pointer x2 = s_lookup(sc, opt3_sym(expr), expr);
  if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) + real(x2)));
  return(add_p_pp(sc, x1, x2));
}

static s7_pointer fx_add_at(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x1 = fx_call(sc, cdr(expr));
  s7_pointer x2 = t_lookup(sc, opt3_sym(expr), expr);
  if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) + real(x2)));
  return(add_p_pp(sc, x1, x2));
}

static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x1 = s_lookup(sc, cadr(expr), expr);
  s7_pointer x2 = fx_call(sc, cddr(expr));
  if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2)));
  return(multiply_p_pp(sc, x1, x2));
}

static s7_pointer fx_multiply_sa_wrapped(s7_scheme *sc, s7_pointer expr) /* experiment */
{
  s7_pointer x1 = s_lookup(sc, cadr(expr), expr);
  s7_pointer x2 = fx_call(sc, cddr(expr));
  if ((is_t_real(x1)) && (is_t_real(x2))) return(wrap_real(sc, real(x1) * real(x2)));
  return(multiply_p_pp_wrapped(sc, x1, x2));
}

static s7_pointer fx_subtract_aa(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer x2;
  s7_pointer x1 = fx_call(sc, cdr(expr));
  sc->z = x1;
  x2 = fx_call(sc, opt3_pair(expr));
  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 expr)
{
  s7_pointer x2;
  const s7_pointer x1 = fx_call(sc, cdr(expr));
  sc->z = x1;
  x2 = fx_call(sc, opt3_pair(expr));
  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 expr)
{
  s7_pointer x2;
  const s7_pointer x1 = fx_call(sc, cdr(expr));
  sc->z = x1;
  x2 = fx_call(sc, opt3_pair(expr));
  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 expr) {return(add_p_pp(sc, s_lookup(sc, opt3_sym(expr), expr), fx_call(sc, cddr(expr))));}
static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer expr) {return(number_to_string_p_pp(sc, fx_call(sc, cdr(expr)), fx_call(sc, opt3_pair(expr))));}

static s7_pointer fx_c_3g(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_1, fx_call(sc, cdr(expr)));
  set_car(sc->t3_2, fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer result;
  /* check_stack_size(sc); */
  gc_protect_2_via_stack(sc, fx_call(sc, cdr(expr)), fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(expr))));
  set_car(sc->t3_2, gc_protected2(sc));
  set_car(sc->t3_1, gc_protected1(sc));
  result = fn_proc(expr)(sc, sc->t3_1);
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t3_2, fx_call(sc, opt3_pair(expr)));
  set_car(sc->t3_3, cadr(opt3_pair(expr)));
  set_car(sc->t3_1, g_lookup(sc, cadr(expr), expr));
  return(fn_proc(expr)(sc, sc->t3_1));
}

static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t2_1, fn_proc(cadr(expr))(sc, with_list_t1(sc, fx_call(sc, cdadr(expr)))));
  set_car(sc->t2_2, lookup_checked(sc, caddr(expr)));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer expr) /* (vector-ref v (random i)) */
{
  set_car(sc->t2_2, fn_proc(caddr(expr))(sc, with_list_t1(sc, fx_call(sc, opt3_pair(expr))))); /* cdaddr(expr) */
  set_car(sc->t2_1, lookup_checked(sc, cadr(expr)));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer arg1 = cadr(expr);
  set_car(sc->t1_1, fx_call(sc, cdr(arg1)));
  return(fn_proc(expr)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t1_1))));
}

static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  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(expr)(sc, with_list_t1(sc, result));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer arg1 = cadr(expr);
  set_car(sc->t2_2, fx_call(sc, cddr(arg1)));
  set_car(sc->t2_1, s_lookup(sc, cadr(arg1), expr));
  return(fn_proc(expr)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t2_1))));
}

static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg1 = cadr(expr);
  gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg1)), fx_call(sc, opt3_pair(arg1))); /* cddr(expr) */
  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(expr)(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 expr)
{
  const s7_pointer arg2 = caddr(expr);
  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, s_lookup(sc, cadr(expr), expr));
  {
    s7_pointer result = fn_proc(expr)(sc, sc->t2_1);
    unstack_gc_protect(sc);
    return(result);
  }
}

static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer code = cdr(expr), result;
  check_stack_size(sc); /* t718 pp cycles #f */
  gc_protect_2_via_stack(sc, fx_call(sc, code), fx_call(sc, cdr(code)));
  code = cddr(code);
  set_gc_protected3(sc, fx_call(sc, code));  /* cddr! */
  set_car(sc->t4_4, fx_call(sc, cdr(code))); /* cdddr */
  set_car(sc->t4_3, gc_protected3(sc));
  set_car(sc->t4_2, gc_protected2(sc));
  set_car(sc->t4_1, gc_protected1(sc));
  /* here sc->t4 may have changed after the fn_proc call if fn_proc calls other (arbitrary) stuff as in snd-test 13: (convolve-with "1a.snd" 0.5 ind 0) */
  result = fn_proc(expr)(sc, sc->t4_1);
  unstack_gc_protect(sc);
  /* set_car(sc->t4_1, sc->unused); */
  return(result);
}

static s7_pointer fx_c_4g(s7_scheme *sc, s7_pointer expr)
{ /* all opts in use for expr, opt1 free cdr(expr), expr opt3 is line_number, cdr(expr) opt3 is arglen?? */
  const s7_pointer code = cdr(expr);
  s7_pointer result;
  set_car(sc->t4_1, fx_call(sc, code));
  set_car(sc->t4_2, fx_call(sc, cdr(code)));
  set_car(sc->t4_3, fx_call(sc, opt3_pair(expr)));      /* cddr(res) */
  set_car(sc->t4_4, fx_call(sc, cdr(opt3_pair(expr)))); /* cdddr(res) */
  result = fn_proc(expr)(sc, sc->t4_1);
  /* set_car(sc->t4_1, sc->unused); */
  return(result);
}

static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg2 = caddr(expr);
  set_car(sc->t2_1, s_lookup(sc, cadr(arg2), expr));
  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(expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer arg2 = caddr(expr);
  set_car(sc->t2_2, s_lookup(sc, caddr(arg2), expr));
  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, s_lookup(sc, cadr(expr), expr));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer code = opt1_pair(cdr(expr));
  set_car(sc->t2_1, s_lookup(sc, cadr(code), code));
  set_car(sc->t2_2, s_lookup(sc, opt1_sym(cdr(code)), code));
  set_car(sc->t2_1, fn_proc(cadr(expr))(sc, with_list_t1(sc, fn_proc(code)(sc, sc->t2_1))));
  set_car(sc->t2_2, s_lookup(sc, caddr(expr), code));
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer code = opt1_pair(cdr(expr));
  return(((s7_p_pp_t)opt3_direct(expr))(sc,
            ((s7_p_p_t)opt2_direct(cdr(expr)))(sc,
               ((s7_p_pp_t)opt3_direct(cdr(expr)))(sc, s_lookup(sc, cadr(code), code), s_lookup(sc, caddr(code), code))),
	    s_lookup(sc, caddr(expr), code)));
}

static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer result;
  const s7_pointer lst = safe_list_if_possible(sc, opt3_arglen(cdr(expr)));
  if (in_heap(lst)) gc_protect_via_stack(sc, lst);
  for (s7_pointer args = cdr(expr), p = lst; is_pair(args); args = cdr(args), p = cdr(p))
    set_car(p, s_lookup(sc, car(args), expr));
  result = fn_proc(expr)(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 expr)
{
  s7_pointer lst = make_list(sc, opt3_arglen(cdr(expr)), sc->unused);
  for (s7_pointer args = cdr(expr), p = lst; is_pair(args); args = cdr(args), p = cdr(p))
    set_car(p, s_lookup(sc, car(args), expr));
  return(lst);
}

static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer result;
  const s7_pointer lst = safe_list_if_possible(sc, opt3_arglen(cdr(expr)));
  if (in_heap(lst)) gc_protect_via_stack(sc, lst);
  for (s7_pointer args = cdr(expr), p = lst; is_pair(args); args = cdr(args), p = cddr(p))
    {
      set_car(p, opt2_con(args));
      args = cdr(args);
      set_cadr(p, fx_call(sc, args));
    }
  result = fn_proc(expr)(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 expr)
{
  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.
   */
  for (s7_pointer lst = cdr(expr); 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_slot_checked(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 expr)
{
  s7_pointer args, p;
  const s7_pointer val = safe_list_if_possible(sc, opt3_arglen(cdr(expr)));
  if (in_heap(val)) gc_protect_via_stack(sc, val);
  for (args = cdr(expr), p = val; is_pair(args); args = cdr(args), p = cdr(p))
    set_car(p, fx_call(sc, args));
  p = fn_proc(expr)(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 expr)
{
  s7_pointer args = cdr(expr);
  const s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(expr)));
  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 expr)
{
  s7_pointer args = cdr(expr);
  const s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(expr))); /* was s7_make_vector */
  s7_pointer *els = vector_elements(vec);
  gc_protect_via_stack(sc, vec);
  t_vector_fill(vec, sc->unused); /* 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->z = 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 expr)
{
  return((is_true(sc, fx_call(sc, cdr(expr)))) ? fx_call(sc, opt1_pair(expr)) : sc->unspecified);
}

static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer expr)
{
  return((is_false(sc, fx_call(sc, opt1_pair(expr)))) ? fx_call(sc, opt2_pair(expr)) : sc->unspecified);
}

static s7_pointer fx_if_a_a_a(s7_scheme *sc, s7_pointer expr)
{
  return((is_true(sc, fx_call(sc, cdr(expr)))) ? fx_call(sc, opt1_pair(expr)) : fx_call(sc, opt2_pair(expr)));
}

#define fx_if_s_a_a_any(Name, Lookup) \
  static s7_pointer Name(s7_scheme *sc, s7_pointer expr) \
  { \
    return((Lookup(sc, cadr(expr), expr) != sc->F) ? fx_call(sc, opt1_pair(expr)) : fx_call(sc, opt2_pair(expr))); \
  }

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 expr)
{
  return(((fx_call(sc, opt1_pair(expr)) == sc->F) || (fx_call(sc, opt2_pair(expr)) == sc->F)) ? fx_call(sc, cdddr(expr)) : lookup(sc, opt3_sym(expr)));
}

static s7_pointer fx_if_not_a_a_a(s7_scheme *sc, s7_pointer expr)
{
  return((is_false(sc, fx_call(sc, opt1_pair(expr)))) ? fx_call(sc, opt2_pair(expr)) : fx_call(sc, opt3_pair(expr)));
}

static s7_pointer fx_if_a_c_c(s7_scheme *sc, s7_pointer expr) {return((is_true(sc, fx_call(sc, cdr(expr)))) ? opt1_con(expr) : opt2_con(expr));}

static s7_pointer fx_if_is_type_s_a_a(s7_scheme *sc, s7_pointer expr)
{
  if (gen_type_match(sc, s_lookup(sc, opt2_sym(cdr(expr)), expr), opt3_byte(cdr(expr))))
    return(fx_call(sc, cddr(expr)));
  return(fx_call(sc, opt2_pair(expr))); /* cdddr(expr) */
}

static inline s7_pointer fx_and_2a(s7_scheme *sc, s7_pointer expr)   /* expr is the full expr: (and ...) */
{
  return((fx_call(sc, cdr(expr)) == sc->F) ? sc->F : fx_call(sc, cddr(expr)));
}

static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t1_1, s_lookup(sc, opt3_sym(cdr(expr)), expr));  /* cadadr(expr) */
  return((fn_proc(cadr(expr))(sc, sc->t1_1) == sc->F) ? sc->F : fn_proc(caddr(expr))(sc, sc->t1_1));
}

static s7_pointer fx_len2_t(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = t_lookup(sc, opt1_sym(cdr(expr)), expr); /* isn't this unprotected from mock pair? */ /* opt1_sym == cadadr(expr) */
  return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val)))));
}

static s7_pointer fx_len3_t(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = t_lookup(sc, opt1_sym(cdr(expr)), expr);
  return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val)))));
}

static s7_pointer fx_and_3a(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = cdr(expr);
  if (fx_call(sc, p) == sc->F) return(sc->F);
  p = cdr(p);
  return((fx_call(sc, p) == sc->F) ? sc->F : fx_call(sc, cdr(p)));
}

static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = sc->T;
  for (s7_pointer p = cdr(expr); (is_pair(p)) && (val != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */
    val = fx_call(sc, p);
  return(val);
}

static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = cdr(expr);
  s7_pointer val = fx_call(sc, p);
  return((val != sc->F) ? val : fx_call(sc, cdr(p)));
}

static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer expr)
{
  /* the "s" is looked up once here -- not obvious how to use fx_call anyway */
  s7_pointer val = fn_proc(cadr(expr))(sc, with_list_t1(sc, s_lookup(sc, opt3_sym(cdr(expr)), expr))); /* cadadr(expr) */
  return((val != sc->F) ? val : fn_proc(caddr(expr))(sc, sc->t1_1));
}

static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer expr)
{
  int32_t val = type(lookup(sc, opt3_sym(cdr(expr)))); /* cadadr(expr)) */
  return(make_boolean(sc, (val == opt3_int(expr)) || (val == opt2_int(cdr(expr)))));
}

static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val = lookup(sc, opt3_sym(expr));
  return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val))));
}

static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = cdr(expr);
  s7_pointer val = fx_call(sc, p);
  if (val != sc->F) return(val);
  p = opt3_pair(expr); /* 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 expr)
{
  s7_pointer p = cdr(expr);
  s7_pointer val = fx_call(sc, p);
  if (val != sc->F) return(val);
  p = opt3_pair(expr); /* 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 expr)
{
  s7_pointer p = cdr(expr);
  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 expr)
{
  s7_pointer val = sc->F;
  for (s7_pointer p = cdr(expr); (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 expr)
{
  fx_call(sc, cdr(expr));
  return(fx_call(sc, cddr(expr)));
}

static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p;
  for (p = cdr(expr); 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 expr)
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);  /* 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_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer expr) /* also called from h_safe_closure_s_a in eval */
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), s_lookup(sc, opt2_sym(expr), expr)));
  result = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_s_direct(s7_scheme *sc, s7_pointer expr) {return(lookup(sc, opt2_sym(expr)));}

static s7_pointer op_safe_closure_s_a(s7_scheme *sc, s7_pointer expr) /* also called from h_safe_closure_s_a in eval */
{
  const s7_pointer func = opt1_lambda(expr);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), s_lookup(sc, opt2_sym(expr), expr)));
  return(fx_call(sc, closure_body(func)));
}

static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), t_lookup(sc, opt2_sym(expr), expr)));
  result = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer expr)
{
  return(fn_proc(car(closure_body(opt1_lambda(expr))))(sc, with_list_t1(sc, s_lookup(sc, opt2_sym(expr), expr))));
}

static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer expr)
{
  set_car(sc->t2_2, opt3_con(cdr(expr)));
  set_car(sc->t2_1, s_lookup(sc, opt2_sym(expr), expr));
  return(fn_proc(car(closure_body(opt1_lambda(expr))))(sc, sc->t2_1));
}

static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer expr) {return(vector_ref_p_pp(sc, s_lookup(sc, opt2_sym(expr), expr), opt3_con(cdr(expr))));}
static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer p = s_lookup(sc, opt2_sym(expr), expr);
  if ((!With_Gmp) && (is_t_integer(p))) return(make_integer(sc, integer(p) - 1));
  return(minus_c1(sc, p));
}

static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer p = s_lookup(sc, opt2_sym(expr), expr);
  if ((!With_Gmp) && (is_t_integer(p))) return(make_integer(sc, integer(p) + 1));
      /* better but slower: return(add_if_overflow_to_real_or_big_integer(sc, integer(p), 1)) */
  return(g_add_x1_1(sc, p, 1));
}

static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer p = cdr(expr);
  const s7_pointer val = fx_proc(cdar(p))(sc, car(p));
  sc->z = val;
  set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p)));
  set_car(sc->t2_1, val);
  return(fn_proc(expr)(sc, sc->t2_1));
}

static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  set_car(sc->t2_1, fx_call(sc, cdr(expr)));
  set_car(sc->t2_2, opt3_con(cdr(expr)));
  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 expr) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(expr)), opt3_con(cdr(expr))));}

static s7_pointer fx_safe_closure_s_and_2a(s7_scheme *sc, s7_pointer expr) /* safe_closure_s_a where "a" is fx_and_2a */
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), s_lookup(sc, opt2_sym(expr), expr)));
  expr = cdar(closure_body(func));
  result = fx_call(sc, expr);  /* have to unwind the stack so this can't return */
  if (result != sc->F)
    result = fx_call(sc, cdr(expr));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_s_and_pair(s7_scheme *sc, s7_pointer expr) /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), s_lookup(sc, opt2_sym(expr), expr)));
  expr = cdar(closure_body(func));
  result = (is_pair(t_lookup(sc, cadar(expr), expr))) ? fx_call(sc, cdr(expr)) : sc->F;  /* pair? arg = func par, pair? is global, symbol_id=0 */
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(expr))));
  result = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(expr))));
  return(fx_call(sc, closure_body(func)));
}

static s7_pointer fx_safe_closure_a_sqr(s7_scheme *sc, s7_pointer expr) {return(fx_sqr_1(sc, fx_call(sc, cdr(expr))));}
static s7_pointer fx_safe_closure_s_sqr(s7_scheme *sc, s7_pointer expr) {return(fx_sqr_1(sc, lookup(sc, opt2_sym(expr))));}

static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  const s7_pointer and_arg = cdar(closure_body(func));
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(expr))));
  result = fx_call(sc, and_arg);
  if (result != sc->F) result = fx_call(sc, cdr(and_arg));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt2_sym(expr), expr)));
  result = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt2_sym(expr), expr)));
  return(fx_call(sc, closure_body(func)));
}

static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  s7_pointer result;
  gc_protect_curlet_via_stack(sc);
  set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt2_sym(expr), expr), s_lookup(sc, opt3_sym(expr), expr)));
  result = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(result);
}

static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer expr)
{
  const s7_pointer func = opt1_lambda(expr);
  set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), s_lookup(sc, cadr(expr), expr), s_lookup(sc, opt2_sym(expr), expr), s_lookup(sc, opt3_sym(expr), expr)));
  return(fx_call(sc, closure_body(func)));
}

static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p = cdr(expr);
  const s7_pointer func = opt1_lambda(expr);
  check_stack_size(sc); /* lint+s7test.scm can overflow here */
  gc_protect_via_stack(sc, 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_protected1(sc)));
  p = fx_call(sc, closure_body(func));
  set_curlet(sc, gc_protected_let_via_stack(sc));
  unstack_gc_protect(sc);
  return(p);
}

static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer expr)  /* all tests are fxable, results are all fx, no =>, no missing results */
{
  for (s7_pointer p = cdr(expr); 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 expr) {return(starlet(sc, opt3_int(expr)));}
static s7_pointer fx_implicit_starlet_print_length(s7_scheme *sc, s7_pointer unused_expr) {return(make_integer(sc, sc->print_length));}
static s7_pointer fx_implicit_starlet_safety(s7_scheme *sc, s7_pointer unused_expr) {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);
  /* if (!is_proper_quote(sc, expr)) fprintf(stderr, "%d: nope: %s %s\n", __LINE__, display(expr), op_names[optimize_op(expr)]); */
  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 void fixup_add_wrapper(s7_scheme *sc, s7_pointer arg) /* hardly called */
{
  if (opt3_direct(arg) == (s7_pointer)add_p_pp)
    set_opt3_direct(arg, add_p_pp_wrapped);
  else
    if (opt3_direct(arg) == (s7_pointer)subtract_p_pp)
      set_opt3_direct(arg, subtract_p_pp_wrapped);
    else
      if (opt3_direct(arg) == (s7_pointer)multiply_p_pp)
	set_opt3_direct(arg, multiply_p_pp_wrapped);
}

typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer var_list);

#if s7_Debugging
#define fx_choose(Sc, Holder, Var_List, Checker) fx_choose_1(Sc, Holder, Var_List, Checker, __func__, __LINE__)
static s7_function fx_choose_1(s7_scheme *sc, const s7_pointer holder, const s7_pointer var_list, safe_sym_t *checker, const char *func, int line)
#else
static s7_function fx_choose(s7_scheme *sc, const s7_pointer holder, const s7_pointer var_list, safe_sym_t *checker)
#endif
{
  const s7_pointer expr = car(holder);
  /* fprintf(stderr, "%s[%d] from %s[%d]: %s\n", __func__, __LINE__, func, line, display(expr)); */

#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(expr))
    {
      if (is_symbol(expr))
	{
	  if (is_keyword(expr)) return(fx_c);
	  if ((expr == sc->else_symbol) && (is_global(sc->else_symbol)))
	    {
	      if (is_let(var_list)) {if (s7_symbol_local_value(sc, expr, var_list) == sc->else_symbol) return(fx_c);}
	      else if ((is_pair(var_list)) && (!direct_memq(expr, var_list))) return(fx_c); /* is_pair -> not () */
	    }
	  return((is_defined_global(expr)) ? fx_g : ((checker(sc, expr, var_list)) ? fx_s : fx_unsafe_s));
	}
      return(fx_c);
    }
  /* fprintf(stderr, "%s from %s[%d]: %s %d\n", __func__, func, line, display(expr), is_optimized(expr)); */
  if (is_optimized(expr))
    {
      const s7_pointer head = car(expr);
      switch (optimize_op(expr))
	{
	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(expr) == sc->nil) return((fn_proc(expr) == g_read_char) ? fx_read_char_0 : ((fn_proc(expr) == g_curlet) ? fx_curlet : fx_c_0c));
#if !With_Gmp
	  if (fn_proc(expr) == g_add_i_random) return(fx_add_i_random);
#endif
	  if (fn_proc(expr) == g_cons)
	    {
	      set_opt1_con(cdr(expr), caddr(expr));
	      return(fx_cons_cc);
	    }
	  return((fn_proc(expr) == g_random_i) ? fx_random_i : fx_c_nc);

	case OP_OR_2A:
	  {
	    const s7_pointer arg2p = cddr(expr);
	    if (fx_proc(arg2p) == fx_and_2a) {set_opt3_pair(expr, cdar(arg2p)); return(fx_or_and_2a);}
	    if (fx_proc(arg2p) == fx_and_3a) {set_opt3_pair(expr, 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(expr)) == cadar(arg2p)))
	      {
		/* (or (not (symbol? body)) (keyword? body)) */
		set_opt3_sym(expr, 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 */
	    {
	      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... */
	      {
		const uint8_t typ = symbol_type(head);
		if (typ > T_FREE)
		  {
		    set_opt3_byte(cdr(expr), 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))))
		{
		  const s7_p_p_t func = s7_p_p_function(global_value(head));
		  if (func)
		    {
		      set_opt2_direct(cdr(expr), 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(expr))) ? fx_c_g_direct : fx_c_s_direct);
		    }}}
	  return((is_defined_global(cadr(expr))) ? fx_c_g : fx_c_s);

	case HOP_SAFE_C_SS:
	  {
	    const s7_function func = fn_proc(expr);
	    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(expr))) ? fx_lt_sg : fx_lt_ss);
	    if ((fx_matches(head, sc->multiply_symbol)) && (cadr(expr) == caddr(expr))) 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(expr), 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(expr) == g_list) return(fx_list_ns);    /* it is no faster here to divide out the big list cases!? */
	  return((fn_proc(expr) == 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(expr), s7_p_p_function)))
	    {
	      set_opt2_direct(cdr(expr), s7_p_pp_function(global_value(head)));
	      set_opt3_direct(cdr(expr), s7_p_p_function(global_value(caadr(expr))));
	      return(((head == sc->cons_symbol) && (caadr(expr) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct);
	    }
	  return(fx_c_opsq_s);

	case HOP_SAFE_C_SSS:
	  if ((fn_proc(expr) == g_less) && (is_defined_global(cadr(expr))) && (is_defined_global(cadddr(expr)))) return(fx_lt_gsg);
	  if (is_global_and_has_func(head, s7_p_ppp_function))
	    {
	      set_opt3_direct(cdr(expr), s7_p_ppp_function(global_value(head)));
	      return(fx_c_sss_direct);
	    }
	  return(fx_c_sss);

	case HOP_SAFE_C_SSA:
	  if (is_global_and_has_func(head, s7_p_ppp_function))
	    {
	      set_opt2_direct(cdr(expr), s7_p_ppp_function(global_value(head)));
	      return(fx_c_ssa_direct);
	    }
	  return(fx_c_ssa);

	case HOP_SAFE_C_SCS:
	  if (is_global_and_has_func(head, s7_p_ppp_function))
	    {
	      set_opt3_direct(cdr(expr), s7_p_ppp_function(global_value(head)));
	      return(fx_c_scs_direct);
	    }
	  return(fx_c_scs);

	case HOP_SAFE_C_SAS:
	  if ((!With_Gmp) && (fx_proc(cddr(expr)) == fx_random_i)) set_fx_direct(cddr(expr), fx_random_i_wrapped); /* g_vector_set_3 tgc */
	  return(fx_c_sas);

	case HOP_SAFE_C_AAA:
	  if ((fx_proc(cdr(expr)) == fx_g) && (fx_proc(cdddr(expr)) == fx_c)) return(fx_c_gac);
	  if ((is_unquoted_pair(sc, cadr(expr))) || (is_unquoted_pair(sc, caddr(expr))) || (is_unquoted_pair(sc, cadddr(expr)))) return(fx_c_aaa);
	  return(fx_c_3g);

	case HOP_SAFE_C_4A:
	  set_opt3_pair(expr, cdddr(expr));
	  for (s7_pointer p = cdr(expr); 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(expr);
	    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(expr);
		set_opt2_direct(arg1p, s7_p_pp_function(global_value(head)));
		set_opt3_direct(arg1p, s7_p_pp_function(global_value(car(s2))));
		fixup_add_wrapper(sc, arg1p);
		set_opt3_pair(expr, 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(expr))) && (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(expr), s7_p_pp_function)))
	    {
	      /* op_c_opgsq_t */
	      const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr);
	      set_opt2_direct(arg1p, s7_p_pp_function(global_value(head)));
	      set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p))));
	      fixup_add_wrapper(sc, arg1p);
	      set_opt3_pair(expr, 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) */
	      if ((head == sc->gt_symbol) && (car(arg1) == sc->add_symbol)) return(fx_gt_add_s);
	      if ((head == sc->add_symbol) && (car(arg1) == sc->multiply_symbol)) return(fx_add_mul_opssq_s);
	      return(fx_c_opssq_s_direct);
	    }
	  return(fx_c_opssq_s);

	case HOP_SAFE_C_opSSq_opSSq:
	  {
	    const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
	    set_opt3_pair(expr, cdr(arg2));
	    if ((fx_matches(car(arg1), sc->multiply_symbol)) && (car(arg2) == sc->multiply_symbol))
	      {
		set_opt1_pair(cdr(expr), 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(expr), 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(expr, cadr(cdaddr(expr)));
		return(fx_sub_vref2);
	      }
	    return(fx_c_opssq_opssq);
	  }

	case HOP_SAFE_C_opSq:
	  if (is_unchanged_global(caadr(expr)))
	    {
	      const s7_pointer arg_sym = cadadr(expr), arg_head = caadr(expr);
	      if (fx_matches(head, sc->is_pair_symbol))
		{
		  if (arg_head == sc->car_symbol)  {set_opt3_sym(expr, 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(expr, arg_sym); return(fx_is_pair_cdr_s);}
		  if (arg_head == sc->cadr_symbol) {set_opt3_sym(expr, arg_sym); return(fx_is_pair_cadr_s);}
		  if (arg_head == sc->cddr_symbol) {set_opt3_sym(expr, 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(expr, arg_sym); return(fx_is_null_cdr_s);}
		  if (arg_head == sc->cadr_symbol) {set_opt3_sym(expr, arg_sym); return(fx_is_null_cadr_s);}
		  if (arg_head == sc->cddr_symbol) {set_opt3_sym(expr, arg_sym); return(fx_is_null_cddr_s);}
		}
	      if ((fx_matches(head, sc->is_symbol_symbol)) &&
		  (caadr(expr) == sc->cadr_symbol))
		{set_opt3_sym(expr, 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(expr, arg_sym); return(fx_not_is_pair_s);}
		  if (arg_head == sc->is_null_symbol)   {set_opt3_sym(expr, arg_sym); return(fx_not_is_null_s);}
		  if (arg_head == sc->is_symbol_symbol) {set_opt3_sym(expr, 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(expr, 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 > T_FREE)              /* h_safe_c here so the type checker isn't shadowed */
		{
		  set_opt3_sym(expr, cadadr(expr));
		  set_opt3_byte(cdr(expr), typ);
		  if (fn_proc(cadr(expr)) == (s7_function)g_c_pointer_weak1)
		    return(fx_eq_weak1_type_s);
		  return(fx_matches(caadr(expr), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq);
		}}
	  /* this should follow the is_type* check above */
	  if (fx_matches(caadr(expr), sc->car_symbol))
	    {
	      set_opt3_sym(expr, cadadr(expr));
	      return(fx_c_car_s);
	    }
	  if (fx_matches(caadr(expr), sc->cdr_symbol))
	    {
	      set_opt3_sym(expr, cadadr(expr));
	      return(fx_c_cdr_s);
	    }
	  return(fx_c_opsq);

	case HOP_SAFE_C_SC:
	  if (is_unchanged_global(head))
	    {
	      const s7_pointer arg2 = caddr(expr);
	      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(expr) == g_memq_2) && (is_pair(arg2))) return(fx_memq_sq_2);
	      if ((fn_proc(expr) == 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(expr), 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(expr) != 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(expr), 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(expr), arg2 = caddr(expr);
	      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(expr, 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); /* f = float here, not wrapped snd-test 22 grani */
		  if (is_t_integer(arg1)) return(fx_multiply_is);
		}}
	  return(fx_c_cs);

	case HOP_SAFE_C_S_opSq:
	  {
	    const s7_pointer arg1p = cdr(expr), arg2 = caddr(expr);
	    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(expr), 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)))); /* expr opt3 only location, but no change in callgrind */
		if (opt3_direct(arg1p) == (s7_pointer)random_p_p) set_opt3_direct(cdr(expr), 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(expr);
	      if (is_global_and_has_func(car(arg2), s7_p_p_function))
		{
		  set_opt2_direct(cdr(expr), s7_p_pp_function(global_value(head)));
		  set_opt3_direct(cdr(expr), s7_p_p_function(global_value(car(arg2))));
		  set_opt1_sym(cdr(expr), 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(expr), arg1 = cadr(expr), arg2 = caddr(expr);
	      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(expr, arg2);
		  return((head == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i);
		}}
	  set_opt1_sym(cdr(expr), cadadr(expr));
	  return(fx_c_opsq_c);

	case HOP_SAFE_C_op_opSqq:
	  return((fx_matches(head, sc->not_symbol)) ? ((fn_proc(cadr(expr)) == 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(expr)) == g_is_eq)
		{
		  const s7_pointer arg1 = cadr(expr);
		  set_opt3_sym(expr, cadr(arg1));
		  set_opt3_con(cdr(expr), (is_pair(caddr(arg1))) ? cadaddr(arg1) : caddr(arg1));
		  return(fx_not_is_eq_sq);
		}
	      return(fx_not_opscq);
	    }
	  return(fx_c_opscq);

	case HOP_SAFE_C_S_opSCq:
	  if (is_global_and_has_func(head, s7_p_pp_function))
	    {
	      const s7_pointer arg1p = cdr(expr), arg2 = caddr(expr);
	      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(expr, 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(expr, cadr(arg2));
		  fixup_add_wrapper(sc, arg1p);
		  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(expr)) == 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(expr), s7_p_pp_function)))
	    {
	      const s7_pointer arg1p = cdr(expr);
	      set_opt2_direct(arg1p, s7_p_p_function(global_value(head)));
	      set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p))));
	      fixup_add_wrapper(sc, arg1p);
	      return(fx_c_opssq_direct);
	    }
	  return(fx_c_opssq);

	case HOP_SAFE_C_C_opSSq:
	  {
	    const s7_pointer arg1p = cdr(expr), s2 = caddr(expr);
	    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(expr, cadr(s2));
		set_opt1_sym(arg1p, caddr(s2));
		fixup_add_wrapper(sc, arg1p);
		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(expr))));
		fixup_add_wrapper(sc, arg1p);
		set_opt3_sym(expr, cadr(s2));
		set_opt1_sym(arg1p, caddr(s2));
		fixup_add_wrapper(sc, arg1p);
		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(expr), arg1 = cadr(expr), arg2 = caddr(expr);
	    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(expr, 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(expr), arg1 = cadr(expr);
	    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(expr, 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))));
		fixup_add_wrapper(sc, arg1p);
		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(expr)) == fx_is_eq_car_sq)
		{
		  set_opt1_sym(cdr(expr), cadadr(cadr(expr)));
		  set_opt3_con(cdr(expr), cadaddr(cadr(expr)));
		  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(expr, s7_p_p_function(global_value(head)));
	      if ((head == sc->sqrt_symbol) && (fx_proc(cdr(expr)) == fx_add_sqr_sqr))
		{
		  set_opt1_sym(cdr(expr), cadr(cadr(cadr(expr))));  /* opt1_cfunc(expr) is set */
		  set_opt3_sym(cdr(expr), cadr(caddr(cadr(expr)))); /* opt3(expr) is sqrt_p_p but used to be clobbered anyway */
		  return(fx_hypot);
		}
	      return(fx_c_a_direct);
	    }
	  return(fx_c_a);

	case HOP_SAFE_C_AC:
	  if (fn_proc(expr) == 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(expr);
	      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(expr))) && (integer(caddr(expr)) == 0))
		set_opt3_direct(arg1p, string_ref_p_p0);
	      if (opt3_direct(arg1p) == (s7_pointer)memq_p_pp)
		{
		  if (fn_proc(expr) == g_memq_2)
		    set_opt3_direct(arg1p, memq_2_p_pp);
		  else
		    if ((is_pair(caddr(expr))) && (is_proper_list_3(sc, cadaddr(expr))))
		      set_opt3_direct(arg1p, memq_3_p_pp);
		    else
		      if (fn_proc(expr) == 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(expr))) && (opt3_direct(arg1p) == (s7_pointer)lt_p_pp))
		  return(fx_lt_ad);
	      if ((is_t_integer(opt3_con(expr))) && (s7_p_pi_function(global_value(head))))
		{
		  set_opt3_direct(arg1p, s7_p_pi_function(global_value(head)));
		  if (integer(opt3_con(expr)) == 1)
		    {
		      if (opt3_direct(arg1p) == (s7_pointer)g_sub_xi)
			return(fx_sub_a1);
		      if (opt3_direct(arg1p) == (s7_pointer)add_p_pi)
			return(fx_add_a1);
		    }
		  return(fx_c_ai_direct);
		}
	      return(fx_c_ac_direct);
	    }
	  return(fx_c_ac);

	case HOP_SAFE_C_CA:
	  if ((!With_Gmp) && (fx_proc(cddr(expr)) == fx_random_i)) set_fx_direct(cddr(expr), fx_random_i_wrapped);
	  return((fn_proc(expr) == g_cons) ? fx_cons_ca : fx_c_ca);

	case HOP_SAFE_C_SA:
	  if ((!With_Gmp) && (fx_proc(cddr(expr)) == fx_random_i)) set_fx_direct(cddr(expr), fx_random_i_wrapped);
	  if (fn_proc(expr) == g_multiply_2) return(fx_multiply_sa);
	  if (fn_proc(expr) == g_add_2) return(fx_add_sa);
	  if (is_global_and_has_func(head, s7_p_pp_function))
	    {
	      set_opt3_direct(cdr(expr), s7_p_pp_function(global_value(head)));
	      if (((s7_p_pp_t)opt3_direct(cdr(expr)) == vector_ref_p_pp) && (fx_proc(cddr(expr)) == fx_random_i_wrapped)) return(fx_vref_ran);
	      return((fn_proc(expr) == g_cons) ? fx_cons_sa : fx_c_sa_direct);
	    }
	  return(fx_c_sa);

	case HOP_SAFE_C_AS:
	  if (fn_proc(expr) == g_add_2) return(fx_add_as);
	  if (is_global_and_has_func(head, s7_p_pp_function))
	    {
	      set_opt3_direct(cdr(expr), s7_p_pp_function(global_value(head)));
	      return((fn_proc(expr) == 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(expr) == g_add_2)            return(fx_add_aa);
	  if (fn_proc(expr) == g_subtract_2)       return(fx_subtract_aa);
	  if (fn_proc(expr) == g_multiply_2)       return(fx_multiply_aa);
	  if (fn_proc(expr) == g_number_to_string) return(fx_number_to_string_aa);
	  if (fn_proc(expr) == g_cons)             return(fx_cons_aa);
	  return(fx_c_aa);

	case HOP_SAFE_C_opAAq:
	  return((fx_proc(cdadr(expr)) == fx_s) ? fx_c_opsaq : fx_c_opaaq);

	case HOP_SAFE_C_NA:
	  return((fn_proc(expr) == g_vector) ? fx_vector_na : fx_c_na);

	case HOP_SAFE_C_ALL_CA:
	  return((fn_proc(expr) == g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca);

	case HOP_SAFE_CLOSURE_S_A:
	  {
	    const s7_pointer pbody = closure_body(opt1_lambda(expr));
	    const s7_pointer body = car(pbody);
	    const s7_pointer par = car(closure_pars(opt1_lambda(expr)));
	    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 expr: (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))                  /* many cases in lint.scm */
		      {
			set_opt2_sym(cdr(expr), cadaddr(body));
			return(fx_cdr_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */
		      }}}
	    if ((fx_proc(pbody) == fx_t) && (body == par)) return(fx_safe_closure_s_direct);
	    return((fx_proc(pbody) == 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(expr)));
	    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(expr)))) == 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(expr))) == fx_and_2a)
	    return(fx_safe_closure_a_and_2a);
	  return((fx_proc(closure_body(opt1_lambda(expr))) == 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(expr))) == fx_vref_vref_tu_v) return(fx_vref_vref_3_no_let);
	  return(fx_function[optimize_op(expr)]);

	case OP_IMPLICIT_STARLET_REF_S:
	  if (opt3_int(expr) == sl_Print_Length) return(fx_implicit_starlet_print_length);
	  if (opt3_int(expr) == 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(expr)]) && (is_h_optimized(expr))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(expr)], display(expr)); */
	  /* 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(expr)]);
	}} /* is_optimized */

  if (is_safe_quote(sc, car(expr)))
    {
      check_quote(sc, expr);
      return(fx_q);
    }
  return(NULL);
}

#if s7_Debugging
#define with_fx(P, F) with_fx_1(sc, P, F)
static bool with_fx_1(s7_scheme *sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */
#else
static bool with_fx(s7_pointer p, s7_function f)
#endif
{
  set_fx_direct(p, f);
  return(true);
}

static bool o_var_ok(const s7_pointer p, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));}

static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3, bool unused_more_vars)
{
  const s7_pointer p = car(tree);
  const s7_function pfunc = fx_proc(tree);
  if (is_symbol(p))
    {
      if ((pfunc == fx_s) || (pfunc == fx_o))
	{
	  if (p == var1) return(with_fx(tree, fx_T));
	  if (p == var2) return(with_fx(tree, fx_U));
	  if (p == var3) return(with_fx(tree, fx_V));
	}
      return(false);
    }
#if 0
  fprintf(stderr, "  %s[%d]: %s, vars: %s %s %s %d\n", __func__, __LINE__, display(tree),
	  (var1) ? display(var1) : "", (var2) ? display(var2) : "", (var3) ? display(var3) : "", unused_more_vars);
#endif
  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));
	  if (pfunc == fx_vref_ran) return(with_fx(tree, fx_vref_ran_T));
	}
      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));
	    if (pfunc == fx_vref_ran) return(with_fx(tree, fx_vref_ran_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));
		    if (pfunc == fx_c_css) return(with_fx(tree, fx_c_cTs));
		  }
		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));
		      if ((pfunc == fx_cons_car_s_s) && (cadr(arg1) == var1) && (caddr(p) == var3)) return(with_fx(tree, fx_cons_car_T_V));
		    }}}
  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_pointer arg1;
  s7_function pfunc;
#if 0
  fprintf(stderr, "  %s[%d]: %s, vars: %s %s %s %d\n", __func__, __LINE__, display(tree),
	  (var1) ? display(var1) : "", (var2) ? display(var2) : "", (var3) ? display(var3) : "", more_vars);
#endif
  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 0
  fprintf(stderr, "  %s: fx_treed: %d, has_fx: %d\n", op_names[optimize_op(p)], is_fx_treed(tree), has_fx(tree));
#endif
  if ((!is_pair(p)) || (is_fx_treed(tree)) || (!has_fx(tree))) return(false);
  set_fx_treed(tree);
  pfunc = fx_proc(tree);
  arg1 = (is_pair(cdr(p))) ? cadr(p) : sc->nil;
  switch (optimize_op(p))
    {
    case HOP_SAFE_C_S:
      if (arg1 == 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 (arg1 == 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 (arg1 == 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, (opt2_direct(cdr(p)) == (s7_pointer)read_char_p_p) ? fx_c_o_read_char : fx_c_o_direct));
	  /* this is faster only because read_char_p_p is inlined */
	  if (pfunc == fx_c_s)        return(with_fx(tree, fx_c_o));
	}
      break;

    case HOP_SAFE_C_SC:
      if (arg1 == var1)
	{
	  if ((pfunc == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc));
	  if (pfunc == fx_c_sc)           return(with_fx(tree, fx_c_tc));
	  if (pfunc == fx_add_sf)         return(with_fx(tree, fx_add_tf));
	  if (fn_proc(p) == g_less_xf)    return(with_fx(tree, fx_lt_tf));
	  if (fn_proc(p) == g_less_x0)    return(with_fx(tree, fx_lt_t0));
	  if (fn_proc(p) == g_less_xi)
	    return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti)));
	  if (fn_proc(p) == g_geq_xf)     return(with_fx(tree, fx_geq_tf));
	  if (fn_proc(p) == g_geq_xi)     return(with_fx(tree, (integer(caddr(p)) == 0) ? fx_geq_t0 : fx_geq_ti));
	  if (fn_proc(p) == g_leq_xi)     return(with_fx(tree, fx_leq_ti));
	  if (fn_proc(p) == g_greater_xi) return(with_fx(tree, fx_gt_ti));
	  if (pfunc == fx_leq_si)         return(with_fx(tree, fx_leq_ti));
	  if (pfunc == fx_gt_si)          return(with_fx(tree, fx_gt_ti));

	  if (pfunc == fx_c_sc_direct) /* p_pp cases */
	    {
	      if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p))))
		return(with_fx(tree, fx_vector_ref_tc));
	      if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(p))) && (integer(caddr(p)) == 0))
		set_opt3_direct(cdr(p), string_ref_p_p0);
	      return(with_fx(tree, fx_c_tc_direct));
	    }
	  if (pfunc == fx_c_si_direct) /* p_pi cases */
	    {
	      if (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pi)
		return(with_fx(tree, fx_vector_ref_tc));
	      if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pi) && (integer(caddr(p)) == 0))
		set_opt3_direct(cdr(p), string_ref_p_p0);
	      return(with_fx(tree, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct));
	    }
	  if (pfunc == fx_is_eq_sc)    return(with_fx(tree, fx_is_eq_tc));
	  if (pfunc == fx_add_s1)      return(with_fx(tree, fx_add_t1));
	  if (pfunc == fx_add_si)      return(with_fx(tree, fx_add_ti));
	  if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1));
	  if (pfunc == fx_subtract_si) return(with_fx(tree, fx_subtract_ti));
	  if (pfunc == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf));
	  if (pfunc == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf));
	  if (pfunc == fx_multiply_si) return(with_fx(tree, fx_multiply_ti));
	  if (pfunc == fx_lt_si) /* is this ever hit? */
	    return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti)));
	  if (pfunc == fx_num_eq_si)   return(with_fx(tree, fx_num_eq_ti));
	  if (pfunc == fx_num_eq_s0)   return(with_fx(tree, fx_num_eq_t0));
	  if (pfunc == fx_memq_sc)     return(with_fx(tree, fx_memq_tc));
	  return(false);
	}
      if (arg1 == 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 (arg1 == 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(arg1, var1, var2, var3))) return(with_fx(tree, fx_c_oc));
	}
      break;

    case HOP_SAFE_C_CS:
      {
	const s7_pointer arg2 = caddr(p);
	if (arg2 == 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_multiply_fs) return(with_fx(tree, fx_multiply_ft));
	    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 ((arg2 == var2) && (pfunc == fx_c_cs)) return(with_fx(tree, fx_c_cu));
      }
      break;

    case HOP_SAFE_C_SS:
      {
	const s7_pointer 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)
	{
	  if (pfunc == fx_add_as) return(with_fx(tree, fx_add_at));
	  return(with_fx(tree, fx_c_at));
	}
      break;

    case HOP_SAFE_C_SA:
      if (arg1 == 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 (arg1 == var2) return(with_fx(tree, (pfunc == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua));
      break;

    case HOP_SAFE_C_SCS:
      if (arg1 == 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 ((arg1 == 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 ((arg1 == 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 (arg1 == 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 (cadr(arg1) == 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), cadr(arg1));
	      if ((is_global_and_has_func(car(p), s7_p_p_function)) &&
		  (is_global_and_has_func(car(arg1), 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(car(arg1))));
		  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, cadr(arg1));
	      return(with_fx(tree, (car(arg1) == sc->car_symbol) ? fx_not_car_t : fx_not_optq));
	    }}
      if (cadr(arg1) == 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 (cadr(arg1) == 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), 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 (arg1 == 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 (arg1 == var2)
	  {
	    if ((pfunc == fx_add_s_car_s) && (arg2_arg == var1)) /* arg2_arg = car's arg */
	      {
		set_opt1_sym(tree, 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));
	if ((pfunc == fx_c_s_opsq_direct) &&
	    (o_var_ok(arg1, var1, var2, var3)) && (o_var_ok(arg2_arg, var1, var2, var3)) && (!more_vars))
	  return(with_fx(tree, fx_c_o_opoq_direct));
      }
      break;

    case HOP_SAFE_C_opSq_opSq:
      {
	const s7_pointer 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 (cadr(arg1) == 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(car(arg1), 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(car(arg1))));
		      set_fx_direct(tree, fx_c_optq_c_direct);
		      return(true);
		    }
		  if ((is_t_integer(caddr(p))) &&
		      (is_global_and_has_func(car(arg1), 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(car(arg1))));
		      set_fx_direct(tree, fx_c_optq_i_direct);
		    }
		  else set_fx_direct(tree, fx_c_optq_c);
		}
	      return(true);
	    }}
      break;

    case HOP_SAFE_C_opSSq:
      if (pfunc == fx_c_opssq)
	{
	  if (caddr(arg1) == var1) return(with_fx(tree, fx_c_opstq));
	  if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq));
	}
      if (pfunc == fx_c_opssq_direct)
	{
	  if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq_direct));
	  if (caddr(arg1) == var1)
	    {
	      if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) &&
		  (!more_vars) && (o_var_ok(cadr(arg1), var1, var2, var3)))
		return(with_fx(tree, fx_is_zero_remainder_o));
	      return(with_fx(tree, fx_c_opstq_direct));
	    }}
      if ((cadr(arg1) == var2) && (pfunc == fx_not_opssq) && (caddr(arg1) == 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 (cadr(arg1) == var1)
	{
	  if ((fn_proc(p) == g_is_zero) && (fn_proc(arg1) == g_remainder) &&
	      (is_t_integer(caddr(arg1))) && (integer(caddr(arg1)) > 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) && (caddr(arg1) == 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;

#if !With_Gmp
    case HOP_SAFE_C_opSCq_C:
      if ((pfunc == fx_c_opscq_c) && (cadr(arg1) == var1))
	return(with_fx(tree, (fn_proc(p) == g_ash_ii) ? fx_c_optcq_c_ash : fx_c_optcq_c));
      break;
#endif

    case HOP_SAFE_C_S_opSCq:
      if (arg1 == 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 ((arg1 == 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 ((cadr(arg1) == 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), 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 = cadr(arg1), s2 = caddr(arg1);
	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 ((s1 == var1) && (s2 == var2))
	  {
	    if (pfunc == fx_gt_add_s) return(with_fx(tree, fx_gt_add_tu_s));
	    if (pfunc == fx_add_sub_s) return(with_fx(tree, fx_add_sub_tu_s));
	  }
	if ((pfunc == fx_c_opssq_s_direct) && (s2 == var2)) return(with_fx(tree, fx_c_opsuq_s_direct));
      }
      break;

    case HOP_SAFE_C_S_opSSq:
      if (caddaddr(p) == var1)
	{
	  if ((fn_proc(p) == g_vector_ref_2) && (is_defined_global(arg1) && (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 ((caddaddr(p) == var2) && (pfunc == fx_c_s_opssq_direct)) return(with_fx(tree, (arg1 == var1) ? fx_c_t_opsuq_direct : fx_c_s_opsuq_direct));
      break;

    case HOP_SAFE_C_op_opSq_Sq:
      if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol)) && (var1 == cadr(cadr(arg1))))
	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) && (car(arg1) == sc->remainder_symbol) && (fn_proc(cadr(arg1)) == g_car))
	{
	  set_opt3_sym(p, cadr(cadr(arg1)));
	  set_opt1_sym(cdr(p), caddr(arg1));
	  return(with_fx(tree, fx_is_zero_remainder_car));
	}
      break;

    case HOP_SAFE_CLOSURE_S_A:
      if ((arg1 == 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(arg1, var1, var2, var3))) return(with_fx(tree, fx_if_o_a_a));
      break;

    case OP_AND_3A:
      if ((pfunc == fx_and_3a) &&
	  (is_pair(arg1)) &&
	  (is_pair(cdr(arg1))) && (cadr(arg1) == 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), cadr(arg1));
	  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);
}

#if s7_Debugging
#define fx_tree(Sc, Tree, Var1, Var2, Var3, More_Vars) fx_tree_1(Sc, Tree, Var1, Var2, Var3, More_Vars, __func__, __LINE__)
static void fx_tree_1(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars, const char *func, int line)
#else
static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars)
#endif
{
#if 0
  fprintf(stderr, "  %s[%d] from %s[%d]: %s, vars: %s %s %s %d\n", __func__, __LINE__, func, line, display(tree),
	  (var1) ? display(var1) : "", (var2) ? display(var2) : "", (var3) ? display(var3) : "", more_vars);
#endif
  if (!is_pair(tree)) return;
  if ((is_symbol(car(tree))) &&
      (is_definer_or_binder(car(tree))))
    {
      /* fprintf(stderr, "definer: %s\n", display(tree)); */
      if (((car(tree) == sc->let_symbol) || (car(tree) == sc->letrec_symbol)) &&
	  /* let* vars can be in any combination of lets (outlet for each but sometimes combined) etc */
	  /*   in s7test tok? the let*'s data variable is in the of the result variable, so access has to be U not u, but no way to disambiguate here */
	  /*   if let*, one var case should be safe, but in that case let* is pointless */
	  /* do vars are stored in reverse order (do ((i 1) (j 2)) ...) has j first in the do body's environment, which greatly complicates this code */
	  (is_pair(cdr(tree))) &&    /* not named let */
	  (is_pair(cadr(tree))) &&   /* if empty = (), there are no local vars, so fx_tree_in is pointless (I think) */
	  (is_pair(caadr(tree))))    /* (let ((len (length str)) ) ...) */
	{
	  const s7_pointer let_var1 = caaadr(tree);
	  s7_pointer let_var2 = NULL, let_var3 = NULL, let_vars = cdadr(tree);
	  bool more_let_vars = false;
	  if ((is_pair(let_vars)) &&
	      (is_pair(car(let_vars))))
	    {
	      let_var2 = caar(let_vars);
	      let_vars = cdr(let_vars);
	      if ((is_pair(let_vars)) &&
		  (is_pair(car(let_vars))))
		{
		  let_var3 = caar(let_vars);
		  more_let_vars = is_pair(cdr(let_vars));
		}}
	  fx_tree(sc, cddr(tree), let_var1, let_var2, let_var3, more_let_vars);
	}
#if 0
      else
	if ((car(tree) == sc->do_symbol) && (is_pair(cadr(tree)))) /* there is at least one do var */
	  {
	    s7_pointer do_var1 = caaadr(tree), do_var2 = NULL, do_var3 = NULL, do_vars = cdadr(tree);
	    bool more_do_vars = false;
	    while ((is_pair(do_vars)) && (is_pair(car(do_vars))))
	      {
		if (do_var3) more_vars = true;
		do_var3 = do_var2;
		do_var2 = do_var1;
		do_var1 = caar(do_vars);
		do_vars = cdr(do_vars);
	      }
	    fx_tree(sc, cddr(tree), do_var1, do_var2, do_var3, more_do_vars);
	    fx_tree(sc, cdddr(tree), do_var1, do_var2, do_var3, more_do_vars);
	  }
#endif
      return;
    }
  /* if (is_syntax(car(tree))) fprintf(stderr, "  %s: syntax\n", display(car(tree))); */
  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[] =  /* Oft = optimizer function type? */
    {"Oft_d_v", "Oft_d_vd", "Oft_d_vdd", "Oft_d_vid", "Oft_d_id", "Oft_d_7pi", "Oft_d_7pii", "Oft_d_7piid",
     "Oft_d_ip", "Oft_d_pd", "Oft_d_7p", "Oft_d_7pid", "Oft_d", "Oft_d_d", "Oft_d_dd", "Oft_d_7dd", "Oft_d_ddd", "Oft_d_dddd",
     "Oft_i_i", "Oft_i_7i", "Oft_i_ii", "Oft_i_7ii", "Oft_i_iii", "Oft_i_7pi", "Oft_i_7pii", "Oft_i_7_piii", "Oft_d_p",
     "Oft_b_p", "Oft_b_7p", "Oft_b_pp", "Oft_b_7pp", "Oft_b_pp_unchecked", "Oft_b_pi", "Oft_b_ii", "Oft_b_7ii", "Oft_b_dd",
     "Oft_p", "Oft_p_p", "Oft_p_ii", "Oft_p_d", "Oft_p_dd", "Oft_i_7d", "Oft_i_7p", "Oft_d_7d", "Oft_p_pp", "Oft_p_ppp", "Oft_p_pi", "Oft_p_pi_unchecked",
     "Oft_p_ppi", "Oft_p_i", "Oft_p_pii", "Oft_p_pip", "Oft_p_pip_unchecked", "Oft_p_piip", "Oft_b_i", "Oft_b_d"};

  if (!is_c_function(base_func))
    {fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(base_func)); abort();}
  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, Oft_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, Oft_d));}

void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df) {add_opt_func(sc, f, Oft_d_d, (void *)df);}
s7_d_d_t s7_d_d_function(s7_pointer f) {return((s7_d_d_t)opt_func(f, Oft_d_d));}

void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df) {add_opt_func(sc, f, Oft_d_dd, (void *)df);}
s7_d_dd_t s7_d_dd_function(s7_pointer f) {return((s7_d_dd_t)opt_func(f, Oft_d_dd));}

void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df) {add_opt_func(sc, f, Oft_d_v, (void *)df);}
s7_d_v_t s7_d_v_function(s7_pointer f) {return((s7_d_v_t)opt_func(f, Oft_d_v));}

void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df) {add_opt_func(sc, f, Oft_d_vd, (void *)df);}
s7_d_vd_t s7_d_vd_function(s7_pointer f) {return((s7_d_vd_t)opt_func(f, Oft_d_vd));}

void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df) {add_opt_func(sc, f, Oft_d_vdd, (void *)df);}
s7_d_vdd_t s7_d_vdd_function(s7_pointer f) {return((s7_d_vdd_t)opt_func(f, Oft_d_vdd));}

void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df) {add_opt_func(sc, f, Oft_d_vid, (void *)df);}
s7_d_vid_t s7_d_vid_function(s7_pointer f) {return((s7_d_vid_t)opt_func(f, Oft_d_vid));}

void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df) {add_opt_func(sc, f, Oft_d_id, (void *)df);}
s7_d_id_t s7_d_id_function(s7_pointer f) {return((s7_d_id_t)opt_func(f, Oft_d_id));}

void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df) {add_opt_func(sc, f, Oft_d_7pid, (void *)df);}
s7_d_7pid_t s7_d_7pid_function(s7_pointer f) {return((s7_d_7pid_t)opt_func(f, Oft_d_7pid));}

void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df) {add_opt_func(sc, f, Oft_d_ip, (void *)df);}
s7_d_ip_t s7_d_ip_function(s7_pointer f) {return((s7_d_ip_t)opt_func(f, Oft_d_ip));}

void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df) {add_opt_func(sc, f, Oft_d_pd, (void *)df);}
s7_d_pd_t s7_d_pd_function(s7_pointer f) {return((s7_d_pd_t)opt_func(f, Oft_d_pd));}

void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df) {add_opt_func(sc, f, Oft_d_p, (void *)df);}
s7_d_p_t s7_d_p_function(s7_pointer f) {return((s7_d_p_t)opt_func(f, Oft_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, Oft_d_7p, (void *)df);}
static s7_d_7p_t s7_d_7p_function(s7_pointer f) {return((s7_d_7p_t)opt_func(f, Oft_d_7p));}

void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df) {add_opt_func(sc, f, Oft_b_p, (void *)df);}
s7_b_p_t s7_b_p_function(s7_pointer f) {return((s7_b_p_t)opt_func(f, Oft_b_p));}

void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df) {add_opt_func(sc, f, Oft_d_7pi, (void *)df);}
s7_d_7pi_t s7_d_7pi_function(s7_pointer f) {return((s7_d_7pi_t)opt_func(f, Oft_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, Oft_d_7pii, (void *)df);}
static s7_d_7pii_t s7_d_7pii_function(s7_pointer f) {return((s7_d_7pii_t)opt_func(f, Oft_d_7pii));}

void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df) {add_opt_func(sc, f, Oft_i_7p, (void *)df);}
s7_i_7p_t s7_i_7p_function(s7_pointer f) {return((s7_i_7p_t)opt_func(f, Oft_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, Oft_d_ddd, (void *)df);}
s7_d_ddd_t s7_d_ddd_function(s7_pointer f) {return((s7_d_ddd_t)opt_func(f, Oft_d_ddd));}

void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df) {add_opt_func(sc, f, Oft_d_dddd, (void *)df);}
s7_d_dddd_t s7_d_dddd_function(s7_pointer f) {return((s7_d_dddd_t)opt_func(f, Oft_d_dddd));}

void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df) {add_opt_func(sc, f, Oft_i_i, (void *)df);}
s7_i_i_t s7_i_i_function(s7_pointer f) {return((s7_i_i_t)opt_func(f, Oft_i_i));}

void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df) {add_opt_func(sc, f, Oft_i_ii, (void *)df);}
s7_i_ii_t s7_i_ii_function(s7_pointer f) {return((s7_i_ii_t)opt_func(f, Oft_i_ii));}

void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df) {add_opt_func(sc, f, Oft_i_7d, (void *)df);}
s7_i_7d_t s7_i_7d_function(s7_pointer f) {return((s7_i_7d_t)opt_func(f, Oft_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, Oft_p_d, (void *)df);}
s7_p_d_t s7_p_d_function(s7_pointer f) {return((s7_p_d_t)opt_func(f, Oft_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, Oft_d_7dd, (void *)df);}
static s7_d_7dd_t s7_d_7dd_function(s7_pointer f) {return((s7_d_7dd_t)opt_func(f, Oft_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, Oft_i_7i, (void *)df);}
static s7_i_7i_t s7_i_7i_function(s7_pointer f) {return((s7_i_7i_t)opt_func(f, Oft_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, Oft_i_7ii, (void *)df);}
static s7_i_7ii_t s7_i_7ii_function(s7_pointer f) {return((s7_i_7ii_t)opt_func(f, Oft_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, Oft_i_iii, (void *)df);}
static s7_i_iii_t s7_i_iii_function(s7_pointer f) {return((s7_i_iii_t)opt_func(f, Oft_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, Oft_p_pi, (void *)df);}
static s7_p_pi_t s7_p_pi_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, Oft_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, Oft_p_ppi, (void *)df);}
static s7_p_ppi_t s7_p_ppi_function(s7_pointer f) {return((s7_p_ppi_t)opt_func(f, Oft_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, Oft_i_7pi, (void *)df);}
static s7_i_7pi_t s7_i_7pi_function(s7_pointer f) {return((s7_i_7pi_t)opt_func(f, Oft_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, Oft_i_7pii, (void *)df);}
static s7_i_7pii_t s7_i_7pii_function(s7_pointer f) {return((s7_i_7pii_t)opt_func(f, Oft_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, Oft_i_7piii, (void *)df);}
static s7_i_7piii_t s7_i_7piii_function(s7_pointer f) {return((s7_i_7piii_t)opt_func(f, Oft_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, Oft_b_d, (void *)df);}
static s7_b_d_t s7_b_d_function(s7_pointer f) {return((s7_b_d_t)opt_func(f, Oft_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, Oft_b_i, (void *)df);}
static s7_b_i_t s7_b_i_function(s7_pointer f) {return((s7_b_i_t)opt_func(f, Oft_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, Oft_b_7p, (void *)df);}
static s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, Oft_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, Oft_b_pp, (void *)df);}
static s7_b_pp_t s7_b_pp_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, Oft_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, Oft_b_7pp, (void *)df);}
static s7_b_7pp_t s7_b_7pp_function(s7_pointer f) {return((s7_b_7pp_t)opt_func(f, Oft_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, Oft_d_7d, (void *)df);}
static s7_d_7d_t s7_d_7d_function(s7_pointer f) {return((s7_d_7d_t)opt_func(f, Oft_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, Oft_b_pi, (void *)df);}
static s7_b_pi_t s7_b_pi_function(s7_pointer f) {return((s7_b_pi_t)opt_func(f, Oft_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, Oft_b_ii, (void *)df);}
static s7_b_ii_t s7_b_ii_function(s7_pointer f) {return((s7_b_ii_t)opt_func(f, Oft_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, Oft_b_7ii, (void *)df);}
static s7_b_7ii_t s7_b_7ii_function(s7_pointer f) {return((s7_b_7ii_t)opt_func(f, Oft_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, Oft_b_dd, (void *)df);}
static s7_b_dd_t s7_b_dd_function(s7_pointer f) {return((s7_b_dd_t)opt_func(f, Oft_b_dd));}

void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df) {add_opt_func(sc, f, Oft_p_p, (void *)df);}
s7_p_p_t s7_p_p_function(s7_pointer f) {return((s7_p_p_t)opt_func(f, Oft_p_p));}

static void s7_set_p_function(s7_scheme *sc, s7_pointer f, s7_p_t df) {add_opt_func(sc, f, Oft_p, (void *)df);}
static s7_p_t s7_p_function(s7_pointer f) {return((s7_p_t)opt_func(f, Oft_p));}

void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df) {add_opt_func(sc, f, Oft_p_pp, (void *)df);}
s7_p_pp_t s7_p_pp_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, Oft_p_pp));}

void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df) {add_opt_func(sc, f, Oft_p_ppp, (void *)df);}
s7_p_ppp_t s7_p_ppp_function(s7_pointer f) {return((s7_p_ppp_t)opt_func(f, Oft_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, Oft_p_pip, (void *)df);}
static s7_p_pip_t s7_p_pip_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, Oft_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, Oft_p_pii, (void *)df);}
static s7_p_pii_t s7_p_pii_function(s7_pointer f) {return((s7_p_pii_t)opt_func(f, Oft_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, Oft_p_piip, (void *)df);}
static s7_p_piip_t s7_p_piip_function(s7_pointer f) {return((s7_p_piip_t)opt_func(f, Oft_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, Oft_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, Oft_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, Oft_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, Oft_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, Oft_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, Oft_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, Oft_p_i, (void *)df);}
static s7_p_i_t s7_p_i_function(s7_pointer f) {return((s7_p_i_t)opt_func(f, Oft_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, Oft_p_ii, (void *)df);}
static s7_p_ii_t s7_p_ii_function(s7_pointer f) {return((s7_p_ii_t)opt_func(f, Oft_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, Oft_d_7piid, (void *)df);}
static s7_d_7piid_t s7_d_7piid_function(s7_pointer f) {return((s7_d_7piid_t)opt_func(f, Oft_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, Oft_p_dd, (void *)df);}
static s7_p_dd_t s7_p_dd_function(s7_pointer f) {return((s7_p_dd_t)opt_func(f, Oft_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))
    {
      const s7_pointer slot = s7_slot(sc, sym);
      if ((is_slot(slot)) &&              /* here and below, p can be #<undefined> (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))
    {
      const 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))
    {
      const 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)
{
  const 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)
{
  const s7_pointer slot = s7_slot(sc, sym);
  if (is_slot(slot))
    {
      const s7_pointer checker = s7_symbol_value(sc, check);
      const 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) */
#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) */
/* #define q_p_func4_call(O) q_func4(O).fp(q_func4_arg(O).o1) */


/* -------------------------------- 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);
    }
  {
    const 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_c_rand(opt_info *o) {return(random_i_7i(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;
  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 : ((func7 == random_i_7i) ? opt_i_7i_c_rand : opt_i_7i_c);
	    }
	  return_true(sc, expr);
	}
      {
	const s7_pointer 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);
	    }
	  {
	    const s7_pointer 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 <int-vector> <int>)? */
	{
	  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)))
	{
	  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;
	  {
	    const s7_pointer 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_add(opt_info *o) {return(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));
}

#if With_Gmp
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)));}
static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(q_arg1(o).i * next_random(o->sc)) - q_arg2(o).i);}
#else
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);}
#endif

static bool i_ii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr)
{
  const s7_i_ii_t ifunc = s7_i_ii_function(s_func);
  s7_i_7ii_t ifunc7 = NULL;

  if (!ifunc)
    {
      ifunc7 = s7_i_7ii_function(s_func);
      if (!ifunc7)
	return_false(sc, expr);
    }
  { /* 2-Jul-26: this was dependent on c_function_signature which wasn't used? */
    const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
    const int32_t start = sc->pc;
    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);
	  }
	{
	  const s7_pointer arg2_slot = opt_integer_symbol(sc, arg2);
	  if (arg2_slot)
	    {
	      q_arg2(opc).p = arg2_slot;
	      if (ifunc)
		q_call(opc).fi = (ifunc == multiply_i_ii) ? opt_i_ii_cs_mul : ((ifunc == add_i_ii) ? opt_i_ii_cs_add : 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_rand) ||
		     ((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 is not an integer */
    {
      const s7_pointer 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 is not an integer, arg1 is an integer or a symbol */
	    const s7_pointer 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 is not an integer or a 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_rand) ||
			 ((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 is not an integer or a symbol, arg2 is not an 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)
{
  const s7_i_7pii_t pfunc = s7_i_7pii_function(s_func);
  if (!pfunc) return_false(sc, expr);
  {
    const s7_pointer sig = c_function_signature(s_func);
    if ((is_pair(sig)) &&
	(is_symbol(cadr(expr))))
      {
	const s7_pointer 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)));
	{
	  const s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr));
	  if (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);
	      
	      {
		const s7_pointer arg2 = caddr(expr);
		const s7_pointer arg2_slot = opt_integer_symbol(sc, arg2);
		if (arg2_slot)
		  {
		    q_arg2(opc).p = arg2_slot;
		    {
		      const s7_pointer 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) */
  const s7_pointer slot2 = opt_integer_symbol(sc, car(indexp2));
  if (slot2)
    {
      const s7_pointer slot1 = opt_integer_symbol(sc, car(indexp1));
      q_arg3(opc).p = slot2;
      if (slot1)
	{
	  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);
	    }
	  {
	    const s7_pointer 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)
{
  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 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 */
	    {
	      const s7_pointer slot = opt_integer_symbol(sc, car(indexp1));
	      q_func(opc).i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii;
	      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);

      if ((len == 2) && /* ipi case */
	  (vector_rank(obj) == 1))
	{
	  opt_info *opc = alloc_opt_info(sc);
	  q_arg1(opc).p = s_slot;
	  {
	    const s7_pointer 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;
	  {
	    const s7_pointer slot2 = opt_integer_symbol(sc, cadr(expr));
	    if (slot2)
	      {
		const s7_pointer slot3 = opt_integer_symbol(sc, caddr(expr));
		q_arg2(opc).p = slot2;
		if (!slot3)
		  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 = slot3;
		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))))
    {
      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)));
      {
	const s7_pointer settee = s7_slot(sc, cadr(expr));
	if (is_slot(settee))
	  {
	    const 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, s7_Warn_Bufsize, "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 *unused_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)); 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 */
{
  const 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)
{
  const 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)
{
  const 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)
{
  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);
    }
  {
    const s7_pointer 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))
    {
      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);
	}
      {
	const s7_pointer 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)
{
  const s7_d_v_t flt_func = s7_d_v_function(s_func);
  if (!flt_func) return_false(sc, expr);
  {
    const s7_pointer 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) */
      {
	const 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)));}
#if !With_Gmp
  static s7_double opt_d_7p_s_magnitude(opt_info *o) {return(magnitude_d_7p(o->sc, slot_value(q_arg1(o).p)));}
#endif
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 = NULL;
  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)))
    {
      const s7_pointer slot = opt_simple_symbol(sc, cadr(expr));
      if (!slot)
	return_false(sc, expr);
      q_arg1(opc).p = slot;
#if With_Gmp
      q_call(opc).fd = (dpf) ? opt_d_p_s : opt_d_7p_s;
#else
      q_call(opc).fd = (dpf) ? opt_d_p_s : ((d7pf == magnitude_d_7p) ? opt_d_7p_s_magnitude : opt_d_7p_s);
#endif
      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_sc_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));}
static s7_double opt_d_7pi_sc_fvref_direct(opt_info *o) {return(float_vector(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 <float-vector> <int>)? */
	{
	  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) */
    {
      q_arg1(opc).p = s7_slot(sc, cadr(expr));
      if (!is_slot(q_arg1(opc).p)) return_false(sc, expr);
      {
	const s7_pointer 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 */
	
	{
	  const s7_pointer arg2 = caddr(expr);
	  if (!is_pair(arg2))
	    {
	      if (is_t_integer(arg2))
		{
		  q_arg2(opc).i = integer(arg2);
		  q_call(opc).fd = (ifunc == float_vector_ref_d_7pi) ?
		    (((integer(arg2) >= 0) && (vector_length(obj) > integer(arg2))) ? opt_d_7pi_sc_fvref_direct : opt_d_7pi_sc_fvref) : opt_d_7pi_sc;
		  return_true(sc, expr);
		}
	      {
		const s7_pointer 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))))
    {
      const 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)
	{
	  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);
	  {
	    const s7_pointer 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;
      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))))
    {
      const 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)
{
  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;
  {
    const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
    if (arg1_slot)
      {
	const s7_pointer arg2 = caddr(expr);
	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);
	  }
	{
	  const s7_pointer 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_sub(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_mul(opt_info *o) {return(q_arg1(o).x * q_d_func1_call(o));}

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)
{
#if With_Gmp
  return(q_arg1(o).x * next_random(o->sc) - q_arg2(o).x);
#else
  return(q_arg1(o).x * next_random(o->sc->default_random_state) - q_arg2(o).x);
#endif
}

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_dd_sfo_add(opt_info *o)
{
  return(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;
	      if (q_func(opc).d_dd_f == add_d_dd) q_call(opc).fd = opt_d_dd_sfo_add;
	    }
	  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 inline s7_double opt_d_7dd_ff_add_div(opt_info *o) /* probably spectral-norm in tshoot.scm */
{
  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));
  const 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_call(opc).fd == opt_d_dd_cf) && (func == multiply_d_dd))
	    q_call(opc).fd = opt_d_dd_cf_mul;
	  else
	    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 : ((func == subtract_d_dd) ? opt_d_dd_ss_sub : 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)))
    {
      const 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);
		}
	      /* opt_d_dd_ff_atan here (tari.scm) saves only 1 */
	      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_sff_mul(opt_info *o)
{
  s7_double x1 = q_d_func2_call(o);
  s7_double x2 = q_d_func3_call(o);
  return(multiply_d_ddd(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) /* add case saves only 5 in tfft */
{
  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(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;
  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;
  q_func2_arg(opc).o1 = sc->opts[start];
  {
    const s7_pointer arg1_slot = opt_float_symbol(sc, arg1);
    if (arg1_slot)
      {
	const s7_pointer arg2_slot = opt_float_symbol(sc, arg2);
	q_arg1(opc).p = arg1_slot;
	if (arg2_slot)
	  {
	    const s7_pointer arg3 = cadddr(expr);
	    q_arg2(opc).p = arg2_slot;
	    {
	      const s7_pointer 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 = (func == multiply_d_ddd) ? opt_d_ddd_sff_mul: 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_sif_fvset(opt_info *o) {return(float_vector_set_d_7pid(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, q_d_func3_call(o)));}
static s7_double opt_d_7pid_sif_fvset_direct(opt_info *o) {return(float_vector_set_d_7pid_direct(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, 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; /* works for (block-set! b1 j (block-ref b j)) -- we have d_7pid above and d_7pi here (tobj via s7test) */
	  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))
	{
	  const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr));
	  if (arg2_slot)
	    {
	      const s7_pointer arg3_slot = opt_float_symbol(sc, cadddr(expr));
	      q_arg2(opc).p = arg2_slot;
	      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))))
    {
      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);
      {
	const s7_pointer arg3_slot = opt_integer_symbol(sc, cadddr(expr));
	if (arg3_slot)
	  {
	    const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr));
	    q_arg3(opc).p = arg3_slot;
	    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))))
    {
      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);
      {
	const s7_pointer arg4_slot = opt_integer_symbol(sc, car(cddddr(expr)));
	if (arg4_slot)
	  {
	    const s7_pointer arg3_slot = opt_integer_symbol(sc, cadddr(expr));
	    q_arg4(opc).p = arg4_slot;
	    if (arg3_slot)
	      {
		const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr));
		q_arg3(opc).p = arg3_slot;
		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 float_optimize_1(s7_scheme *sc, s7_pointer form);

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), arg2 = car(indexp1);
  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))
	{
	  const s7_pointer ind1_slot = opt_integer_symbol(sc, arg2);
	  q_func(opc).d_7pid_f = float_vector_set_d_7pid;
	  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) ?
		    ((is_t_integer(arg2)) ? opt_d_7pid_sif_fvset : opt_d_7pid_sff_fvset) : opt_d_7pid_sff;
		  if (q_call(opc).fd != opt_d_7pid_sif_fvset)
		    q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi;
		  else
		    {
		      q_arg2(opc).i = integer(arg2);
		      if ((integer(arg2) >= 0) && (integer(arg2) < vector_length(vect)))
			q_call(opc).fd = opt_d_7pid_sif_fvset_direct;
		    }
		  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))
	{
	  const s7_pointer ind2_slot = opt_integer_symbol(sc, car(indexp2));
	  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
	   */
	  if (ind2_slot)
	    {
	      q_arg3(opc).p = ind2_slot;
	      if (is_t_integer(arg2))
		{
		  if (!float_optimize(sc, valp))
		    return_false(sc, valp);
		  q_call(opc).fd = opt_d_7piid_scsf;
		  q_arg2(opc).i = integer(arg2);
		  q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd;
		  return_true(sc, NULL);
		}
	      {
		const s7_pointer ind1_slot = opt_integer_symbol(sc, arg2);
		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_1(sc, valp)) && (sc->pc < Opts_Size))
		      {
			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))
	{
	  const s7_pointer ind3_slot = opt_integer_symbol(sc, car(indexp3));
	  if (ind3_slot)
	    {
	      const s7_pointer ind2_slot = opt_integer_symbol(sc, car(indexp2));
	      q_arg4(opc).p = ind3_slot;
	      if (ind2_slot)
		{
		  const s7_pointer ind1_slot = opt_integer_symbol(sc, arg2);
		  q_arg3(opc).p = ind2_slot;
		  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))))
    {
      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;
      {
	const s7_pointer 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)
	      {
		q_call(opc).fd = opt_d_vid_ssf;
		q_arg1(opc).p = vslot;
		q_func2_arg(opc).o1 = sc->opts[start];
		{
		  const s7_pointer 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)
{
  const 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))
	{
	  opt_info *opc = alloc_opt_info(sc);
	  const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
	  q_arg1(opc).p = s_slot;
	  q_func(opc).d_7pi_f = float_vector_ref_d_7pi;
	  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))
	{
	  opt_info *opc = alloc_opt_info(sc);
	  const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
	  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 */
	  if (arg1_slot)
	    {
	      const s7_pointer arg2_slot= opt_integer_symbol(sc, caddr(expr));
	      q_arg2(opc).p = arg1_slot;
	      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))
	{
	  const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
	  opt_info *opc = alloc_opt_info(sc);
	  q_arg1(opc).p = s_slot;
	  if (arg1_slot)
	    {
	      const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr));
	      q_arg2(opc).p = arg1_slot;
	      if (arg2_slot)
		{
		  const s7_pointer arg3_slot = opt_integer_symbol(sc, cadddr(expr));
		  q_arg3(opc).p = arg2_slot;
		  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)
	    {
	      opt_info *opc = alloc_opt_info(sc);
	      const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
	      q_arg1(opc).p = s_slot;
	      q_func(opc).d_7pi_f = func;
	      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;
  const 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 == is_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;
  {
    const 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 #<undefined> */
			  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)));
	    }
	  {
	    const s7_pointer arg_slot = s7_slot(sc, car(arg));
	    if ((is_slot(arg_slot)) &&
		(is_sequence(slot_value(arg_slot))))
	      {
		const 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))
    {
      const s7_pointer arg_slot = opt_simple_symbol(sc, arg);
      if (!arg_slot) return(sc->T);
#if With_Gmp
      if (is_big_number(slot_value(arg_slot)))
	return(sc->T);
      if ((is_t_integer(slot_value(arg_slot))) &&
	  (integer(slot_value(arg_slot)) > Quotient_Int_Limit))
	return(sc->T);
      if ((is_t_real(slot_value(arg_slot))) &&
	  (real(slot_value(arg_slot)) > Quotient_Float_Limit))
	return(sc->T);
#endif
      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);
	  if (q_call(opc).fb == opt_b_7pp_ffo)
	    {
	      if (q_func1(opc).p_p_f == magnitude_p_p) q_func1(opc).p_p_f = magnitude_p_p_wrapped;
	      if (q_func2(opc).p_p_f == magnitude_p_p) q_func2(opc).p_p_f = magnitude_p_p_wrapped;
	    }
	  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))
    {
      const s7_pointer call_sig = c_function_signature(s_func);
      const s7_pointer arg1_type = opt_arg_type(sc, cdr(expr));
      const 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 s7_pointer opt_p_z_f_magnitude(opt_info *o);
static s7_pointer opt_p_z_f_magnitude_wrapped(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 #<undefined> */
	    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;

	  if (q_call(opc).fb == opt_b_7pp_ff)
	    {
	      /* q_call(opc).fb == leq_b_7pp, q_func3(opc).fp == opt_p_p_f, q_func2(opc).fp == opt_p_z_f_magnitude */
	      if (q_func2(opc).fp == opt_p_z_f_magnitude) q_func2(opc).fp = opt_p_z_f_magnitude_wrapped;
	    }

	  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)
{
  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);
    }
  {
    const s7_pointer 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_z_f_magnitude_wrapped(opt_info *o) {return(magnitude_p_z_wrapped(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) {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_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_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;
      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;
		  /* tcomplex: (magnitude (complex-vector-ref cv1 (+ i 1))) in
		   *  (if (<= (magnitude (complex-vector-ref cv1 i)) (magnitude (complex-vector-ref cv1 (+ i 1))))...)
		   */
		}
	      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));
	      if (caadr(expr) == sc->string_ref_symbol)
		{
		  if (q_func1(opc).p_p_f == char_upcase_p_p)
		    q_func1(opc).p_p_f = char_upcase_p_p_unchecked;
		  else
		    if (q_func1(opc).p_p_f == is_char_whitespace_p_p)
		      q_func1(opc).p_p_f = is_char_whitespace_p_p_unchecked;
		}
	      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;
	      if (q_func1(opc).p_p_f == magnitude_p_p) q_func1(opc).p_p_f = magnitude_p_p_wrapped; /* tcomplex */
	    }
	  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))));} /* integer_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 s7_pointer opt_p_i_s_str(opt_info *o)
{
  s7_int nlen = 0;
  const char *result = integer_to_string(o->sc, integer(slot_value(q_arg1(o).p)), &nlen);
  return(inline_make_string_with_length(o->sc, result, nlen));
}

static bool p_i_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart)
{
  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;
  {
    const s7_pointer slot = opt_integer_symbol(sc, cadr(expr));
    if (slot)
      {
	q_arg1(opc).p = slot;
	q_call(opc).fp = (ifunc == integer_to_string_p_i) ? opt_p_i_s_str : 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_sc_divide(opt_info *o)
{
  return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, integer(slot_value(q_arg1(o).p)), q_arg2(o).i));
}

static s7_pointer opt_p_ii_ss_cmplx(opt_info *o)
{
  s7_int x = integer(slot_value(q_arg1(o).p));
  s7_int y = integer(slot_value(q_arg2(o).p));
  return((y == 0.0) ? make_integer(o->sc, x) : make_complex_not_0i(o->sc, (s7_double)x, (s7_double)y));
}

static s7_pointer opt_p_ii_ss_cmplx_wrapped(opt_info *o)
{
  s7_int x = integer(slot_value(q_arg1(o).p));
  s7_int y = integer(slot_value(q_arg2(o).p));
  return((y == 0.0) ? wrap_integer(o->sc, x) : wrap_complex(o->sc, (s7_double)x, (s7_double)y));
}

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)
{
  const s7_p_ii_t ifunc = s7_p_ii_function(s_func);
  if (!ifunc) return_false(sc, expr);
  {
    const s7_pointer 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 = (ifunc == complex_p_ii) ? opt_p_ii_ss_cmplx : 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);
      }}
  if ((ifunc == divide_p_ii) && (is_t_integer(caddr(expr))))
    {
      const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr));
      if (arg1_slot)
	{
	  q_arg1(opc).p = arg1_slot;
	  q_arg2(opc).i = integer(caddr(expr));
	  q_func(opc).p_ii_f = ifunc;
	  q_call(opc).fp = opt_p_ii_sc_divide;
	  return_true(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)
{
  opt_info *o1;
  const s7_p_d_t ifunc = s7_p_d_function(s_func);
  if (!ifunc) return_false(sc, expr);
  {
    const s7_pointer 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))
    {
      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);
	}
      {
	const s7_pointer 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))
    {
      const s7_pointer 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))));}
/* replacing the p_pi_direct call with its innards does not speed up the following functions according to callgrind */
/* see opt_p_p above for opt_p_pi_ss_vref_direct et al */
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_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)
{
  /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(obj), display(slot), display(expr)); */
  if (!is_t_integer(slot_value(slot))) return;
  if (integer(slot_value(slot)) < 0) return; /* p_pi_ok 67164 p_2x_ok 71555 cell_optimize_1 71769 (vector-ref v i) */
  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)
{
  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 */
  {
    const s7_pointer 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;
  }
  {
    const s7_pointer obj = slot_value(q_arg1(opc).p);
    const s7_pointer checker = (is_symbol(cadr(sig))) ? cadr(sig) : NULL;
    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);
	  }}
    {
      const s7_pointer 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_ss_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));}
static s7_pointer opt_p_pp_ss_mul_wrapped(opt_info *o) {return(multiply_p_pp_wrapped(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_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_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_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_sc_read_line(opt_info *o) {return(read_line_p_pp(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));}
static s7_pointer opt_p_pp_sc_remainder(opt_info *o) {return(remainder_p_pp(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));}

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_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_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_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(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_fs_vref(opt_info *o) {return(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_fs_write_string(opt_info *o) {return(write_string_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)
{
  const 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)
{
  const 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)))
    {
      const 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)
{
  const 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 : ((func == multiply_p_pp) ? opt_p_pp_ss_mul :
		                (((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 (func == read_line_p_pp) q_call(opc).fp = opt_p_pp_sc_read_line;
	  else if (func == remainder_p_pp) q_call(opc).fp = opt_p_pp_sc_remainder;
	  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 == vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons :
				     ((func == write_string_p_pp) ? opt_p_pp_fs_write_string : 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 #<undefined> */
	  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-ci<? (null? i) (quote . let)) t101-43.scm */
	    {
	      q_call(opc).fp = opt_p_call_fc;
	      q_arg2(opc).p = (is_pair(arg2)) ? cadr(arg2) : arg2;
	      check_opc_vector_wraps_1(opc);
	      return_true(sc, expr);
	    }
	  q_func2_arg(opc).o1 = sc->opts[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_sif_lset(opt_info *o)
{
  return(list_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, 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; /* (set! (obj j) (sequence i)) and the like */
	  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 arg1_slot, val_type;
  const s7_p_pip_t func = s7_p_pip_function(s_func);
  if (!func) return_false(sc, expr);
  /* here we know cadr is a symbol */
  arg1_slot = s7_slot(sc, cadr(expr));
  if (!is_slot(arg1_slot)) return_false(sc, expr);
  {
    const s7_pointer obj = slot_value(arg1_slot);
    if ((has_methods(obj)) || (is_immutable(obj))) return_false(sc, expr);
    if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) return_false(sc, expr);
    val_type = opt_arg_type(sc, cdddr(expr));
    q_arg1(opc).p = arg1_slot;
    q_func(opc).p_pip_f = func;
    {
      const s7_pointer sig = c_function_signature(s_func);
      const s7_pointer checker = ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_symbol(cadr(sig)))) ? cadr(sig) : NULL;
      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))
	      {
		const 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;
		if ((q_call(opc).fp == opt_p_pip_sff_lset) && (q_func2_arg(opc).q_call(o1).fi == opt_i_c))
		  {
		    q_call(opc).fp = opt_p_pip_sif_lset;
		    q_arg2(opc).i = integer(caddr(expr));
		  }
		else 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)
{
  const s7_pointer vec = slot_value(q_arg1(o).p);
  const 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)
{
  const 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;
  {
    const s7_pointer 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))))
    {
      const s7_pointer arg1_slot = s7_slot(sc, cadr(expr));
      if (!is_slot(arg1_slot))
	return_false(sc, expr);
      {
	const s7_pointer 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 opt_p_pii_sii_vref(opt_info *o) {return(vector_ref_p_pii_direct(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, q_arg3(o).i));}

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))))
    {
      const s7_pointer arg1_slot = s7_slot(sc, cadr(expr));
      if (!is_slot(arg1_slot))
	return_false(sc, expr);
      {
	const s7_pointer 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))
	  {
	    const s7_pointer indexp1 = cddr(expr), indexp2 = cdddr(expr);
	    const s7_pointer ind2_slot = opt_integer_symbol(sc, car(indexp2));
	    q_arg1(opc).p = arg1_slot;
	    q_func(opc).p_pii_f = vector_ref_p_pii;
	    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_ssf_cvset(opt_info *o) {return(complex_vector_set_p_ppp(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)));
  set_gc_protected3(sc, q_p_func1_call(o));
  result = q_func(o).p_ppp_f(sc, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc));
  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 */
{
  const 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 */
{
  const 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 */
{
  const 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;
      const 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))
		{
		  const s7_pointer 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 (q_func(opc).p_ppp_f == complex_vector_set_p_ppp)
		    q_call(opc).fp = opt_p_ppp_ssf_cvset;

		  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(opc).fp == opt_p_ii_ss_cmplx)
			    q_func1(opc).fp = opt_p_ii_ss_cmplx_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;
		    }
		  else
		    if (q_func(opc).p_ppp_f == add_p_ppp)
		      {
			if (q_func1(opc).fp == opt_p_pp_ss_mul) q_func1(opc).fp = opt_p_pp_ss_mul_wrapped;
			if (q_func2(opc).fp == opt_p_pp_ss_mul) q_func2(opc).fp = opt_p_pp_ss_mul_wrapped;
			if (q_func3(opc).fp == opt_p_pp_ss_mul) q_func3(opc).fp = opt_p_pp_ss_mul_wrapped;
		      }
		  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;
  const 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 s7_pointer opt_p_call_4c(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_arg1(o1).p, q_arg1(o2).p, q_arg1(o3).p, q_arg1(o4).p)));
}

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, safe_c = 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;
	  else if (is_symbol(car(p))) safe_c = false;
	}
      if (is_null(p))
	{
	  if ((len == 5) && safe)
	    q_call(opc).fp = (safe_c) ? opt_p_call_4c : opt_p_call_4g;
	  else q_call(opc).fp = 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)
{
  const s7_function func = ((is_pair(car(expr))) && (has_fx(car(expr)))) ? fx_proc(car(expr)) : NULL;
  /* if safe_closure_s_to_add1, fx_proc and has_fx are in cdr(expr), but this is not safe to use here (see ffitest s7f) */
#if 0 /* this triggers a hard-to-understand bug in ffitest involving lets and opts in code fragments */
  if ((!func) && (is_pair(cdar(expr))) && (!is_pair(cadar(expr))) && (has_fx(cdar(expr))))
    {
      s7_function f = fx_proc(cdar(expr));
      if (f == fx_safe_closure_s_to_add1) {fprintf(stderr, "got %s\n", display(expr)); func = f;}
    }
#endif
#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;
	  /* if (q_func(opc).p_pi_f == t_vector_ref_p_pi_unchecked) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(expr)); */
	  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;
		  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) -> #<slot: :x :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)
	    {
	      const s7_pointer arg1_slot = opt_integer_symbol(sc, arg1);
	      q_arg3(opc).p = arg2_slot;
	      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);
		}}
	  if ((is_t_integer(cadr(expr))) && (is_t_integer(caddr(expr))))  /* implicit ref = (v i i) */
	    {
	      q_call(opc).fp = opt_p_pii_sii_vref;
	      q_arg2(opc).i = integer(cadr(expr));
	      q_arg3(opc).i = integer(caddr(expr));
	      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)
{
  const 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)
{
  const s7_pointer val = q_p_func1_call(o); /* the string */
  const 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)
{
  const s7_pointer val = q_p_func1_call(o); /* the string */
  const 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 inline s7_pointer opt_set_p_d_f_sf_add(opt_info *o) /* inline=55 in tnum! */
{
  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)
{
  const 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 */
{
  const 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));
  const 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)
{
  const 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));
  const 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)
{
  const s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)));
  const 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)
{
  const s7_int i = integer(slot_value(q_arg2(o).p)) + integer(slot_value(q_arg3(o).p));
  const 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)
{
  const s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), q_arg3(o).i);
  const 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)
{
  const s7_int i = integer(slot_value(q_arg2(o).p)) + q_arg3(o).i;
  const 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 cur_type, 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 */
  /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(target), display(cur_type), display(expr)); */

  /* 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 (is_pair(cddr(expr)))
	    {
	      s7_pointer expr_type = argument_type(sc, caddr(expr)); /* can be NULL */
	      if ((expr_type) && (symbol_category(expr_type) != symbol_category(cur_type)))
		return_false(sc, expr);
	    }
	  if (cell_optimize(sc, cddr(expr)))
	    {
	      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_func1_arg(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;
  const s7_pointer num = slot_value(q_arg2(o).p);
  const s7_int index = integer(num);
  s7_pointer lst, p;
  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));
	  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, stype, 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, stype, expr, opc, start_pc));
		}
	      return_false(sc, expr);
	    }
	  {
	    const s7_pointer 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)))
	      {
		if (Opt_Print) fprintf(stderr, "    sig mismatch: %s %s, %s\n", display(stype), display(atype), display(target));
		return_false(sc, expr);
	      }}
	  if ((caddr(expr) == sc->T) || (caddr(expr) == sc->F))
	    {
	      q_arg2(opc).p = caddr(expr);
	      q_call(opc).fp = opt_set_p_c;
	      return_true(sc, expr);
	    }
	  /* atype here is usually pair? proper-list? symbol? string? #t etc -- rarely float? or int? occasionally boolean? */
	  /* fprintf(stderr, "atype: %s, stype: %s, expr: %s\n", display(atype), display(stype), display(expr)); */
	  if (cell_optimize(sc, cddr(expr)))
	    {
	      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_func1_arg(opc).o1 = sc->opts[sc->pc];
		      if (cell_optimize(sc, cddr(expr)))
			{
			  q_call(opc).fp = opt_starlet_set;
			  q_func(opc).fp = q_func1_arg(opc).q_call(o1).fp;
			  return_true(sc, expr);
			}}}}
	  return_false(sc, expr);
	}
      index_type = opt_arg_type(sc, cdr(target));
      switch (type(obj))
	{
	case T_STRING:
	  {
	    s7_pointer val_type;
	    if ((index_type != sc->is_integer_symbol) || (is_pair(cddr(target)))) return_false(sc, expr);
	    val_type = opt_arg_type(sc, cddr(expr));
	    if (val_type != sc->is_char_symbol)
	      return_false(sc, expr);
	    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))
	{
	  const 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)
{
  const 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 s7_pointer opt_cond_cc(opt_info *o)  /* 2 branches, results 1 expr, else, both opt_p_c */
{
  opt_info *o1 = (q_b_func1_call(o)) ? q_cond_val1(o).o1 : q_cond_val2(o).o1;
  return(q_arg1(o1).p); /* opt_p_c(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;
      const s7_pointer clause = car(clauses);
      s7_pointer 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;
	  if ((q_call(q_cond_val1(top).o1).fp == opt_p_c) && (q_call(q_cond_val2(top).o1).fp == opt_p_c)) q_call(top).fp = opt_cond_cc;
	  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 Inline s7_pointer inline_case_value(opt_info *o) /* hopefully this doesn't make s7_is_eqv paranoid below */
{
  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 case_value(opt_info *o) {return(inline_case_value(o));}
static s7_pointer no_no_value(s7_scheme *sc, s7_pointer val) {if (val == sc->no_value) return(sc->unspecified); return(val);}

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 = no_no_value(sc, q_call(o1).fp(o1));

  if (is_simpler(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 ((s7_Debugging) && (car(p) == sc->no_value)) fprintf(stderr, "%d: case key is #<no-value>!\n", __LINE__);
	      if (selector == car(p))  /* ok because keys can't be #<no-value>?? */
		return(case_value(o1));
	    }
	  /* according to callgrind, it is slower to pick out the single key cases here and avoid this loop; also a do loop here is slightly slower */
	  if (p == sc->else_symbol)
	    return(case_value(o1));
	}}
  else
#if !With_Gmp
    if (is_t_integer(selector))
      {
	const s7_int selint = integer(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 ((is_t_integer(car(p))) && (selint == integer(car(p))))
		return(case_value(o1));
	    if (p == sc->else_symbol)
	      return(inline_case_value(o1));
	  }}
    else
#endif
      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(inline_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_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 */
  {
    s7_int len = q_arg2(o).i - 1;
    s7_int i;
    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)
{
  const s7_pointer 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_slot_checked(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_slot_checked(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;
  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_slot_checked(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_slot_checked(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_slot_checked(slot1); slot1 = next_slot(slot1))
	if (has_stepper(slot1))
	  slot_set_value(slot1, slot_pending_value(slot1));
    }
  {
    s7_pointer 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, 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_slot_checked(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);
  {
    const s7_pointer 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, 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_slot_checked(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);
  {
    const s7_pointer 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);
  const 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))
	{
	  const 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
	    if (q_call(body).fp == opt_set_p_d_f_sf_add)
	      while (!q_call(ostart).fb(ostart))
		{
		  opt_set_p_d_f_sf_add(body);
		  set_integer(step_val, q_temp(ostep).fi(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);
  const 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);
  const 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;
  const 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)
{
  s7_pointer p;
  opt_info *o1 = do_stepper_init(o);
  const s7_pointer slot = let_slots(do_curlet(o));
  s7_scheme *sc = o->sc;
  s7_pointer (*fp)(opt_info *o);
  bool (*opt_do_fb)(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);
  opt_do_fb = do_end(o1).fb;
  fp = q_call(o1).fp;
  if (fp == opt_if_bp)
    {
      if ((opt_do_fb == opt_car_equal_sf) || (opt_do_fb == opt_car_equivalent_sf))
	{
	  bool (*equal_func)(s7_scheme *sc, s7_pointer x, s7_pointer y) = (opt_do_fb == opt_car_equal_sf) ? s7_is_equal : s7_is_equivalent;
	  const s7_pointer p1 = T_Slt(q_arg1(q_arg2(o1).o1).p); /* is this a safe assumption? "sf" above so p1 is symbol->slot and we use slot_value(p1) below */
	  while (!is_null(p = slot_value(slot)))
	    {
	      if ((s7_Debugging) && (p1 != q_arg1(q_arg2(o1).o1).p)) {fprintf(stderr, "%s[%d]: p1 or q_arg1 changed\n", __func__, __LINE__); abort();}
	      if (!is_pair(p))
		sole_arg_wrong_type_error_nr(sc, sc->car_symbol, p, sc->type_names[T_PAIR]);
	      if (equal_func(sc, slot_value(p1), car(p)))
		q_p_func1_call(o1);
	      slot_set_value(slot, cdr(p));
	    }}
      else
	while (!is_null(p = slot_value(slot)))
	  {
	    if (opt_do_fb(q_arg2(o1).o1)) /* breaking out vunion arg2 is slower */
	      q_p_func1_call(o1);
	    if (!is_pair(p))
	      sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, p, sc->type_names[T_PAIR]);
	    slot_set_value(slot, cdr(p));
	  }}
  else
    while (!is_null(p = slot_value(slot)))
      {
	fp(o1);
	if (!is_pair(p))
	  sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, p, sc->type_names[T_PAIR]);
	slot_set_value(slot, cdr(p));
      }
  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);
  const 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;
  const 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) /* tref */
	{ /* 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));
		  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;
	    const 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))
	    {
	      const s7_pointer ind = q_arg2(o1).p;
	      opt_info *o2 = do_any_body(o1);
	      s7_double (*fd)(opt_info *o) = q_call(o2).fd;
	      const s7_pointer fv = slot_value(q_arg1(o1).p);
	      if (fd == opt_d_7dd_ff_add_div)
		{
		  while (integer(vp) < end)
		    {
		      float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), opt_d_7dd_ff_add_div(o2));
		      integer(vp)++;
		    }}
	      else
		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)++;}}
            /* much overhead in block_set_d_7pid for immutable check, is correct object type checj, bounds check etc --
	     *   could we provide a Oft_d_pid_do or similar to run the loop in the loaded code (s7test.scm)? s7_set_d_7pid_do_function?
	     */
          /* 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);
  const 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;
  const 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));
}

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 do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer step_vars, bool *has_set);

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, init_pc, step_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 (Opt_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display(expr));

  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))
	    error_nr(sc, sc->duplicate_identifier_symbol, set_elist_2(sc, wrap_string(sc, "duplicate identifier in do: '~A", 31), sym));
	  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_slot_checked(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
		{
		  const s7_pointer sf = lookup_checked(sc, caadr(var));
		  if (is_c_function(sf))
		    {
		      const 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)))
	  {
	    const 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 <vars> <end> 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) &&
	      (is_unchanged_global(sc->car_symbol)) &&
	      (is_unchanged_global(sc->cdr_symbol)) &&
	      (do_passes_safety_check(sc, cdddr(expr), ind, vars, &has_set)))
	    /* s7test: (do ((b teq-vars (cdr b))) ((null? b)) (if (equal? vj (car b)) (if (not (eq? a b)) ...))) */
	    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, len: %d, func: %s\n", __LINE__, display(expr), len, display(func));
  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:
      if (len <= 2) return_false(sc, expr);
      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 s_func, s_slot = NULL;
  if (Opt_Print) fprintf(stderr, "     float_optimize[%d] %s\n", __LINE__, display(form));
  if (With_Gmp) return(false);

  if (!is_pair(expr)) /* wrap constants/symbols */
    return_bool(sc, opt_float_not_pair(sc, expr), expr);
  {
    const s7_pointer head = car(expr);
    if (is_symbol(head))
      {
	if ((is_syntactic_symbol(head)) ||
	    (is_syntactic_pair(expr)))
	  return_bool(sc, d_syntax_ok(sc, expr, s7_list_length(sc, expr)), 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);
      const s7_int len = s7_list_length(sc, expr);
      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, s7_list_length(sc, expr)), 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 s_func, s_slot = NULL;
  if (Opt_Print) fprintf(stderr, "     int_optimize %s\n", display(form));
  if (With_Gmp) return(false);

  if (!is_pair(expr)) /* wrap constants/symbols */
    return_bool(sc, opt_int_not_pair(sc, expr), expr);
  {
    const s7_pointer head = car(expr);
    const s7_int 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:
	    {
	      const 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 ((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)); /* 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)
{
  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 (With_Gmp) return(false);
  if (!is_pair(expr)) /* wrap constants/symbols */
    return(opt_cell_not_pair(sc, expr));
  head = car(expr);
  len = s7_list_length(sc, expr); /* len includes head */
  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)) 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:
	  {
	    const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
	    const s7_pointer sig1 = opt_arg_type(sc, cdr(expr));
	    const s7_pointer sig2 = opt_arg_type(sc, cddr(expr));
	    opt_info *opc = alloc_opt_info(sc);
	    const int32_t cur_index = sc->pc;

	    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;
	    
	    {
	      s7_b_7pp_t bpf7 = NULL;
	      const s7_b_pp_t 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 (With_Gmp) return(false);
  if (bool_optimize_nw(sc, expr))
    return_true(sc, expr);
  sc->pc = start;
  wrapper = sc->opts[start];
  if (!cell_optimize(sc, expr))
    return_false(sc, expr);
  if (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 (Opt_Print) fprintf(stderr, "   %s[%d]: %s\n", __func__, __LINE__, display(expr));
  if (With_Gmp) return_null(sc, expr);
  if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0))
    return_null(sc, expr);
  sc->pc = 0;
  if (!no_int_opt(expr))
    {
      if (int_optimize(sc, expr))
	return_success(sc, (nv) ? opt_int_any_nv : opt_make_int, expr);
      sc->pc = 0;
      set_no_int_opt(expr);
    }
  if (!no_float_opt(expr))
    {
      if (float_optimize(sc, expr))
	return_success(sc, (nv) ? opt_float_any_nv : opt_make_float, expr);
      sc->pc = 0;
      set_no_float_opt(expr);
    }
  if (!no_bool_opt(expr))
    {
      if (bool_optimize_nw(sc, expr))
	return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr);
      sc->pc = 0;
      set_no_bool_opt(expr);
    }
  if (cell_optimize(sc, expr))
    return_success(sc, (nv) ? opt_cell_any_nv : opt_wrap_cell, expr);
  set_no_cell_opt(expr); /* checked above */
  return_null(sc, expr);
}

s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr)           {return(s7_optimize_1(sc, expr, false));}
static s7_pfunc s7_optimize_nv(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, true));}

static s7_pointer g_optimize(s7_scheme *sc, s7_pointer args) /* s7-optimize in scheme */
{
  s7_pfunc func;
  const s7_pointer code = car(args);
  s7_pointer result = sc->undefined;
  if (Opt_Print) fprintf(stderr, "   %s[%d]: %s\n", __func__, __LINE__, display(args));
  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;
  s7_pointer slot2 = next_slot(slot1);
  bool more_vars;
  if (is_slot_checked(slot2)) slot3 = next_slot(slot2);
  more_vars = (is_slot_checked(slot3)) && (is_slot_checked(next_slot(slot3)));
  fx_tree(sc, code,
	  slot_symbol(slot1),
	  (is_slot_checked(slot2)) ? slot_symbol(slot2) : NULL,
	  (is_slot_checked(slot3)) ? slot_symbol(slot3) : NULL,
	  more_vars);
  {
    const s7_pointer outer_e = let_outlet(sc->curlet);
    if ((!more_vars) &&
	(is_let(outer_e)) &&
	(!is_funclet(outer_e)) &&
	(is_slot_checked(let_slots(outer_e))) &&
	(slot_symbol(let_slots(outer_e)) != slot_symbol(slot1)))
      {
	slot1 = let_slots(outer_e);
	slot2 = next_slot(slot1);
	slot3 = (is_slot_checked(slot2)) ? next_slot(slot2) : NULL;
	fx_tree_outer(sc, code,
		      slot_symbol(slot1),
		      (is_slot_checked(slot2)) ? slot_symbol(slot2) : NULL,
		      (is_slot_checked(slot3)) ? slot_symbol(slot3) : NULL,
		      (is_slot_checked(slot3)) && (is_slot_checked(next_slot(slot3))));
    }}
}

static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code)
{
  const s7_pointer slot1 = let_slots(sc->curlet);
  const s7_pointer slot2 = next_slot(slot1);
  const s7_pointer slot3 = (is_slot_checked(slot2)) ? next_slot(slot2) : NULL;
  fx_tree_in(sc, code,
	  slot_symbol(slot1),
	  (is_slot_checked(slot2)) ? slot_symbol(slot2) : NULL,
	  (is_slot_checked(slot3)) ? slot_symbol(slot3) : NULL,
	  (is_slot_checked(slot3)) && (is_slot_checked(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_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(fx_proc(fx_expr));
  if (bfunc)
    {
      set_opt3_any(cdr(form), bfunc);
      pair_set_syntax_op(form, op);
    }
}
/* when_b cond? do end-test? num_eq_vs|us */


/* ---------------------------------------- for-each ---------------------------------------- */
static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) /* Inline: 5 in tset, but fbench and tgc -5! */
{
  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 Mutable_Real_Limit 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 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 > Mutable_Real_Limit) &&
		    (!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 > Mutable_Real_Limit) &&
		      (!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 #<unspecified> */
      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 = 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, 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 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->unused)), 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++)
    {
      const 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))
		{
		  const 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)) || (is_byte_vector(vec)))
		  {
		    const s7_pointer iv = wrap_mutable_integer(sc, 0); /* make_mutable_integer? */
		    begin_temp(sc->x, iv);
		    if (is_int_vector(vec))
		      for (s7_int i = 0; i < vlen; i++) {set_integer(iv, int_vector(vec, i)); fp(sc, iv);}
		    else for (s7_int i = 0; i < vlen; i++) {set_integer(iv, byte_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);
	    }}
      {
	const 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->unused));
	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(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->unused)), 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 map_closure(s7_scheme *sc, s7_pointer clo, s7_pointer seq) /* one sequence argument */
{
  const s7_pointer body = closure_body(clo);
  /* set_car(sc->elist_7, seq); */
  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_byte_vector(seq))
		    {
		      const uint8_t *vals = byte_vector_bytes(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_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, 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, make_counter(sc, sc->v), clo);
  end_temp(sc->v);
  return(sc->nil);
}

static s7_pointer 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, 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 <safe f> ...)) e.g. f=append -> use safe_list for map output list here? also for (<safe-func> (map...))
   *   but less savings if mapped func would have used the same safe_list?
   */
  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)
		{
		  const s7_pointer str = cadr(args);
		  const char *s = string_value(str);
		  const s7_int slen = string_length(str);
		  if (fp == char_to_integer_p_p)
		    {
		      s7_int i = 0;
		      val = make_list(sc, slen, sc->nil);
		      for (s7_pointer p = val; i < slen; i++, p = cdr(p))
			set_car(p, small_int((uint8_t)(s[i])));
		      return(val);
		    }
		  val = list_1_unchecked(sc, sc->nil);
		  gc_protect_via_stack(sc, val);
		  for (s7_int i = 0; i < slen; 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->unused));
	    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 #<unused> or #<counter> */
			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(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, 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, 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);
}

/* s7 currently doesn't complain if the function changes the list:
 *    (let ((L (list 1 2 3))) (map (lambda (x) (set! (car L) x) x) L)) -- currently returns '(1 2 3), the mutation is harmless
 *    (let ((L (list 1 2 3))) (map (lambda (x) (set-cdr! L L) x) L)) -- '(1 2 3) as well
 *    (let ((L (list 1 2 3))) (map (lambda (x) (set-cdr!(cdr L) L) x) L)) -- '(1 2)
 */

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); /* continue */
    }
  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); /* goto Begin */
}

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); /* continue */
      }
    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); /* continue */
	}
      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)
    {
      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), 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); /* goto Eval */
}

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_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 Inline s7_pointer inline_apply_mv(s7_scheme *sc, bool use_safe) /* Inline here and below for .4 in tmv = ca 2.3% ?? inline isn't much better */
{
  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 sc->value = c_function_call(sc->code)(sc, sc->args);
  if (use_safe) clear_safe_list_in_use(sc, sc->args);
  return(sc->value);
}

static Inline s7_pointer inline_apply_mv_no_safe_list(s7_scheme *sc)
{
  sc->code = c_function_base(opt1_cfunc(sc->code));
  if (type(sc->code) == T_C_FUNCTION)
    return(apply_c_function_unopt(sc, sc->code, sc->args));
  return(c_function_call(sc->code)(sc, sc->args));
}

static s7_pointer splice_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(inline_apply_mv(sc, use_safe));
}

static s7_pointer splice_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 */
      {
	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));
	{
	  s7_pointer 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(inline_apply_mv(sc, use_safe));
}

static s7_pointer splice_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)); */
      {
	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));
	{
	  s7_pointer 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(inline_apply_mv(sc, use_safe));
}

static s7_pointer splice_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
      {
	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));
	{
	  s7_pointer 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(inline_apply_mv(sc, use_safe));
}

static s7_pointer splice_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(inline_apply_mv_no_safe_list(sc));
}

static s7_pointer splice_safe_c_aap_mv(s7_scheme *sc, s7_pointer args)
{
  set_car(sc->elist_7, copy_proper_list(sc, args));
  /* clear_multiple_value(args); */
  pop_stack_no_op(sc);
  sc->z = fx_call(sc, cddr(sc->code));
  sc->args = cons(sc, sc->z, car(sc->elist_7));
  sc->z = sc->unused;
  set_car(sc->elist_7, sc->unused);
  sc->args = cons_unchecked(sc, fx_call(sc, cdr(sc->code)), sc->args);
  /* fprintf(stderr, "%d: %s\n", __LINE__, display(sc->args)); */
  return(inline_apply_mv_no_safe_list(sc));
}

static s7_pointer splice_safe_c_sps_mv(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  begin_temp(sc->x, copy_proper_list(sc, args));
  pop_stack_no_op(sc); /* get sc->code */
  sc->args = cons(sc, lookup(sc, cadr(sc->code)), sc->x);
  end_temp(sc->x);
  for (p = sc->args; is_pair(cdr(p)); p = cdr(p));
  set_cdr(p, cons_unchecked(sc, lookup(sc, cadddr(sc->code)), sc->nil));
  return(inline_apply_mv_no_safe_list(sc));
}

static s7_pointer splice_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 splice_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)
    return(apply_c_function_unopt(sc, sc->code, sc->args));
  return(c_function_call(sc->code)(sc, sc->args));
}

static s7_pointer splice_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(inline_apply_mv_no_safe_list(sc));
}

static s7_pointer splice_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(inline_apply_mv_no_safe_list(sc));
}

static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arglist;
#if Eval_Print && s7_Debugging
  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)));
#endif
  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) <val>) where evaluation of <val> returned multiple values */
    case OP_EVAL_SET2_NO_MV: /* (set! (fnc <ind...>) <val>), <val> = mv */
    case OP_EVAL_SET3_NO_MV: /* (define f (dilambda (lambda () 1) (lambda (x) x))) (define (f2) (values 1 2 3)) (set! (f) (f2)) */
      syntax_error_nr(sc, "too many arguments to set!: ~S", 30, set_ulist_1(sc, sc->values_symbol, args));
    case OP_EVAL_SET2:       /* here <ind> = args is mv */
      set_stack_top_op(sc, OP_EVAL_SET2_MV);
      return(args); /* ?? */
    case OP_EVAL_SET3:       /* here <ind> = args is mv */
      set_stack_top_op(sc, OP_EVAL_SET3_MV);
      return(args); /* ?? */

    case OP_ANY_CLOSURE_NP_1: case OP_ANY_CLOSURE_NP_2:
      {
	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(splice_safe_c_sp_mv(sc, args));

    case OP_SAFE_C_PS_1:  return(splice_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(splice_safe_c_pc_mv(sc, args));    /* (define (f) (string (values #\a #\b #\c) #\d)) (f) */
    case OP_SAFE_C_PA_1:  return(splice_safe_c_pa_mv(sc, args));
    case OP_SAFE_C_AAP_1: return(splice_safe_c_aap_mv(sc, args));
    case OP_SAFE_C_SPS_1: return(splice_safe_c_sps_mv(sc, args));
    case OP_SAFE_C_P_1:   return(splice_safe_c_p_mv(sc, args));     /* (string (values #\a #\b #\c)) */
    case OP_C_P_1:        return(splice_c_p_mv(sc, args));          /* (let () (define (ho a) (values a 1)) (define (hi) (- (ho 2))) (hi)) */
    case OP_C_AP_1:       return(splice_c_ap_mv(sc, args));
    case OP_SAFE_C_PP_5:  return(splice_safe_c_pp_6_mv(sc, args));  /* (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) (also safe_c_pp_1) */

    case OP_SAFE_C_PP_1:                                            /* (define (f) (list (values 1 2) (values 3 4))) (f): args='(1 2), top_args=#<unused> */
      set_stack_top_op(sc, OP_SAFE_C_PP_3_MV);
      return(args);

    case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3:          /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 + 2 3 5)) */
      set_stack_top_op(sc, stack_top_op(sc) +  3); /* change op to parallel mv case */
    case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: /* (list-values '+ 1 (apply-values (list 2 3))) */
      return(splice_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_SP_1:             /* 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 && (Eval_Print == 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));
#endif
	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 Eval_Print && s7_Debugging
	    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)));
#endif
	    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_MV:
      /* 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 Eval_Print && s7_Debugging
	{
	  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;
	}
#endif
      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 Eval_Print && s7_Debugging
      fprintf(stderr, "  %s[%d]: splice gives up: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)]);
#endif
      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 */
  else
    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); /* 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 #<no-values> (see s7test) */
  /* but (list-values <circular-list>) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */

  s7_pointer 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 "<arg> unbound" (see tgen.scm).
   * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows
   *   everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro,
   *   and therefore have to copy the tree.  But isn't that only the case if the macro expands into closures?
   */
  return(splice_out_values(sc, args));
}

static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args)
{
  /* if just (code-)constant/symbol, symbol->pair won't be checked (not optimized/re-expanded code), but might be no-values */
  for (s7_pointer p = args; is_pair(p); p = cdr(p))
    if (car(p) == sc->no_value)
      return(splice_out_values(sc, args));
  if (is_immutable(args))
    return(copy_proper_list(sc, args));
  return(args);
}

static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer 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 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, 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, 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, quasiquote_1(sc, car(orig), false));
	set_car(bq, quasiquote_1(sc, car(orig), false));
	sc->w = list_3(sc, initial_value(sc->qq_append_symbol), sc->w, quasiquote_1(sc, cdr(orig), false));
	/* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */
      }
    {
      const s7_pointer result = sc->w;
      sc->w = old_scw;
      unstack_gc_protect(sc);
      return(result);
    }}
}

static s7_pointer g_quasiquote(s7_scheme *sc, s7_pointer args) /* this is for explicit quasiquote support, not the backquote stuff in macros */
{
  return(quasiquote_1(sc, car(args), true));
}

static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args)
{
  #define H_qq_append "<list*>: CL list* (I think) for quasiquote's internal use"
  #define Q_qq_append s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->T)

  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 void s7_function_set_class(s7_pointer func, s7_pointer base_f)
{
  c_function_class(func) = c_function_class(base_f);
  c_function_set_base(func, base_f);
}

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)
{
  const s7_pointer func = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL);
  s7_function_set_class(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)
{
  const s7_pointer func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL);
  s7_function_set_class(func, cls);
  c_function_set_signature(func, c_function_signature(cls));
  return(func);
}

static s7_pointer function_set_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr))
{
  const s7_pointer func = global_value(sym);
  c_function_chooser(func) = chooser;
  return(func);
}

s7_pointer s7_function_set_chooser(s7_scheme *sc, s7_pointer func, s7_chooser chooser) /* func = global_value(symbol) above, but we want this to work in libraries */
{
  c_function_chooser(func) = chooser;
  return(func);
}

static void init_choosers(s7_scheme *sc)
{
  s7_pointer func;

  /* + */
  func = function_set_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_2_ints = make_function_with_class(sc, func, "+", g_add_ii, 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 = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_chooser(sc->min_symbol, min_chooser);
  sc->min_2 = make_function_with_class(sc, func, "min", g_min_2, 2, 0, false);
  sc->min_3 = make_function_with_class(sc, func, "min", g_min_3, 3, 0, false);

  /* max */
  func = function_set_chooser(sc->max_symbol, max_chooser);
  sc->max_2 = make_function_with_class(sc, func, "max", g_max_2, 2, 0, false);
  sc->max_3 = make_function_with_class(sc, func, "max", g_max_3, 3, 0, false);

  /* < */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_chooser(sc->log_symbol, log_chooser);
  sc->int_log2 = make_function_with_class(sc, func, "log", g_int_log2, 2, 0, false);

  /* logior */
  func = function_set_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 = function_set_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 = function_set_chooser(sc->logxor_symbol, logxor_chooser);
  sc->logxor_2 = make_function_with_class(sc, func, "logxor", g_logxor_2, 2, 0, false);

  /* gcd */
  func = function_set_chooser(sc->gcd_symbol, gcd_chooser);
  sc->gcd_2 = make_function_with_class(sc, func, "gcd", g_gcd_2, 2, 0, false);

#if !With_Gmp
  /* ash */
  func = function_set_chooser(sc->ash_symbol, ash_chooser);
  sc->ash_ii = make_function_with_class(sc, func, "ash", g_ash_ii, 2, 0, false);
  sc->ash_ic = make_function_with_class(sc, func, "ash", g_ash_ic, 2, 0, false);
#endif

  /* random */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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);

  /* char<? */
  func = function_set_chooser(sc->char_lt_symbol, char_less_chooser);
  sc->char_less_2 = make_function_with_class(sc, func, "char<?", g_char_less_2, 2, 0, false);

  /* read-char */
  func = function_set_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);

  /* char-position */
  func = function_set_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 = function_set_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->substring_uncopied, global_value(sc->substring_symbol));

  /* string>? */
  func = function_set_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);

  /* string<? */
  func = function_set_chooser(sc->string_lt_symbol, string_less_chooser);
  sc->string_less_2 = make_function_with_class(sc, func, "string<?", g_string_less_2, 2, 0, false);

  /* string */
  func = function_set_chooser(sc->string_symbol, string_chooser);
  sc->string_c1 = make_function_with_class(sc, func, "string", g_string_c1, 1, 0, false);

  /* string-append */
  func = function_set_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 */
  function_set_chooser(sc->string_ref_symbol, string_substring_chooser);
  function_set_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here (not const char*??) */
  function_set_chooser(sc->string_to_keyword_symbol, string_substring_chooser);
  function_set_chooser(sc->string_downcase_symbol, string_substring_chooser);
  function_set_chooser(sc->string_upcase_symbol, string_substring_chooser);
  function_set_chooser(sc->string_position_symbol, string_substring_chooser);
  function_set_chooser(sc->string_geq_symbol, string_substring_chooser);
  function_set_chooser(sc->string_leq_symbol, string_substring_chooser);
  function_set_chooser(sc->string_copy_symbol, string_copy_chooser);
  function_set_chooser(sc->eval_string_symbol, string_substring_chooser);
  function_set_chooser(sc->symbol_symbol, string_substring_chooser);
  function_set_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
  function_set_chooser(sc->string_length_symbol, string_substring_chooser);
  function_set_chooser(sc->string_to_list_symbol, string_substring_chooser);
  function_set_chooser(sc->string_ci_eq_symbol, string_substring_chooser);
  function_set_chooser(sc->string_ci_geq_symbol, string_substring_chooser);
  function_set_chooser(sc->string_ci_leq_symbol, string_substring_chooser);
  function_set_chooser(sc->string_ci_gt_symbol, string_substring_chooser);
  function_set_chooser(sc->string_ci_lt_symbol, string_substring_chooser);
#endif
#if With_System_Extras
  function_set_chooser(sc->file_exists_symbol, string_substring_chooser);
#endif

  /* also: directory->list substring with-input-from-file with-input-from-string with-output-to-file open-output-file open-input-file
   *   system load getenv file-mtime gensym directory? call-with-output-file delete-file call-with-input-file call-with-input-string open-input-string
   *   length et al?
   */

  /* symbol->string */
  func = global_value(sc->symbol_to_string_symbol);
  sc->symbol_to_string_uncopied = s7_make_safe_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL);
  s7_function_set_class(sc->symbol_to_string_uncopied, func);

  /* symbol->value */
  func = global_value(sc->symbol_to_value_symbol);
  function_set_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 = function_set_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 = function_set_chooser(sc->write_symbol, write_chooser);
  sc->write_2 = make_function_with_class(sc, func, "write", g_write_2, 2, 0, false);

  /* write-char */
  func = function_set_chooser(sc->write_char_symbol, write_char_chooser);
  sc->write_char_c = make_function_with_class(sc, func, "write-char", g_write_char_c, 1, 0, false);

  /* vector */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_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", complex_wrapped, 2, 0, false); /* not used currently? */

  /* float-vector-ref */
  func = function_set_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 = function_set_chooser(sc->float_vector_set_symbol, float_vector_set_chooser);
  sc->fv_set_3 = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_3, 3, 0, false);
  sc->fv_set_unchecked = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_unchecked, 3, 0, false);

  /* int-vector-ref */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_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! */
  function_set_chooser(sc->hash_table_set_symbol, hash_table_set_chooser);

  /* hash-table */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_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 */
  function_set_chooser(sc->assoc_symbol, assoc_chooser);

  /* member */
  function_set_chooser(sc->member_symbol, member_chooser);

  /* memq */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_chooser(sc->outlet_symbol, outlet_chooser);
  sc->outlet_unlet = make_function_with_class(sc, func, "outlet", g_outlet_unlet, 1, 0, false);

  /* inlet */
  func = function_set_chooser(sc->inlet_symbol, inlet_chooser);
  sc->simple_inlet = make_function_with_class(sc, func, "inlet", g_simple_inlet, 0, 0, true);

  /* sublet */
  func = function_set_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 = function_set_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 = function_set_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 = function_set_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 = function_set_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, "#<restore-setter>", 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;
  const 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 + 1) * sizeof(int32_t));
  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));
    }
  {
    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_slot_checked(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;
		    }}}
	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 451
	    static const char *main_names[Main_Names_Size] = {
	      "<=", ">=", "gc", "if", "pi", "do", "or",
	      "cos", "not", "ash", "exp", "sym", "nan", "tan", "map", "gcd", "car", "max", "abs", "lcm", "cdr", "let", "min", "sin", "eq?", "and", "log",
	      "acos", "assv", "eval", "cons", "help", "let*", "list", "*s7*", "sqrt", "memq", "exit", "expt", "assq", "nan?", "when", "read", "odd?", "let?",
	        "load", "atan", "asin", "cond", "set!", "caar", "eqv?", "cadr", "cdar", "cddr", "tanh", "sinh", "case", "cosh", "copy", "memv", "else",
	      "error", "round", "inlet", "unlet", "throw", "owlet", "list?", "index", "atanh", "asinh", "assoc", "apply", "fill!", "even?", "angle", "pair?",
	        "char?", "caadr", "caddr", "cdadr", "cdddr", "bacro", "macro", "acosh", "zero?", "caaar", "cadar", "cdaar", "cddar", "goto?", "real?", "arity",
	        "byte?", "abort", "catch", "null?", "sort!", "write", "begin", "quote", "floor",
	      "define", "float?", "format", "vector", "bignum", "unless", "symbol", "values", "member", "lambda", "logxor", "system", "logand", "modulo",
	        "length", "char<?", "char=?", "append", "setter", "char>?", "caadar", "caddar", "cdadar", "cdddar", "exact?", "bacro*", "macro*", "string",
	        "equal?", "letrec", "getenv", "macro?", "caaaar", "cadaar", "gensym", "caaddr", "cdaaar", "cadddr", "cddaar", "varlet", "cdaddr", "cddddr",
	        "random", "logior", "caaadr", "cadadr", "cdaadr", "cddadr", "lognot", "sublet", "curlet", "cutlet", "outlet",
	      "letrec*", "complex", "unquote", "reverse", "string?", "let-ref", "gensym?", "require", "define*", "call/cc",
	        "newline", "char<=?", "vector?", "char>=?", "funclet", "display", "rootlet", "logbit?", "lambda*", "bignum?", "provide", "symbol?",
	        "iterate", "openlet", "ceiling", "syntax?", "type-of", "number?",
	      "quotient", "dilambda", "complex?", "reverse!", "string<?", "set-cdr!", "set-car!", "keyword?", "defined?",
	        "string>?", "integer?", "funclet?", "let-set!", "inexact?", "boolean?", "with-let", "openlet?", "truncate", "string=?",
	        "list-ref", "coverlet", "for-each",
	      "substring", "imag-part", "signature", "constant?", "remainder", "dilambda?", "read-byte", "read-char", "infinite?",
	        "sequence?", "magnitude", "peek-char", "char-ci>?", "iterator?", "numerator", "rational?", "char-ci=?", "subvector", "list-set!",
	        "negative?", "provided?", "string<=?", "char-ci<?", "real-part", "aritable?", "make-list", "read-line", "list-tail", "tree-memq",
	        "c-pointer", "let->list", "make-hook", "string>=?", "positive?", "c-object?", "port-file", "hash-code", "type-name", "expansion",
	      "int-vector", "write-char", "undefined?", "quasiquote", "make-polar", "stacktrace", "read-bytes", "write-byte", "c-pointer?", "hash-table", "profile-in",
	        "immutable!", "*function*", "immutable?", "string-ref", "char-ci>=?", "file-mtime", "expansion*",
		"subvector?", "char-ci<=?", "directory?", "tree-count", "procedure?", "vector-ref",
	      "object->let", "with-baffle", "make-string", "denominator", "tree-leaves", "vector-set!", "int-vector?", "vector-rank",
	        "eval-string", "hash-table?", "rationalize", "string-ci<?", "string-ci=?", "string-ci>?", "input-port?", "write-bytes",
		"macroexpand", "eof-object?", "port-string", "char-ready?", "cond-expand", "string-set!", "make-vector", "read-string",
		"char-upcase", "string-copy", "equivalent?", "nan-payload", "list-values", "reader-cond", "byte-vector", "delete-file",
	      "float-vector", "define-bacro", "symbol-table", "string-ci<=?", "list->string", "string-ci>=?", "apply-values", "file-exists?", "c-object-let",
	        "unspecified?", "define-macro", "string-fill!", "list->vector", "port-closed?", "tree-cyclic?", "dynamic-wind", "string->list", "byte-vector?",
		"write-string", "vector-fill!", "proper-list?", "random-state", "output-port?", "vector->list", "vector-typer", "goto-active?",
	      "string-append", "string-upcase", "port-position", "define-macro*", "tree-set-memq", "string-length", "vector-append", "documentation",
	        "char-downcase", "char->integer", "integer->char", "char-position", "c-object-type", "random-state?", "vector-length", "port-filename",
		"symbol->value", "char-numeric?", "float-vector?", "define-bacro*", "make-iterator", "pair-filename", "continuation?",
	      "hook-functions", "c-pointer-type", "exact->inexact", "c-pointer-info", "integer-length", "string->symbol", "symbol->string", "complex-vector",
	        "inexact->exact", "emergency-exit", "string->number", "number->string", "int-vector-ref", "dynamic-unwind", "object->string", "call-with-exit",
		"hash-table-ref",
	      "c-pointer-weak2", "directory->list", "symbol->keyword", "open-input-file", "c-pointer->list", "let-temporarily", "keyword->symbol",
	        "byte-vector-ref", "c-pointer-weak1", "string-position", "int-vector-set!", "make-int-vector", "hash-table-set!",
		"string->keyword", "weak-hash-table", "string-downcase", "define-constant", "complex-vector?", "make-hash-table",
	      "iterator-at-end?", "char-lower-case?", "subvector-vector", "procedure-source", "call-with-values", "close-input-port",
	        "make-byte-vector", "float-vector-ref", "char-alphabetic?", "make-rectangular", "cyclic-sequences", "port-line-number",
		"byte-vector-set!", "weak-hash-table?", "char-whitespace?", "open-output-file", "define-expansion", "char-upper-case?", "pair-line-number",
		"vector-dimension",
	      "open-input-string", "get-output-string", "iterator-sequence", "make-float-vector", "close-output-port", "flush-output-port",
	        "define-expansion*", "float-vector-set!", "procedure-arglist", "vector-dimensions",
	      "open-output-string", "substring-uncopied", "complex-vector-ref", "subvector-position", "hash-table-entries", "random-state->list",
	        "current-input-port", "current-error-port",
	      "string->byte-vector", "byte-vector->string", "multiple-value-bind", "complex-vector-set!", "open-input-function", "current-output-port",
	        "with-output-to-file", "make-complex-vector",
	      "with-input-from-file", "hash-table-key-typer", "symbol-initial-value", "make-weak-hash-table", "integer-decode-float", "open-output-function",
	        "call-with-input-file",
	      "with-output-to-string", "call-with-output-file", "symbol->dynamic-value",
	      "set-current-error-port", "call-with-input-string", "set-current-input-port", "hash-table-value-typer", "with-input-from-string",
	      "set-current-output-port", "call-with-output-string", NULL};

	    static const int32_t main_names_index[Leven_Max_Len] = {0, 7, 27, 62, 103, 156, 184, 206, 245, 269, 301, 327, 350, 367,
	                                                            386, 406, 416, 424, 432, 439, 442, 447, 449};

	    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: (use something like (string-upcass 1) to trigger this) */
	      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++)
	      {
		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 !With_System_Extras
	    if ((min_sym == sc->delete_file_symbol) || (min_sym == sc->system_symbol) || (min_sym == sc->file_exists_symbol) ||
#if !With_r7rs
		(min_sym == sc->getenv_symbol) ||
#endif
		(min_sym == sc->is_directory_symbol) || (min_sym == sc->directory_to_list_symbol) || (min_sym == sc->file_mtime_symbol))
	      {
		if (err_code)
		  error_nr(sc, sc->unbound_variable_symbol,
			   set_elist_4(sc, wrap_string(sc, "unbound variable ~S in ~S (With_System_Extras is off)", 53), sym, err_code, min_sym));
		error_nr(sc, sc->unbound_variable_symbol,
			 set_elist_3(sc, wrap_string(sc, "unbound variable ~S, (With_System_Extras is off)", 48), sym, min_sym));
	      }
	    else
#endif
	    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 #<unused> or #<counter>! */
      sc->code = code;
      set_curlet(sc, current_let);
      sc->temp7 = sc->unused;
      return(result);
    }
  return(sc->undefined);
}

static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
{
  const 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);
}

#if 1
#define choose_c_function(Sc, Expr, Func, Args) set_class_and_fn_proc(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr))
#else
static void choose_c_function(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t args)
{
  set_class_and_fn_proc(expr, c_function_chooser(func)(sc, func, args, expr));
  if (is_pair(cdr(expr)))
    {
      if (is_pair(cadr(expr)))
	{
	  if (caadr(expr) == sc->add_symbol) fprintf(stderr, "%s\n", display(expr));
	  if (caadr(expr) == sc->subtract_symbol) fprintf(stderr, "%s\n", display(expr));
	  if (caadr(expr) == sc->multiply_symbol) fprintf(stderr, "%s\n", display(expr));
	}}
}
#endif

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 (Eval_Print) 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)));
	  if (/* (!safe_case) && */ (one_form) && (is_code_constant(sc, car(body)))) /* safe_case is irrelevant here */
	    set_optimize_op(expr, hop + OP_THUNK_C);
	  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) /* inline: s7test 6, tgen 100 */
{
  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;
    const 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_slot_checked(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 (Eval_Print) 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); /* no fx_treeable here */
	  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);
	  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);
			}}
		  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))
    {
      const s7_pointer q = car(p);
      if ((is_pair(q)) &&
	  (is_optimized(q)))
	{
	  const 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
  if ((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));
#endif
  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)
{
  const s7_pointer arg1 = cadr(expr);
  if (Eval_Print) 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_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) || (g == g_add_ii)) ? 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?
   */
  /* fprintf(stderr, "%s %s\n", display(func), display(expr)); */
  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_closure_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, s7_pointer let_or_list)
{
  const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr), arg2 = caddr(expr);
  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;

  {
    const s7_pointer body = closure_body(func);
    const bool one_form = is_null(cdr(body));
    const bool 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);
}

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 (Eval_Print) 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(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 (is_fx_treeable(expr)) fprintf(stderr, "%d: check %s\n", __LINE__, display_truncated(expr)); */
	      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(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(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(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(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(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(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) ? 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))
    return(optimize_closure_two_args(sc, expr, func, hop, pairs, symbols, let_or_list));

  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(arg3)) && (is_pair(arg2)) && ((!is_symbol(car(arg2))) || (!is_definer(car(arg2)))))
	    {
	      set_opt3_sym(expr, arg3);
	      set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SPS);
	      choose_c_function(sc, expr, func, 3);
	      return(Opt_Bad);
	    }
	  if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2)) && (is_pair(arg3)) && /* (!is_pair(car(arg3))) && */
	      ((!is_symbol(car(arg3))) || /* c_function via #_*? */
	       ((!is_definer(car(arg3))) &&
		(car(arg3) != sc->quote_symbol)))) /* if quote -- not "P" in eval terms but "C" */
	    {
	      set_opt3_pair(expr, arg3);
	      set_unsafe_optimize_op(expr, hop + OP_SAFE_C_AAP);
	      fx_annotate_arg(sc, arg1p, let_or_list);
	      fx_annotate_arg(sc, cddr(expr), let_or_list);
	      choose_c_function(sc, expr, func, 3);
	      if ((func == initial_value(sc->list_values_symbol)) && (is_pair(arg3)) && (is_pair(cdr(arg3))) &&
		  (car(arg3) == initial_value(sc->apply_values_symbol)) && (is_symbol(cadr(arg3))))
		/* (let () (define (func) (#_list-values 1 #_+ (#_apply-values))) (func)) */
		set_unsafe_optimize_op(expr, OP_SAFE_C_AAP_2);
	      return(Opt_Bad);
	    }
	  /* apa and paa: few or no hits outside s7test, tload(paa), make-index, tgen(apa), snd-test; overall apa 3026, paa 895, none amount to much in callgrind */
	  /* fprintf(stderr, "%d: %s\n",__LINE__, display(expr)); */
	  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) ? 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_pointer orig_e, s7_pointer var_list)
{
  for (s7_pointer p = var_list; ((is_pair(p)) && (p != orig_e)); p = cdr(p))
    {
      const 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 Eval_Print && s7_Debugging
  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);
#endif
  sc->w = let_or_list;
  switch (op)
    {
    case OP_QUOTE:
    case OP_MACROEXPAND:
      if (is_proper_list_1(sc, body))
	{
	  cleanup_big_symbol_set(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(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(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 ((Eval_Print) && (!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(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(init_let_or_list, let_or_list);
	  return(Opt_Ok);
	}
      cleanup_big_symbol_set(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(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(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(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(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(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(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(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(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(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(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)) > T_FREE) && (is_defined_global(caadr(expr))) &&
			  ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > T_FREE) && (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(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(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(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(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(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(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(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 (Eval_Print) 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 (Eval_Print) 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 (Eval_Print) 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 '(<par> :allow-other-keys) so this chops off the trailing keyword */
	      }
	    if (symbol_is_in_small_symbol_set(sc, cur_par))     /* (lambda* ((a 1) a) 1) */
	      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))) /* (lambda* (a . a) 1) */
	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;
#define Not_At_End false
#define At_End true
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, s7_pointer goto_name);

static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer form, bool at_end, s7_pointer goto_name) /* 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, goto_name));

	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), Not_At_End, goto_name);
	      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, goto_name));
	      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, goto_name)));
	  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), Not_At_End, goto_name);
	      if (result == Unsafe_Body) return(Unsafe_Body);
	    }
	  return(min_body(result, body_is_safe(sc, func, cddr(form), at_end, goto_name)));

	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), Not_At_End, goto_name));
		    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, goto_name));
		    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), Not_At_End, goto_name);
		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, goto_name)); /* 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), Not_At_End, goto_name);
	      if (result == Unsafe_Body) return(Unsafe_Body);
	    }
	  return((is_pair(cadr(form))) ? min_body(result, form_is_safe(sc, func, cadr(form), Not_At_End, goto_name)) : 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, goto_name), 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), Not_At_End, goto_name));
		  if (result == Unsafe_Body) return(Unsafe_Body);
		}}
	  return(min_body(result, body_is_safe(sc, sc->F, cddr(form), at_end, goto_name)));

	  /* 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:
	  {
	    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;
	    {
	      bool follow = false;
	      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), Not_At_End, goto_name));
		      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, goto_name)));
	  }

	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), Not_At_End, goto_name));
		  if ((is_pair(cddr(do_var))) && (is_pair(caddr(do_var))))
		    result = min_body(result, form_is_safe(sc, func, caddr(do_var), Not_At_End, goto_name));
		  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, goto_name));
	  return(min_body(result, body_is_safe(sc, func, cdddr(form), Not_At_End, goto_name)));

	  /* 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), Not_At_End, goto_name));
		  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;
	  bool c_safe;

	  if (expr == goto_name)
	    {
	      if (!is_pair(cdr(form))) return(Recur_Body);  /* (call-with-exit (lambda (go) (go))) -> () */
	      if (is_pair(cddr(form))) return(Unsafe_Body); /* implicit values -- is this actually safe? */
	      if (!is_pair(cadr(form))) return(Recur_Body);
	      result = min_body(Recur_Body, form_is_safe(sc, func, cadr(form), Not_At_End, NULL)); /* goto_name isn't safe here */
	      /* fprintf(stderr, "  result: %d, %s\n", (int)result, display(form)); */
	      return(result);
	    }

	  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 */

	  if (expr == sc->call_with_exit_symbol)
	    {
	      if ((is_pair(cdr(form))) && (is_pair(cadr(form))) && (is_pair(cdadr(form))) && (is_pair(cadadr(form))) && (is_symbol(caadr(cadr(form)))))
		result = body_is_safe(sc, func, cddadr(form), at_end, caadr(cadr(form)));
	      else result = Unsafe_Body;
	      /* fprintf(stderr, "  result: %d, %s\n", (int)result, display(form)); */
	      return(result);
	    }

	  {
	    const s7_pointer 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 <safe_c_function> ...) */
		  {
		    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, Not_At_End, goto_name);
			  result = min_body(result, lresult);
			}
		      else result = min_body(result, form_is_safe(sc, func, car(p), Not_At_End, goto_name));
		      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), Not_At_End, goto_name)) : 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, s7_pointer goto_name)
{
  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))), goto_name));
	  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, s7_pointer goto_name)
{
  body_t result;
  begin_small_symbol_set(sc);
  result = body_is_safe(sc, func, body, at_end, goto_name);
  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))))
	{
	  /* (and (pair? tree) (or (equal? (car tree) sym) (tm1 sym (car tree)) (tm1 sym (cdr tree)))) */
	  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))))
				{
				  /* (cond ((= m 0) (+ n 1)) ((= n 0) (recur-cond-a-a-a-l2a-opa-l2aq-1 (- m 1) 1))
				   *   (else (+ (- m 1) (recur-cond-a-a-a-l2a-opa-l2aq-1 m (- n 1)))))
				   */
				  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))))))
				{
				  /* (cond ((null? x) ()) ((not (pair? x)) (list x)) (#t (append (flatten (car x)) (flatten (cdr x))))) */
				  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))))
				  {
				    /* (cond ((= x 0) y) ((negative? y) x) (else (+ 1 (recur-cond-a-a-a-a-opa-l2aq-1 (- x 1) (+ y 1))))) */
				    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))))
				{
				  /* (cond ((= m 0) (+ n 1)) ((= n 0) (recur-cond-a-a-a-l2a-lopa-l2aq-1 (- m 1) 1))
				   *   (else (recur-cond-a-a-a-l2a-lopa-l2aq-1 (- m 1) (recur-cond-a-a-a-l2a-lopa-l2aq-1 m (- n 1)))))
				   */
				  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);        /* (when (> x 0) (display x #f) (tc-when-la4 (- x 1))) */
		}
	      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); /* (when (> x 0) (display x #f) (tc-when-l2a4 (- x 1) y)) */
		      }
		    else
		      if ((pars == 3) && (is_fxable(sc, cadddr(l2a))) && (is_null(cddddr(l2a))))
			set_safe_optimize_op(body, OP_TC_WHEN_L3A); /* (when (> x 0) (when_l3a (- x 1) (- y 2) (+ z 1))) */
		      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 num_clauses;
  const s7_int pars = proper_list_length(arg_names);
  bool got_else = false, results_fxable = true;
  for (clauses = cddr(body), num_clauses = 0; is_pair(clauses); clauses = cdr(clauses), num_clauses++)
    {
      const s7_pointer clause = car(clauses);
      s7_pointer result;
      if (is_proper_list_1(sc, car(clause)))   /* one key */
	{
	  if (!is_simple(caar(clause)))        /* or maybe (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);
  /* (case (car x) ((#\a) 1) ((#\b) 2) (else (tc-case-1 (cdr x)))) */
  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), num_clauses);
  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);
    }
  /* (cond ((= x 1) (+ x y)) ((= x 2) (tc-cond-n6 (- x 1) (+ y 2))) ((= y 0) x) ((= x 0) y) (#t (tc-cond-n6 (- x 1) (+ y 1)))) */
  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));
		      /* (cond ((zero? x) 3) (else (tc-cond-a-z-la-1 (- x 1)))) */
		      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));
			  /* (cond ((pair? (cdr p)) (cond-a-la-z (cdr p))) (else (car p))) */
			  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))))
		{
		  /* (cond ((= x 1) (+ x y)) ((= x 2) (tc-cond-n5 (- x 1) (+ y 1))) (else (tc-cond-n5 (- x 1) (+ y 1)))) */
		  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); /* (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-1 (+ x 1)))) */
		      else
			{
			  /* (cond ((< 20 x 30) (+ (* x 2) 1)) ((<= x 20) (tc-cond-a-z-a-la-z-13 (+ x 1))) (else (* x 2))) */
			  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); /* (cond ((= x 0) y) ((= y 100) y) (else (tc-cond-a-z-a-z-l2a-1 (- x 1) (+ y 1)))) */
		      }
		    else
		      {
			set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L2A_Z); /* (cond ((= x 0) y) ((not (= y 100)) (tc-cond-a-z-a-l2a-z-1 (- x 1) (+ y 1))) (else y)) */
			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)); /* only call */

  /* 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: (define (f) (set-car! '(#1=(1 2 3 0.0+nan.0i . #1#) 1) patchwork)) but I'm missing context here */
  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, "%s[%d]: body is circular: %s\n", __func__, __LINE__, display(body)); abort();}
      set_is_fx_treeable(body);
      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 (Eval_Print) 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, At_End, NULL);  /* (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 (result >= Recur_Body) mark_fx_treeable(sc, body); */ /* no good because curlet is not correct yet */

      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); /* not sure about this or fx_tree below -- curlet seems premature t903.scm or s7test.scm 27202 */
	    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 <a> #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 */
  const s7_pointer code = cdr(form);
  s7_pointer body;
  int32_t arity = 0;

  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);
  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));

  /* 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) || /* => has no associated value normally */
	  (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(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(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, ((!With_Gmp) && (key_type == T_INTEGER)) ? OP_CASE_A_I_S : OP_CASE_A_G_S);
	    set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe));
	    if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code);
	  }
	else pair_set_syntax_op(form, ((!With_Gmp) && (key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S);
      }
    else              /* x_e_s */
      if (is_fxable(sc, car(code)))
	{
	  pair_set_syntax_op(form, OP_CASE_A_E_S);
	  set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe));
	  if ((is_fx_treeable(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) || ((!With_Gmp) && (op == OP_CASE_A_I_S)))
	{
	  pair_set_syntax_op(form,
			     (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A :
			       ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A :
				 ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A)));
	  for (s7_pointer clauses = cdr(code); is_pair(clauses); clauses = cdr(clauses))
	    {
	      s7_pointer clause = cdar(clauses);
	      fx_annotate_args(sc, clause, sc->curlet);
	      if ((is_fx_treeable(clause)) && (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);
  }
}

#if !With_Gmp
static bool op_case_i_s(s7_scheme *sc)
{
  const s7_pointer selector  = sc->value;
  const s7_pointer else_clause = opt3_any(cdr(sc->code));
  if (else_clause != sc->unspecified)
    {
      if (is_t_integer(selector))
	{
	  const s7_int val = integer(selector);
	  for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses))
	    if (integer(opt2_any(clauses)) == val)
	      {
		sc->code = opt1_clause(clauses);
		return(false);
	      }}
      sc->code = else_clause;
      return(false);
    }
  if (is_t_integer(selector))
    {
      const s7_int val = integer(selector);
      for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses))
	if (integer(opt2_any(clauses)) == val)
	  {
	    sc->code = opt1_clause(clauses);
	    return(false);
	  }}
  sc->value = sc->unspecified;
  return(true);
}

static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inline saves about 30 in tleft */
{
  const s7_pointer selector = fx_call(sc, cdr(code));
  if (is_t_integer(selector))
    {
      const s7_int val = integer(selector);
      for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses)) /* code = (case ...) */
	if (integer(opt2_any(clauses)) == val)
	  return(fx_call(sc, cdar(clauses)));
    }
  return(fx_call(sc, opt3_any(cdr(code))));
}
#endif

static bool op_case_e_g_1(s7_scheme *sc, const s7_pointer selector, bool ok)
{
  s7_pointer clauses;
  if (ok)
    {
      for (clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses))
	{
	  s7_pointer keys = opt2_any(clauses);
	  if (!is_pair(keys)) /* i.e. else? */
	    goto Else_Case_1;
	  do {
	    if (car(keys) == selector)
	      goto Else_Case_1;
	    keys = cdr(keys);
	  } while (is_pair(keys));
	}
      sc->value = sc->unspecified;
      pop_stack(sc);
      return(true);
    }

  sc->code = opt3_any(cdr(sc->code));
  if (sc->code == sc->unused)    /* set in check_case if no else clause */
    sc->value = sc->unspecified;
  else
    if (is_pair(sc->code))
      goto Else_Case_2;
  pop_stack(sc);
  return(true);

 Else_Case_1:
  /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) */
  sc->code = T_Lst(cdar(clauses));
  if (is_null(sc->code))  /* sc->value is already the selector */
    {
      pop_stack(sc);
      return(true);
    }

 Else_Case_2:
  if (is_null(cdr(sc->code)))
    {
      sc->code = car(sc->code);
      sc->cur_op = optimize_op(sc->code);
      return(true);
    }
  if (is_undefined_feed_to(sc, car(sc->code)))
    return(false);

  push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
  sc->code = car(sc->code);
  sc->cur_op = optimize_op(sc->code);
  return(true);
}

static inline s7_pointer fx_call_all(s7_scheme *sc, s7_pointer code) /* inline = 10 in tleft */
{
  s7_pointer p;
  for (p = code; is_pair(cdr(p)); p = cdr(p))
    fx_call(sc, p);
  return(fx_call(sc, p));
}

static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code)
{
  const s7_pointer selector = fx_call(sc, cdr(code));
  if (is_case_key(selector))
    for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses))
      {
	s7_pointer keys = opt2_any(clauses);
	if (!is_pair(keys)) /* i.e. else? */
	  return(fx_call_all(sc, cdar(clauses))); /* else clause */
	do {
	  if (car(keys) == selector)
	    return(fx_call_all(sc, cdar(clauses)));
	  keys = cdr(keys);
	} while (is_pair(keys));
      }
  return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */
}

#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code);
#define if_pair_set_up_begin_unchecked(Sc) if (is_pair(cdr(Sc->code))) push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code)); Sc->code = car(Sc->code);
/* using the one_form bit here was slower */

static bool op_case_g_g(s7_scheme *sc)
{
  s7_pointer clauses;
  if (has_integer_keys(sc->code))
    {
      s7_int selector;
      sc->code = cddr(sc->code);
      if (is_t_integer(sc->value))
	selector = integer(sc->value);
      else
	{
#if With_Gmp
	  if ((is_t_big_integer(sc->value)) && (mpz_fits_slong_p(big_integer(sc->value))))
	    selector = mpz_get_si(big_integer(sc->value));
	  else
#endif
	    {
	      for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses))
		if (!is_pair(caar(clauses)))
		  goto Else_Case;
	      sc->value = sc->unspecified;
	      pop_stack(sc);
	      return(true);
	    }}
      for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses))
	{
	  s7_pointer keys = caar(clauses);
	  if (!is_pair(keys))
	    goto Else_Case;
	  for (; is_pair(keys); keys = cdr(keys))
	    if (integer(car(keys)) == selector)
	      goto Else_Case;
	}
      sc->value = sc->unspecified;
      pop_stack(sc);
      return(true);
    }
  if (sc->value == sc->no_value) sc->value = sc->unspecified; /* ok because keys can't be #<no-value>?? */
  sc->code = cddr(sc->code);
  if (is_simpler(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 ((s7_Debugging) && (car(keys) == sc->no_value)) fprintf(stderr, "%d: case key is #<no-value>!: %s\n", __LINE__, display(sc->code));
	    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->duplicate_identifier_symbol,
		   set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: '~S in ~S", 38), 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), At_End, NULL) >= 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_slot_checked(slot2))
	{
	  if (is_slot_checked(next_slot(slot2)))
	    {
	      slot3 = next_slot(slot2);
	      more_vars = is_slot_checked(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 OP_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_is_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);
  const 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);
  const 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)); /* not fx_curlet_tree here */
      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), At_End, NULL) >= 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))
	error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "~A: duplicate identifier: '~A", 29), 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)); /* not fx_curlet_tree here */
  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_slot_checked(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_slot_checked(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 #<undefined>
   *   get parallel list of values
   *   eval each member of values list with let still full of #<undefined>'s
   *   assign each value to its variable
   *   eval body
   * which means that (letrec ((x x)) x) is not an error -- it is #<undefined>.
   * 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_slot_checked(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
	slot_set_pending_value(slot, fx_call(sc, slot_expression(slot)));
      if (is_slot_checked(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_slot_checked(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
    slot_set_pending_value(slot, fx_call(sc, slot_expression(slot)));
  if (is_slot_checked(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 #<undefined>
   * eval each member of values list and assign immediately, as in let*
   * eval body
   */
  set_curlet(sc, make_let(sc, sc->curlet));
  if (is_pair(car(code)))
    {
      s7_pointer slot;
      for (s7_pointer 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_slot_checked(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
	slot_set_value(slot, fx_call(sc, slot_expression(slot)));
      if (is_slot_checked(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_slot_checked(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
    slot_set_value(slot, fx_call(sc, slot_expression(slot)));
  if (is_slot_checked(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 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);
	}
      {
	const 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_3(sc, Immutable_Error_String, sc->let_temporarily_symbol, settee));
	if (is_symbol(new_value))
	  new_value = lookup_checked(sc, new_value);
	slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, new_value) : new_value);
      }}
  set_car(sc->args, cadr(sc->args));
  /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */
  unstack_gc_protect(sc);         /* pop_stack_no_args(sc) in effect */
  sc->code = cdr(stack_end_code(sc));
  if (is_pair(sc->code))
    {
      push_stack_direct(sc, OP_LET_TEMP_DONE);
      return(Goto_Begin);
    }
  sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */
  return(Fall_Through);
}

static bool op_let_temp_done1(s7_scheme *sc)
{
  while (is_pair(car(sc->args)))
    {
      const s7_pointer settee = caar(sc->args), p = cddr(sc->args);
      sc->value = caar(p);
      set_car(p, cdar(p));
      set_car(sc->args, cdar(sc->args));

      if ((is_pair(settee)) && (car(settee) == sc->starlet_symbol) &&  /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */
	  ((is_symbol_and_keyword(cadr(settee))) ||
	   (is_quoted_symbol(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);
	}
      else
	{
	  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);
	      /* fprintf(stderr, "%s[%d]: code: %s\n", __func__, __LINE__, display(sc->code)); */
	      return(false); /* goto Set_Unchecked */
	    }
	  {
	    const s7_pointer slot = s7_t_slot(sc, settee);
	    if (is_immutable_slot(slot))      /* (let ((x 1) (y 0)) (let-temporarily ((y x)) (immutable! 'y)) x) */
	      immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily can't restore ~S; it has become immutable!", 58), settee));
	    if (slot_has_setter(slot))        /* maybe setter changed in let-temp body? else setter has already checked the init value */
	      slot_set_value(slot, call_setter(sc, slot, sc->value));
	    else slot_set_value(slot, sc->value);
	  }}}
  pop_stack(sc); /* not unstack */
  sc->value = sc->code;
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
  return(true);          /* goto Start */
}

static bool *starlet_immutable_field = NULL;

static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */
{
  const s7_pointer code = cdr(sc->code); /* don't use sc->code here -- it can be changed */
  s7_pointer *end = sc->stack_end;
  for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars))
    {
      s7_pointer old_value;
      const s7_pointer field = cadadr(caar(vars)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */
      if (starlet_immutable_field[starlet_symbol_id(field)])
	immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field));
      old_value = starlet(sc, starlet_symbol_id(field));
      /* check_stack_size(sc); */ /* t101-42 but commented out (probably the #symbol stuff) */
      push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field);
    }
  for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars), end += 4)
    starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(vars)));
  sc->code = cdr(code);
  return(is_pair(sc->code)); /* sc->code can be null if no body */
}

static void op_let_temp_s7_unwind(s7_scheme *sc)
{
  starlet_set_1(sc, T_Sym(sc->code), sc->args);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

static bool op_let_temp_s7_openlets(s7_scheme *sc)
{
  s7_pointer new_val;
  push_stack_no_code(sc, OP_LET_TEMP_S7_OPENLETS_UNWIND, (sc->has_openlets) ? sc->T : sc->F);
  new_val = fx_call(sc, opt1_pair(sc->code));
  sc->has_openlets = (new_val != sc->F);
  sc->code = cddr(sc->code); /* cddr is body of let-temp */
  return(is_pair(sc->code));
}

static void op_let_temp_s7_openlets_unwind(s7_scheme *sc)
{
  sc->has_openlets = (sc->args != sc->F);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let)
{
  /* called in call/cc, call-with-exit and, catch (unwind to catch) */
  check_stack_size(sc);
  push_stack_direct(sc, OP_GC_PROTECT);
  sc->args = T_Ext(args);
  set_curlet(sc, let);
  if (!op_let_temp_done1(sc)) /* (let-temporarily (((V 0) 1)) ... (throw|call-with-exit...)) */
    {
      /* fprintf(stderr, "%s[%d]: args: %s, let: %s, code: %s\n", __func__, __LINE__, display(args), display(let), display(sc->code)); */
      /* it's non-trivial to do the eval work here via set_implicit and so on */
      push_stack_op(sc, OP_EVAL_DONE);
      eval(sc, OP_SET_UNCHECKED);
    }
}

static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value)
{
  if (slot_has_setter(slot)) /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */
    {
      s7_pointer old_value = sc->value;
      slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */
      sc->value = old_value;
    }
  else slot_set_value(slot, new_value);
}

static void op_let_temp_unwind(s7_scheme *sc)
{
  let_temp_unwind(sc, sc->code, sc->args);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */
{
  s7_pointer *end = sc->stack_end;
  sc->code = cdr(sc->code);

  for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars))
    {
      const s7_pointer var = car(vars);
      const s7_pointer settee = car(var);
      const s7_pointer slot = s7_slot(sc, settee);
      if (!is_slot(slot)) unbound_variable_error_nr(sc, settee);
      if (is_immutable_slot(slot))
	immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->let_temporarily_symbol, settee));
      push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot);
    }
  for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars), end += 4)
    {
      const s7_pointer var = car(vars);
      const 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);
  {
    const 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 unused_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);
    }
}

static bool t_lookup_ok(s7_scheme *sc, s7_pointer code, s7_pointer symbol)
{
  return((is_fx_treeable(code)) &&
	 (curlet_has_slots(sc)) &&
	 (symbol == slot_symbol(let_slots(sc->curlet))));
}

#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 > T_FREE)
		{
		  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) || (optimize_op(form) == OP_IF_IS_TYPE_S_R)) &&
		      (t_lookup_ok(sc, code, cadar(code))))
		    {
		      /* if (s7_Debugging) fprintf(stderr, "use if_t_p: %s\n", display(code)); */
		      pair_set_syntax_op(form, (optimize_op(form) == OP_IF_IS_TYPE_S_P) ? OP_IF_IS_TYPE_T_P : OP_IF_IS_TYPE_T_R);
		      fx_curlet_tree(sc, code);
		    }
		  else
		    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 (t_lookup_ok(sc, code, cadar(code)))
				  pair_set_syntax_op(form, OP_IF_IS_TYPE_T_P_A);
			      }
			    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 (t_lookup_ok(sc, code, cadar(code)))
				pair_set_syntax_op(form, OP_IF_IS_TYPE_T_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); /* false = not reversed */
  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) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */
  if (is_pair(sc->code))
    return(true);
  sc->value = (is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code;
  return(false);
}


/* -------------------------------- when -------------------------------- */
static void check_when(s7_scheme *sc)
{
  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, true = one_branch, false = not reversed */
  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 ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code);
	    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); /* true = one_branch, true = reversed */
  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));
	  if ((is_fx_treeable(code)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, code);
	}
  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);
  /* fprintf(stderr, "check_define: %s\n", display(sc->code)); */
  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, s7_Warn_Bufsize, "%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, s7_Warn_Bufsize, "%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); /* T_Funclet only here */
  let_set_id(new_let, ++sc->let_number);
  let_set_outlet(new_let, outer_let);
  closure_set_let(new_func, new_let);
  set_is_funclet(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_slot_checked(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);
      const s7_pointer value = slot_value(slot);
      if ((is_string(value)) && (is_wrapper(value)))
	{
	  /* currently only strings here, if wrapped value can change as wrapper is reused! */
	  /*  PERHAPS: c_pointer wrapped if from C? can the others happen in this context (not numbers surely?) */
	  const s7_pointer dest = make_string_with_length(sc, string_value(value), string_length(value));
	  if (s7_Debugging) fprintf(stderr, "%s[%d]: %s is wrapped\n", __func__, __LINE__, display(slot));
	  set_immutable(dest); /* ?? */
	  slot_set_value(slot, dest);
	}
      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_slot_checked(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, s7_Warn_Bufsize, "%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) */
  /* if unknown_any returns true, see below for fast? path */
  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); /* if (eval_args_no_eval_args(sc)) goto Apply; goto Top_No_Pop; */
  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);
      set_is_funclet(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 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_call_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_is_expansion(symbol);
      else
	{
	  /* call the reader macro */
	  sc->args = cdr(sc->value);
	  push_stack_no_code(sc, OP_EXPANSION_MV, sc->nil);
	  if (is_c_macro(sc->code))
	    {
	      check_c_macro_args(sc, 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); /* PERHAPS: apply_lambda_unchecked */
	  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->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 OP_APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION_MV(?)
   *   (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3))
   */
  if ((!is_pair(sc->code)) ||
      (!is_pair(car(sc->code))))
    syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, form);
  if (!is_null(cdr(sc->code)))
    syntax_error_nr(sc, "macroexpand: too many arguments: ~A", 35, form);

  if (is_pair(caar(sc->code)))                            /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
    {
      push_stack_no_args_direct(sc, OP_MACROEXPAND_1);
      sc->code = caar(sc->code);
      return(Goto_Eval);
    }
  sc->args = cdar(sc->code);
  if (!is_list(sc->args))                                  /* (macroexpand (mac . 7)) */
    syntax_error_nr(sc, "can't macroexpand ~S: the macro's argument list is not a list", 61, car(sc->code));

  if (!is_symbol(caar(sc->code)))
    {
      if (!is_any_macro(caar(sc->code)))
	syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code);
      sc->code = caar(sc->code);
      return(macroexpand(sc));
    }
  sc->code = lookup_checked(sc, caar(sc->code));
  return(macroexpand(sc));
}

static goto_t op_macroexpand_1(s7_scheme *sc)
{
  sc->args = cdar(sc->code);
  sc->code = sc->value;
  return(macroexpand(sc));
}

static void op_eval_macro(s7_scheme *sc) /* after (scheme-side) macroexpansion, evaluate the resulting expression */
{
  /* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */
  if (is_multiple_value(sc->value))
    {
      /* a normal macro's result is evaluated (below) and its value replaces the macro invocation,
       *   so if a macro returns multiple values, evaluate each one, then replace the macro
       *   invocation with (apply values evaluated-results-in-a-list).  We need to save the
       *   new list of results, and where we are in the macro's output list, so code=macro output,
       *   args=new list.  If it returns (values), should we use #<unspecified>?  I think that
       *   happens now without generating a multiple_value object:
       *       (define-macro (hi) (values)) (hi) -> #<unspecified>
       *   (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19
       *   (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3
       */
      push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value));
      sc->code = car(sc->value);
    }
  else sc->code = sc->value;
}

static bool op_eval_macro_mv(s7_scheme *sc)
{
  if (is_null(sc->code)) /* end of values list */
    {
      sc->value = splice_in_values(sc, multiple_value(proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args))));
      return(true);
    }
  push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), cdr(sc->code));
  sc->code = car(sc->code);
  return(false);
}

static void op_finish_expansion(s7_scheme *sc)
{
  /* after the expander has finished, if a list was returned, we need to add some annotations.
   *   if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*).
   */
#if Eval_Print && s7_Debugging
  fprintf(stderr, "  %s[%d]: op: %s, value: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(sc->value));
#endif
  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 #<undefined>: (with-let (inlet 'x #<undefined>) 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 #<undefined> 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 Eval_Print && s7_Debugging
  fprintf(stderr, "  %s[%d]: op: %s, form: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(form));
#endif
  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, s7_Warn_Bufsize, "%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);
	}}
  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) */
    }
  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) */
    }
  settee = car(code);
  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);
			    if ((has_fx(cdr(code))) && (is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, cdr(code));
			  }}
		    else
		      {
			if (is_fxable(sc, value))
			  {
			    pair_set_syntax_op(form, OP_SET_S_A);
			    fx_annotate_arg(sc, cdr(code), sc->curlet);
			    if ((has_fx(cdr(code))) && (is_fx_treeable(cdr(code))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, cdr(code));
			  }
			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) /* without Inline num and fbench are faster! (also op_set_s_s above) */
{
  s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); /* settee */
  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_SP_1, cadr(sc->code)); /* only path to op_set_sp_1, cadr(sc->code) might be immutable */
  sc->code = caddr(sc->code);
}

static void op_set_sp_1(s7_scheme *sc)
{
  const 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)
{
  const s7_pointer settee = sc->code;
  const 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 With_Gmp
      sc->value = vector_set_p_ppp(sc, obj, arg, value);
#else
      if (vector_rank(obj) > 1)
	sc->value = g_vector_set(sc, with_list_t3(sc, obj, arg, value));
      else
	{
	  s7_int index;
	  if (!is_t_integer(arg))
	    error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code));
	  index = integer(arg);
	  if (index < 0)
	    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code));
	  if (index >= vector_length(obj))
	    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code));
	  if (is_immutable_vector(obj))
	    immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->vector_set_symbol, obj));
	  if (is_typed_vector(obj))
	    value = typed_vector_setter(sc, obj, index, value);
	  else vector_element(obj, index) = value;
	  sc->value = T_Ext(value);
	}
#endif
      break;

    case T_STRING:
#if With_Gmp
      sc->value = g_string_set(sc, with_list_t3(sc, obj, arg, value));
#else
      {
	s7_int index;
	if (!is_t_integer(arg))
	  error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code));
	index = integer(arg);
	if (index < 0)
	  error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code));
	if (index >= string_length(obj))
	  error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code));
	if (is_immutable_string(obj))
	  immutable_object_error_nr(sc, set_elist_3(sc, Immutable_Error_String, sc->string_set_symbol, obj));
	if (!is_character(value))
	  error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code));
	string_value(obj)[index] = (char)s7_character(value);
	sc->value = value;
      }
#endif
      break;

    case T_PAIR:
      sc->value = g_list_set(sc, with_list_t3(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;
  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);
    }
  {
    const s7_pointer 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) */
{
  const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code));
  if (has_macro_setter(obj))
    {
      const s7_pointer setf = macro_setter_p_pp(sc, obj);
      sc->code = setf;
      sc->args = pair_append(sc, cdar(code), cdr(code));
      return(true); /* goto Apply (if false, continue) */
    }
  {
    s7_pointer index;
    const s7_pointer 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 (has_macro_setter(obj))
    {
      s7_pointer setf = macro_setter_p_pp(sc, obj);
      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)
{
  const 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) */
{
  const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code));
  if (has_macro_setter(obj))
    {
      const s7_pointer setf = macro_setter_p_pp(sc, obj);
      sc->code = setf;
      sc->args = pair_append(sc, cdar(code), cdr(code));
      return(true);
    }
  {
    s7_pointer index1;
    const s7_pointer 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 (has_macro_setter(obj))
    {
      const s7_pointer setf = macro_setter_p_pp(sc, obj);
      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)
{
  /* 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));
  {
    const s7_pointer val = sc->value;
    const s7_pointer arg1 = car(sc->args);
    const s7_pointer 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 = 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, set_mlist_1(sc, fx_call(sc, cdr(arg)))));
  ind = fx_call(sc, cdr(arg));
  if ((s7_is_integer(ind)) && (vector_rank(vec) == 1))
    {
      s7_int index = s7_integer_clamped_if_gmp(sc, ind);
      if ((index < vector_length(vec)) && (index >= 0))
	return(vector_getter(vec)(sc, vec, index));
    }
  return(vector_ref_1(sc, vec, set_plist_1(sc, ind)));
}

static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* tnum/tmat, neither uses fx case if available (see tmp) */
{
  s7_pointer ind1, ind2, code;
  const s7_pointer vec = lookup_checked(sc, car(sc->code));
  if (!is_any_vector(vec)) {sc->last_function = vec; return(false);}
  code = cdr(sc->code);
  ind1 = fx_call(sc, code);
  gc_protect_via_stack(sc, ind1);
  ind2 = fx_call(sc, cdr(code));
  set_gc_protected2(sc, ind2);
  if ((s7_is_integer(ind1)) && (s7_is_integer(ind2)) && (vector_rank(vec) == 2))
    {
      s7_int i1 = s7_integer_clamped_if_gmp(sc, ind1);
      s7_int i2 = s7_integer_clamped_if_gmp(sc, ind2);
      if ((i1 >= 0) && (i2 >= 0) &&
	  (i1 < vector_dimension(vec, 0)) && (i2 < vector_dimension(vec, 1)))
	{
	  s7_int index = (i1 * vector_offset(vec, 0)) + i2;
	  sc->value = (is_float_vector(vec)) ? make_real(sc, float_vector(vec, index)) : vector_getter(vec)(sc, vec, index); /* check for normal vector saves in some cases, costs in others */
	  unstack_gc_protect(sc);
	  return(true);
	}}
  sc->value = vector_ref_1(sc, vec, set_plist_2(sc, ind1, ind2));
  unstack_gc_protect(sc);
  return(true);
}

static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form);

static void setup_eval_args_pair(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val)
{
  push_stack(sc, OP_SET2, cdr(inds), val);
  sc->code = list_2(sc, obj, car(inds));
  set_optimize_op(sc->code, OP_PAIR_ANY);        /* usually an error: (#\a) etc, might be (#(0) 0) */
  sc->value = obj;
  sc->code = cdr(sc->code);
  push_op_stack(sc, sc->value);
  if (sc->op_stack_now >= sc->op_stack_end)
    resize_op_stack(sc);
  sc->args = sc->nil;
}

static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer inds, s7_pointer val, s7_pointer form)
{
  /* vect is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */
  s7_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))
		{
		  s7_pointer index = car(p);
		  if (is_symbol(index))
		    index = lookup_checked(sc, index);
		  if (!s7_is_integer(index))
		    {
		      if (in_heap(args)) unstack_gc_protect(sc);
		      error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form));
		    }
		  set_car(pa, index);
		}
	      set_car(pa, car(val));
	      if (is_symbol(car(pa)))
		set_car(pa, lookup_checked(sc, car(pa)));
	      sc->value = g_vector_set(sc, args);
	      if (in_heap(args)) unstack_gc_protect(sc);
	      else clear_safe_list_in_use(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 */
    s7_pointer index = car(inds);
    if (!is_pair(index))
      {
	s7_int ind;
	s7_pointer value;
	if (is_symbol(index))
	  index = lookup_checked(sc, index);
	if (!s7_is_integer(index))
	  error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code));
	ind = s7_integer_clamped_if_gmp(sc, index);
	if ((ind < 0) || (ind >= vector_length(vect)))
	  out_of_range_error_nr(sc, sc->vector_set_symbol, Int_Two, index, (ind < 0) ? It_Is_Negative_String : It_Is_Too_Large_String);
	value = car(val);
	if (!is_pair(value))
	  {
	    if (is_symbol(value))
	      value = lookup_checked(sc, value);
	    if (is_typed_t_vector(vect))
	      typed_vector_setter(sc, vect, ind, value);
	    else vector_setter(vect)(sc, vect, ind, value);
	    sc->value = T_Ext(value);
	    return(Goto_Start);
	  }
	push_op_stack(sc, sc->vector_set_function);
	sc->args = list_2(sc, index, vect);
	sc->code = val;
	return(Goto_Eval_Args);
      }}
  /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */
  push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), val);
  push_op_stack(sc, sc->vector_set_function);
  sc->code = car(inds);
  sc->cur_op = optimize_op(sc->code);
  return(Goto_Top_No_Pop);
}

static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer inds, s7_pointer val, s7_pointer unused_form)
{
  /* 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);
    }
  {
    s7_pointer 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)
{
  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);
    }
  {
    const s7_int 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)
	{
	  const 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;
  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);
    }
  {
  const s7_pointer sig = c_function_signature(func);
  if ((is_pair(sig)) &&
      ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol) ||
       ((is_pair(car(sig))) && /* tvect tshoot tbig */
	((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 */
    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 ((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 */
			/* this is trying to catch (set! end i) [do-test-20 s7test] etc and needs the end-and-result form to check that */
			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;
			    /* fprintf(stderr, "%d: %s %s %s\n", __LINE__, display(end_and_result), display(settee), display(expr)); */
			    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);
			      }}
			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 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 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 && s7_Debugging
  fprintf(stderr, "  op: %s\n", op_names[optimize_op(sc->code)]);
#endif
  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);
}

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?
   */
  for (s7_pointer p = tree; is_pair(p); p = cdr(p))
    {
      const 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))
	  {
	    /* in some context (from t725 with (*s7* 'safety) set to 1)
	     *   (do ((i 0 (+ i 1))) ((= i 1)) (with-immutable (i) (values (copy (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)) '((1) (vector 1))))))
	     *   (do ((i 0 (+ i 1))) ((= i 1)) (with-immutable (i) (values (set-car! '((quote #1=(1 . #1#))) (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp))))))
	     * can get into an infinite loop 6 calls deep in do_tree_has_definer.  So set safety to 2!  I don't think I promise to catch circular function bodies.
	     */
	    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))...) */
	    error_nr(sc, sc->duplicate_identifier_symbol, set_elist_3(sc, wrap_string(sc, "duplicate identifier in do: '~A in ~A", 37), car(vars), 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)) */
	{
	  const s7_pointer var = car(vars);
	  const 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, s7_Warn_Bufsize, "%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 && s7_Debugging
	    fprintf(stderr, "  %s[%d]: ok %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)]);
#endif
	    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;

  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display_truncated(form));
  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 */
  /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->curlet)); */

  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_slot_checked(slot))
		    {
		      v2 = slot_symbol(slot);
		      slot = next_slot(slot);
		      if (is_slot_checked(slot))
			{
			  v3 = slot_symbol(slot);
			  more_vs = is_slot_checked(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))) /* Tree_Is_Cyclic or Tree_Has_Pairs */
    {
      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 OP_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 */

	      /* fprintf(stderr, "%d: step: %s %d %d\n", __LINE__, display(step_expr), caddr(step_expr) == Int_One, opt1_cfunc(end) == sc->geq_2); */

	      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);
		    }}
	      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_slot_checked(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_is_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))) &&
#if 0 /* allow "p" steppers */
		      (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) &&
#endif
		      (caadr(var) == car(step_expr)))))	       /* i.e. accept char-position as init/step, but not iterate */
		  {
		    if (Do_Print)
		      fprintf(stderr, "%s[%d]: %s is a safe expression\n", __func__, __LINE__, display(caddr(var)));
		    set_is_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_slot_checked(slot))
	      {
		var2 = slot_symbol(slot);
		slot = next_slot(slot);
		if (is_slot_checked(slot))
		  {
		    var3 = slot_symbol(slot);
		    more_vars = is_slot_checked(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);
	  }

	/* fprintf(stderr, "%d: %s %d\n", __LINE__, display(body), is_fxable(sc, car(body))); */
	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); /* ridiculous... */
	    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 && s7_Debugging
  fprintf(stderr, "%s[%d]: optimizable %s %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)], op_names[optimize_op(sc->code)]);
#endif
  return(sc->nil);
}

static bool has_safe_steppers(s7_scheme *sc, s7_pointer let)
{
  if (Do_Print) fprintf(stderr, "%s[%d]: curlet: %s\n", __func__, __LINE__, display(let));
  for (s7_pointer slot = let_slots(let); is_slot_checked(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 (Do_Print)
	    fprintf(stderr, "%s[%d]: %s: %s safe: %d, val: %s\n", __func__, __LINE__, display(slot), display(step_expr), is_safe_stepper_expr(step_expr), display(val));
	  if (is_safe_stepper_expr(step_expr))
	    {
	      if (is_t_integer(val))
		{
		  if (is_int_optable(step_expr))
		    set_is_safe_stepper(slot);
		  else
		    if (no_int_opt(step_expr))
		      clear_is_safe_stepper(slot);
		    else
		      {
			sc->pc = 0;
			if (int_optimize(sc, step_expr))
			  {
			    set_is_safe_stepper(slot);
			    set_is_int_optable(step_expr);
			  }
			else
			  {
			    clear_is_safe_stepper(slot);
			    set_no_int_opt(step_expr);
			  }}}
	      else
		if (is_t_real(val)) /* is_small_real: t_integer, t_ratio, t_real */
		  {
		    if (is_float_optable(step_expr))
		      set_is_safe_stepper(slot);
		    else
		      if (no_float_opt(step_expr))
			clear_is_safe_stepper(slot);
		      else
			{
			  sc->pc = 0;
			  if (float_optimize(sc, step_expr))
			    {
			      set_is_safe_stepper(slot);
			      set_is_float_optable(step_expr);
			    }
			  else
			    {
			      clear_is_safe_stepper(slot);
			      set_no_float_opt(step_expr);
			    }}}
		else
		  {
		    if (Do_Print) fprintf(stderr, "  %s is safe\n", display(slot));
		    set_is_safe_stepper(slot);  /* ?? shouldn't this check types ?? */
		  }}
	  else
	    if (Do_Print)
	      fprintf(stderr, "%s[%d]: %s in slot %s is not a safe stepper expression\n", __func__, __LINE__, display(step_expr), display(slot));
	}
      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_is_safe_stepper(slot);
	}
      if (!is_safe_stepper(slot))
	{
	  if (Do_Print)
	    fprintf(stderr, "%s[%d]: %s is not a safe stepper\n", __func__, __LINE__, display(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))))
    {
      const 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)
{
  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;
  {
    const s7_pointer 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->do_unspecified;
	}
      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->do_unspecified;
		    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_slot_checked(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_slot_checked(slot));
  } while ((sc->value = endf(sc, endp)) == sc->F);
  sc->code = cdr(end);
  return(Goto_Do_End_Clauses);
}

#define Max_Opt_Body_Size 32

static goto_t op_dox(s7_scheme *sc)
{
  /* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
   *    since all these exprs are local, we don't need to jump until the body
   */
  s7_int id;
  int32_t steppers = 0;
  s7_pointer code, end, endp, stepper = NULL, slots;
  const s7_pointer form = sc->code;
  s7_function endf;
#if With_Gmp
  bool got_bignum = false;
#endif
  const s7_pointer let = inline_make_let(sc, sc->curlet);   /* new let is not tied into the symbol lookup process yet */
  if ((Eval_Print) || (Do_Print)) 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 new_slot;
      const s7_pointer val = fx_call(sc, expr);
      const s7_pointer stp = cdr(expr); /* cddar(vars) */
#if With_Gmp
      if (!got_bignum) got_bignum = is_big_number(val);
#endif
      new_cell_unchecked(sc, new_slot, T_SLOT);
      slot_set_symbol_and_value(new_slot, caar(vars), val);
      if (is_pair(stp))
	{
	  steppers++;
	  stepper = new_slot;
	  slot_set_expression(new_slot, stp);
	}
      else slot_just_set_expression(new_slot, sc->nil);
      slot_set_next(new_slot, let_slots(let));
      let_set_slots(let, new_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_slot_checked(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);
      if (Do_Print) fprintf(stderr, "op_dox[%d], at end at start\n", __LINE__);
      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, "op_dox[%d]: no body\n", __LINE__);
      return(op_dox_no_body_1(sc, slots, end, steppers, stepper));
    }

  if (Do_Print) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_truncated(code));

  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 (Do_Print) fprintf(stderr, "%d: no_cell: %d, safe_steppers: %d %s\n", __LINE__, no_cell_opt(code), has_safe_steppers(sc, sc->curlet), display(sc->curlet));
      if ((!no_cell_opt(code)) &&
#if With_Gmp
	  (!got_bignum) &&
#endif
	  (has_safe_steppers(sc, sc->curlet)))
	bodyf = s7_optimize_nv(sc, code);

      if ((!bodyf) &&
	  (is_fxable(sc, body)) &&     /* happens very rarely, #_* as car etc */
	  (is_c_function(car(body))))
	{
	  if ((s7_Debugging) && (lookup(sc, c_function_symbol(car(body))) != car(body)))
	    fprintf(stderr, "%s[%d]: replacing %s with %s -> %s in %s\n", __func__, __LINE__,
		    display(car(body)),
		    display(c_function_symbol(car(body))),
		    display(lookup(sc, c_function_symbol(car(body)))),
		    display(body));
	  bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_symbol(car(body)), cdr(body)))); /* trouble! #_xyzzy need not match xyzzy */
	}
      if (bodyf)
	{
	  if ((Eval_Print) || (Do_Print)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(body));
	  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)))) */
			      const 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->do_unspecified;
			    }
			  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_slot_checked(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));
		      const 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_slot_checked(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_slot_checked(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);
	  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));
	      /* if ((s7_Debugging) && (!is_fx_treeable(val))) fprintf(stderr, "%s[%d]: not treeable: %s\n", __func__, __LINE__, display(val)); */
	      if ((is_fx_treeable(val)) && (curlet_has_slots(sc))) fx_curlet_tree(sc, val);
	    }
	  valf = fx_proc(val);
	  val = car(val);
	  stepf = fx_proc(slot_expression(stepper));
	  {
	    const s7_pointer 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[Max_Opt_Body_Size];

      if ((!no_cell_opt(code)) &&
#if With_Gmp
	  (!got_bignum) &&
#endif
	  (has_safe_steppers(sc, sc->curlet)))
	{
	  sc->pc = 0;
	  if (Opt_Print) fprintf(stderr, "  %s[%d]: cell_optimize(%s)\n", __func__, __LINE__, display(code));
	  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 (Opt_Print) fprintf(stderr, "   %s[%d]: success (%s, %d)\n", __func__, __LINE__, display(form), use_opts);
	  if (!use_opts)
	    fx_annotate_args(sc, code, sc->curlet);
	  if (stepper)
	    {
	      stepf = fx_proc(slot_expression(stepper));
	      stepa = car(slot_expression(stepper));
	    }
	  /* body_len = 3 in trec (steppers:1)/tshoot(steppers:3), 2's in s7test */
	  if ((use_opts) && (body_len == 3) && (steppers == 1)) /* maybe not useful -- omit steppers check? */
	    {
	      opt_info *o1 = body[0], *o2 = body[1], *o3 = body[2];
	      while(true)
		{
		  q_call(o1).fp(o1);
		  q_call(o2).fp(o2);
		  q_call(o3).fp(o3);
		  slot_set_value(stepper, stepf(sc, stepa));
		  if (is_true(sc, sc->value = endf(sc, endp)))
		    {
		      sc->code = cdr(end);
		      return(Goto_Do_End_Clauses);
		    }}}
	  else
	    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_slot_checked(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_slot_checked(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_slot_checked(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_slot_checked(slot));
      slot = slots;
      do {
	if (slot_has_expression(slot))
	  slot_set_value(slot, slot_pending_value(slot));
	slot = next_slot(slot);
      } while (is_slot_checked(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[Max_Opt_Body_Size];

  sc->code = cdr(sc->code);
  sc->pc = 0;
  for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < Max_Opt_Body_Size); 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_slot_checked(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) /* called only in eval */
{
  if (!is_null(sc->code))
    return(false);                        /* fall into do_end_code */
  /* since sc->code is null here, we don't have an explicit return value, I hope */
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
  else
    if (sc->value == sc->T) /* this is problematic any way we handle it */
      sc->value = sc->do_unspecified;
  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, Int_Two, 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, Int_Two, 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;

  /* fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display(code)); */
  sc->do_body_p = caddr(code);
  func = s7_optimize_nv(sc, cddr(code));
  if (!func)
    {
      set_no_cell_opt(cddr(code));
      if (Do_Print) fprintf(stderr, "%s[%d]: can't s7_optimize %s\n", __func__, __LINE__, display(caddr(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->do_unspecified;
      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->do_unspecified;
      sc->code = cdadr(code);
      sc->do_body_p = NULL;
      return(true);
    }
  if (((stepf == g_add_2) || (stepf == g_add_ii)) &&
      (is_t_integer(slot_value(ctr_slot))) &&
      (is_t_integer(slot_value(end_slot))) &&
      ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)))
    {
      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->do_unspecified;
      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, 1 var, might not be + for step I think */
  const s7_pointer code = cdr(sc->code);
  const s7_pointer end_expr = caadr(code);
  const s7_pointer end = opt1_any(code);        /* caddr(caadr(code)) */
  const s7_pointer step_expr = opt2_pair(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));
  /* fprintf(stderr, "%s[%d]: %s t2: %s\n", __func__, __LINE__, display(end_expr), display(sc->t2_1)); */
  sc->value = fn_proc(end_expr)(sc, sc->t2_1);
  if (is_true(sc, sc->value))
    {
      sc->code = cdadr(code);
      return(true);                           /* goto Do_End_Clauses */
    }
  if (!no_cell_opt(cdddr(sc->code)))
    {
      if ((is_null(cdr(body))) &&             /* one expr in body */
	  (is_pair(car(body))) &&             /*   and it is a pair */
	  (is_symbol(cadr(step_expr))) &&     /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this checks that stepf is reasonable? */
	  (is_t_integer(caddr(step_expr))) &&
	  (is_t_integer(let_dox1_value(sc->curlet))) &&
	  (is_t_integer(let_dox2_value(sc->curlet))))
	{
	  s7_int end_int = integer(let_dox2_value(sc->curlet));
	  s7_int step_int = integer(caddr(step_expr));
	  s7_int init_int = integer(let_dox1_value(sc->curlet));
	  if (((car(end_expr) != sc->num_eq_symbol) ||
	       ((car(step_expr) == sc->add_symbol) &&
		(((end_int - init_int) % step_int) == 0))) &&
	      (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->do_unspecified;
      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->do_unspecified;
      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->do_unspecified;
      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 (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display_truncated(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->do_unspecified;
	      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 form, bool loop_end_ok) /* form = cdr(do...) */
{
  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s %d\n", __func__, __LINE__, display_truncated(form), loop_end_ok);
  if (loop_end_ok)
    set_is_safe_stepper(sc->args);
  else set_is_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-alphabetic? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */
	      for (; integer(stepper) < end; integer(stepper)++)
		func(sc);
	  clear_mutable_integer(stepper);
	} /* loop_end_ok */
      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 (step > stop) return_false(sc, code);

	  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->do_unspecified;
      sc->code = cdadr(form);
      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 WITH_GMP
    for (int32_t i = 0; i < 32; i++) body[i] = NULL; /* make the compiler happy */
#endif

    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->do_unspecified;
	    sc->code = cdadr(form);
	    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 == 2)
		  {
		    opt_info *o1 = body[0], *o2 = body[1];
		    for (; integer(stepper) < end; integer(stepper)++)
		      {
			q_call(o1).fp(o1);
			q_call(o2).fp(o2);
		      }}
		else
		  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));
	      if (body_len == 2)
		{
		  opt_info *o1 = body[0], *o2 = body[1];
		  for (s7_int step = integer(slot_value(step_slot)); step < stop; step++)
		    {
		      slot_set_value(step_slot, make_integer(sc, step));
		      q_call(o1).fp(o1);
		      q_call(o2).fp(o2);
		    }}
	      else
		if (body_len == 3)
		  {
		    opt_info *o1 = body[0], *o2 = body[1], *o3 = body[2];
		    for (s7_int step = integer(slot_value(step_slot)); step < stop; step++)
		      {
			slot_set_value(step_slot, make_integer(sc, step));
			q_call(o1).fp(o1);
			q_call(o2).fp(o2);
			q_call(o3).fp(o3);
		      }}
		else
		  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->do_unspecified;
	  sc->code = cdadr(form);
	  return_true(sc, code);
	}}}
  return_false(sc, code);
}

static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer form)
{
  const s7_pointer let_code = caddr(form);
  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 *));

  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display_truncated(form));
  /* 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_is_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_slot_checked(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_slot_checked(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->do_unspecified;
  sc->code = cdadr(form);
  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;
  if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display_truncated(form));

  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->do_unspecified;
	      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);
		  /* optimize_op(car(body)) == hp_safe_c_s, opt2(car(body))=g_abs, opt2(body)==fx_c_o, sym is object with 'abs method */
		  if ((optimize_op(car(body)) == HOP_SAFE_C_S) && (fn_proc(car(body)) == g_abs))
		    {
		      s7_pointer symval = lookup(sc, cadar(body));
		      for (s7_pointer stepper = slot_value(sc->args); integer(stepper) < end; integer(stepper)++) abs_p_p(sc, symval); /* kinda stupid... */
		    }
		  else
		    for (s7_pointer stepper = slot_value(sc->args); integer(stepper) < end; integer(stepper)++) fx_call(sc, body);
		  sc->value = sc->do_unspecified;
		  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->do_unspecified;
      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->do_unspecified;
	      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 */
      else sc->value = sc->do_unspecified;
      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_macro(s7_scheme *sc)  	            /* -------- C-based macro -------- */
{
  check_c_macro_args(sc, 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 = 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 no_return void apply_lambda_arg_error_1_nr(s7_scheme *sc)
{
  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 : ((is_expansion(sc->code)) ? sc->expansion_symbol : sc->macro_symbol)),
		       closure_pars(sc->code), sc->args));
}

static no_return void apply_lambda_arg_error_2_nr(s7_scheme *sc)
{
  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 : ((is_expansion(sc->code)) ? sc->expansion_symbol : sc->macro_symbol)),
		       closure_pars(sc->code), sc->args));
}

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;

  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)) apply_lambda_arg_error_1_nr(sc);
      slot = make_slot(sc, sym, T_Ext(car_unchecked(args)));
      symbol_set_local_slot(sym, let_id(let), slot);
      if (is_slot_checked(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)) apply_lambda_arg_error_2_nr(sc);
    }
  else
    {
      const s7_pointer slot = make_slot(sc, T_Sym(pars), args);
      symbol_set_local_slot(pars, let_id(let), slot);
      if (is_slot_checked(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_slot_checked(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_slot_checked(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_slot_checked(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)
{
  const 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_slot_checked(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) /* inline = 0 in s7test, 1 in tset */
{
  for (s7_pointer slot = sc->args; is_slot_checked(slot); slot = next_slot(slot))
    {
      if ((slot_value(slot) == sc->undefined) &&    /* trouble: (lambda* ((e #<undefined>))...) */
	  (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 #<undefined>
		   *   (or maybe #<unused>?) earlier in apply_*_closure_star_1, so (define (f f) (define* (f (f f)) f) (f)) (f 0)
		   *   looks for the default f, finds itself currently undefined, and raises an error! So, before
		   *   claiming it is unbound, we need to check outlet as well. But in the case above, the inner
		   *   define* shadows the caller's parameter before checking the default arg values, so the default f
		   *   refers to the define* -- I'm not sure this is a bug.  It means that (define* (f (a f)) a)
		   *   returns f: (equal? f (f)) -> #t, so any outer f needs an extra let and endless outlets:
		   *   (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3
		   *   We want the shadowing once the define* is done, so the current mess is simplest.
		   */
		  slot_set_value(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_slot_checked(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_slot_checked(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)))
    {
      const 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)
{
  const 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)
{
  const 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 */
{
  const 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)
{
  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));
  {
    const s7_pointer 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, s7_Warn_Bufsize, "(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)) */
	      sc->let_number++; /* dummy let, force symbol lookup */
	      for (s7_pointer slot = let_slots(sc->curlet); is_slot_checked(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;
		  }
	      {
		s7_pointer new_slot;
		new_cell_unchecked(sc, new_slot, T_SLOT);
		slot_set_symbol_and_value(new_slot, code, new_func);
		symbol_set_local_slot(code, sc->let_number, new_slot);
		slot_set_next(new_slot, let_slots(sc->curlet));
		let_set_slots(sc->curlet, new_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);
	  if (is_expansion(sc->value)) set_is_expansion(code);
	}}
}


/* -------------------------------- 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 bool op_thunk_c(s7_scheme *sc)
{
  s7_pointer func = opt1_lambda(sc->code);
  s7_pointer body = closure_body(func);
  if (optimize_op(car(body)) == OP_CONSTANT) /* does not include quoted cases */
    {
      sc->value = car(body);
      return(false);
    }
  if (caar(body) == sc->quote_function)      /* #_quote can't be refined */
    {
      sc->value = cadar(body);
      return(false);
    }
  set_curlet(sc, inline_make_let(sc, closure_let(func)));
  sc->code = car(body);
  return(true); /* goto Eval */
}

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))) -> #<unused>
   *    g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe!
   */
  push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args);
  sc->code = caddr(code);
}

static void op_closure_ap_1(s7_scheme *sc)          /* sc->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: #<lambda (x a)> */
{
  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) */
{
  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 */
  set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, args), sc->code));
  {
    const s7_pointer 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") */
{
  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));
  {
    const s7_pointer 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_slot_checked(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_slot_checked(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_slot_checked(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), 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), list_2(sc, gc_protected1(sc), sc->args))); /* not plist_2!! this is a slot value */
	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 unused_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 pars)
{
  /* 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 = (pars == 1) ? NULL : next_slot(la_slot);
  const s7_pointer l3a_slot = (pars <= 2) ? NULL : next_slot(l2a_slot);
  const s7_int num_clauses = opt3_arglen(cdr(code));
  tick_tc(sc, (pars == 1) ? OP_TC_CASE_LA : ((pars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A));

  if (num_clauses == 3)
    {
      if (pars == 1)
	{
	  while (true)
	    {
	      const s7_pointer selector = fx_call(sc, selp);
	      if (selector == case_clause_key(clauses))
		endp = case_clause_result(clauses);
	      else
		{
		  const 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)));
	      else break;
	    }}
      else
	while (true)
	  {
	    const s7_pointer selector = fx_call(sc, selp);
	    if (selector == case_clause_key(clauses))
	      endp = case_clause_result(clauses);
	    else
	      {
		const 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)));
		slot_set_value(l2a_slot, fx_call(sc, cddr(endp)));
		if (pars > 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 (pars > 1)
	      {
		slot_set_value(l2a_slot, fx_call(sc, cddr(endp)));
		if (pars > 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 tc_z below) */
}

static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_case_la(sc, arg, 1)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  return(sc->value);
}

static s7_pointer fx_tc_case_l2a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_case_la(sc, arg, 2)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  return(sc->value);
}

static s7_pointer fx_tc_case_l3a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_case_la(sc, arg, 3)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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 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))
	    {
	      const 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(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(tc_z(sc, if_done));
}

static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_la(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  return(sc->value);
}

static bool op_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer code)
{
  const bool true_quits = true_is_done(code);
  const s7_pointer la_slot = let_slots(sc->curlet);
  s7_function tf;
  s7_pointer if_test = rec_test_clause(code);
  const s7_pointer if_done = rec_done_clause(code);
  const s7_pointer la = rec_call_clause(code);
  const s7_pointer l2a = cdr(la);
  const s7_pointer l2a_slot = next_slot(la_slot);
  tick_tc(sc, OP_TC_IF_A_Z_L2A);
#if !With_Gmp
  if (!no_bool_opt(code))
    {
      sc->pc = 0;
      if (bool_optimize(sc, if_test))
	{
	  opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2;
	  const int32_t start_pc = sc->pc;
	  if ((is_t_integer(slot_value(la_slot))) &&
	      (is_t_integer(slot_value(l2a_slot))))
	    {
	      if (int_optimize(sc, la))
		{
		  o2 = sc->opts[sc->pc];
		  if (int_optimize(sc, l2a))
		    {
		      s7_int (*fi1)(opt_info *o) = 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))) */
			  const s7_int lim = q_arg2(o).i;
			  const s7_int m = q_arg2(o1).i;
			  const s7_pointer slot1 = q_arg1(o).p;
			  const s7_pointer slot2 = q_arg1(o1).p;
			  while (integer(slot_value(slot1)) >= lim)
			    {
			      const 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))) */
			   /* trec:   (define (add n acc) (if (< n 1) acc (add (- n 1) (+ acc 1)))) */
			while (fb(o) != true_quits)
			  {
			    const s7_int i1 = fi1(o1);
			    set_integer(val2, fi2(o2));
			    set_integer(val1, i1);
			  }
		      return(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))) */
			  const s7_double lim = q_arg2(o).x;
			  const s7_double m = q_arg2(o1).x;
			  const s7_pointer slot1 = q_arg1(o).p;
			  const s7_pointer slot2 = q_arg1(o1).p;
			  while (real(slot_value(slot1)) >= lim)
			    {
			      const 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)
			  {
			    const s7_double x1 = fd1(o1);
			    set_real(val2, fd2(o2));
			    set_real(val1, x1);
			  }
		      clear_mutable_number(val1);
		      clear_mutable_number(val2);
		      return(tc_z(sc, if_done));
		    }}}}
      set_no_bool_opt(code);
    }
#endif
  tf = fx_proc(if_test);
  if_test = car(if_test);
  if (true_quits)
    {
      if ((fx_proc(la) == fx_cdr_t) && (is_pair(slot_value(la_slot))))
	{
	  if ((fx_proc(l2a) == fx_subtract_u1) && (fn_proc(if_test) == g_num_eq_xi) &&  /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */
	      (is_t_integer(slot_value(l2a_slot))))
	    { /* list-tail ferchrissake */
	      const s7_int end = integer(caddr(if_test));
	      s7_pointer lst = slot_value(la_slot);
	      for (s7_int start = integer(slot_value(l2a_slot)); start > end; start--)
		lst = cdr(lst);
	      slot_set_value(la_slot, lst);
	      return(tc_z(sc, if_done));
	    }
	  if (tf == fx_is_null_t)
	    {
	      if ((fx_proc(l2a) == fx_add_u_car_t) && (cadar(la) == opt1_sym(l2a)))
		set_opt2(l2a, fx_add_u_car_t_direct, Opt2_Fx);
	      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(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 */
	  if ((fx_proc(l2a) == fx_add_u_car_t) && (cadar(la) == opt1_sym(l2a)))
	    set_opt2(l2a, fx_add_u_car_t_direct, Opt2_Fx);
	  do {
	    const 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(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(tc_z(sc, if_done));
}

static s7_pointer fx_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_l2a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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(tc_z(sc, if_done));
}

static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_l3a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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! */
  if (fx_proc(fx_and) == fx_is_pair_t)
    {
      while (is_pair(slot_value(la_slot)))
	{
	  s7_pointer 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);
    }
  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);
  if (fx_proc(fx_or) == fx_is_null_t)
    {
      while (!is_null(slot_value(la_slot)))
	{
	  if (fx_call(sc, fx_and) == sc->F) return(sc->F);
	  slot_set_value(la_slot, fx_call(sc, fx_la));
	}
      return(sc->T);
    }
  while (true)
    {
      const 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)
    {
      const 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)
    {
      const 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)
    {
      const 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)
	{
	  const 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)
    {
      const 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);
  const bool tc_and = (car(code) == sc->and_symbol);
  const bool tc_cond = (car(code) == sc->cond_symbol);
  tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA);
  if (!tc_cond)                 /* code: (if a1 z1 (if a2 z2 la) or (and a1 (if a2 z la))? */
    {
      if1_test = cdr(code);
      if1_true = (!tc_and) ? cdr(if1_test) : sc->F;
      if1_false = (!tc_and) ? cadr(if1_true) : cadr(if1_test);
      if2_test = cdr(if1_false);
      if2_z = (z_first) ? cdr(if2_test) : cddr(if2_test);
      la = (z_first) ? cdaddr(if2_test) : cdadr(if2_test);
    }
  else
    {
      if1_test = cadr(code);    /* code: (cond (a1 z1) (a2 z2|la) (else la|z3)) */
      if1_true = cdr(if1_test);
      if1_false = caddr(code);  /* (a2 z2|la) */
      if2_test = if1_false;
      if2_z = (z_first) ? cdr(if2_test) : cdr(cadddr(code));
      la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code));
    }
#if !With_Gmp
  if (is_t_integer(slot_value(la_slot)))
    {
      opt_info *o = sc->opts[0];
      sc->pc = 0;
      if (bool_optimize_nw(sc, if1_test))
 	{
	  opt_info *o1 = sc->opts[sc->pc];
 	  if (bool_optimize_nw(sc, if2_test))
 	    {
	      opt_info *o2 = sc->opts[sc->pc];
 	      if (int_optimize(sc, la))
 		{
 		  const 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(tc_z(sc, endp));
 		}}}}
#endif
  while (true)
    {
      if ((fx_call(sc, if1_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if1_true; break;}}
      if ((fx_call(sc, if2_test) == sc->F) != z_first) {endp = if2_z; break;}
      slot_set_value(la_slot, fx_call(sc, la));
    }
  return(tc_z(sc, endp));
}

static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_if_a_z_la(sc, arg, true)) && (s7_Debugging)) /* true = z_first */
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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);
  if ((!op_tc_if_a_z_if_a_z_la(sc, arg, false)) && (s7_Debugging)) /* false = not z_first */
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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);
  if ((!op_tc_if_a_z_if_a_z_la(sc, arg, true)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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);
  if ((!op_tc_if_a_z_if_a_z_la(sc, arg, false)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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);
  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);
  const s7_pointer if2_test = (cond) ? caddr(code) : cdadr(if1_true);
  const s7_pointer if2_true = cdr(if2_test);
  const s7_pointer la = (cond) ? opt3_pair(code) : cdadr(if2_true);  /* cdadr(cadddr(code)) */
  const s7_pointer l2a = cdr(la);
  const s7_pointer l2a_slot = next_slot(la_slot);
  const s7_pointer slot1 = (fx_proc(if1_test) == fx_is_null_t) ? la_slot : ((fx_proc(if1_test) == fx_is_null_u) ? l2a_slot : NULL);
  s7_pointer endp;
  tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_L2A);
  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(tc_z(sc, endp));
}

static s7_pointer fx_tc_if_a_z_if_a_z_l2a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_if_a_z_l2a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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)
{
  const bool cond = car(code) == sc->cond_symbol;
  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);
  const s7_pointer if2_test = (cond) ? caddr(code) : cdadr(if1_true);
  const s7_pointer if2_true = cdr(if2_test);
  const s7_pointer if2_false = (cond) ? cdr(cadddr(code)) : cdr(if2_true);
  const s7_pointer la = (cond) ? opt3_pair(code) : cdar(if2_true); /* cdadr(caddr(code)) */
  const s7_pointer l2a = cdr(la);
  const s7_pointer l2a_slot = next_slot(la_slot);
  s7_pointer endp;
  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(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);
  if ((!op_tc_if_a_z_if_a_l2a_z(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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(tc_z(sc, endp));
}

static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_if_a_l3a_l3a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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 z_first) /* z_first: 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 = (z_first) ? if2_true : if2_false;
  const s7_pointer la2 = (z_first) ? cdar(if2_false) : cdar(if2_true);
  const s7_pointer l2a2 = cdr(la2);
  const s7_pointer l3a2 = cdr(l2a2);
  tick_tc(sc, (z_first) ? 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) == z_first) {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(tc_z(sc, endp));
}

static s7_pointer fx_tc_if_a_z_if_a_z_l3a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_if_a_z_if_a_z_l3a(sc, arg, true)) && (s7_Debugging)) /* true = z_first */
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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)
{
  if ((!op_tc_if_a_z_if_a_z_l3a(sc, arg, false)) && (s7_Debugging)) /* false = not z_first */
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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 (!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)
{
  if ((!op_tc_let_if_a_z_la(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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 !With_Gmp
  if (!no_bool_opt(code))
    {
      sc->pc = 0;
      if (bool_optimize(sc, if_test))
	{
	  opt_info *o = sc->opts[0];
	  opt_info *o1 = sc->opts[sc->pc], *o2, *o3;
	  if ((is_t_integer(slot_value(la_slot))) &&
	      (is_t_integer(slot_value(l2a_slot))))
	    {
	      if (int_optimize(sc, la))
		{
		  o2 = sc->opts[sc->pc];
		  if (int_optimize(sc, l2a))
		    {
		      o3 = sc->opts[sc->pc];
		      set_curlet(sc, outer_let);
		      if (int_optimize(sc, let_var))
			{
			  const s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot)));
			  const s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(l2a_slot)));
			  const 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 (!tc_z(sc, if_true)) return(false);
			  let_set_slots(inner_let, Slot_End);
			  return(true);
			}}}}}
      set_no_bool_opt(code);
    }
#endif
  while (fx_call(sc, if_test) == sc->F)
    {
      sc->rec_p1 = fx_call(sc, la);
      slot_set_value(l2a_slot, fx_call(sc, l2a));
      slot_set_value(la_slot, sc->rec_p1);
      set_curlet(sc, outer_let);
      slot_set_value(let_slot, fx_call(sc, let_var));
      set_curlet(sc, inner_let);
    }
  if (!wrappable) unstack_gc_protect(sc);
  if (!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)
{
  if ((!op_tc_let_if_a_z_l2a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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))
	{
	  const s7_pointer a1 = slot_value(let_slots(outer_let));                /* par1 of proc */
	  const s7_pointer a2 = slot_value(next_slot(let_slots(outer_let)));     /* par2 */
	  /* (let ((x (vector-ref fv 0))) (unless (>= x z) (vector-set! fv 0 (+ x 1)) (unless2 fv z))) (trclo: unless2) */
	  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)));
	      /* (let ((x (read-char in))) (unless (eof-object? x) (write-char x out) (catport in out))) -- b[orig]: cat */
	      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)
	  {
	    const 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
    {
      const s7_pointer la_slot = let_slots(outer_let);
      const s7_pointer l2a_slot = next_slot(la_slot);
      while (true)
	{
	  const 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(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);
  {
    const 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_1;
	    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_slot_checked(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;
	  }}
 Tc_Let_Cond_Done_1:
  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)
{
  if ((!op_tc_let_cond(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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(tc_z(sc, c1));
}

static s7_pointer fx_tc_cond_a_z_a_l2a_l2a(s7_scheme *sc, s7_pointer arg)
{
  if ((!op_tc_cond_a_z_a_l2a_l2a(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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_1;
	  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_slot_checked(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */
	    slot_set_value(slot, slot_pending_value(slot));
	  break;
	}
 Tc_Cond_N_Done_1:
  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)
{
  if ((!op_tc_cond_n(sc, arg)) && (s7_Debugging))
    {fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display(sc->code)); abort();}
  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
#define Initial_Recur_Stack_Size INITIAL_RECUR_STACK_SIZE

static void recur_resize(s7_scheme *sc)
{
  const s7_pointer stack = sc->rec_stack;
  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);
      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;
  {
    block_t *old_b = vector_block(stack);
    block_t *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);

#if !With_Gmp
  const s7_pointer c_op = car(caller);
  tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq);
  if ((is_symbol(c_op)) &&
      ((is_slot(global_slot(c_op))) &&
       ((is_global(c_op)) ||
	(s7_t_slot(sc, c_op) == global_slot(c_op)))))
    {
      const s7_pointer s_func = global_value(c_op);
      const s7_pointer slot = let_slots(sc->curlet);
      if (is_c_function(s_func))
	{
	  sc->pc = 0;
	  sc->rec_test_o = sc->opts[0];
	  if (bool_optimize(sc, rec_test_clause(code)))
	    {
	      const int32_t start_pc = sc->pc;
	      sc->rec_result_o = sc->opts[start_pc];
	      if (is_t_integer(slot_value(slot)))
		{
		  sc->rec_i_ii_f = s7_i_ii_function(s_func);
		  if ((sc->rec_i_ii_f) &&
		      (int_optimize(sc, rec_done_clause(code))))
		    {
		      sc->rec_a1_o = sc->opts[sc->pc];
		      if (int_optimize(sc, cdr(call1)))
			{
			  sc->rec_a2_o = sc->opts[sc->pc];
			  if (int_optimize(sc, cdr(call2)))
			    {
			      sc->rec_bool = a_is_cadr(code);
			      sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot)));
			      slot_set_value(slot, sc->rec_val1);
			      if (sc->pc != 4) return(Opt_Int); /* call1/call2 above are more complicated than (- n 1) or the like */
			      sc->rec_fb1 = 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);
				}}}}}}}}
#endif
  tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq);
  sc->rec_bool = a_is_cadr(code);
  sc->rec_fn = fn_proc(caller);
  rec_set_test(sc, rec_test_clause(code));
  rec_set_res(sc, rec_done_clause(code));
  rec_set_f1(sc, cdr(call1));
  rec_set_f2(sc, cdr(call2));
  sc->rec_slot1 = let_slots(sc->curlet);
  sc->rec_loc = 0;
  return(Opt_Ptr);
}

static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc)
{
  s7_int i1, i2;
  if (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);
  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)));
  {
    const s7_pointer p = cdadr(caller);
    rec_set_f3(sc, p);
    rec_set_f4(sc, cdr(p));
  }
  {
    const s7_pointer 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);
  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);
  {
    const s7_pointer p = cdadr(caller);
    rec_set_f3(sc, p);
    rec_set_f4(sc, cdr(p));
    rec_set_f5(sc, cddr(p));
  }
  {
    const s7_pointer p = rec_call_clause(caller);
    rec_set_f6(sc, p);
    rec_set_f7(sc, cdr(p));
    rec_set_f8(sc, cddr(p));
  }
  sc->rec_slot1 = let_slots(sc->curlet);
  sc->rec_slot2 = next_slot(sc->rec_slot1);
  sc->rec_slot3 = next_slot(sc->rec_slot2);
  sc->rec_fn = fn_proc(caller);
  sc->rec_loc = 0;
}

static s7_pointer oprec_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc)
{
  if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
  if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p));
  recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
  recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
  recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
  recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p));
  recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p));
  slot_set_value(sc->rec_slot3, sc->rec_f8f(sc, sc->rec_f8p));
  slot_set_value(sc->rec_slot2, recur_pop(sc));
  slot_set_value(sc->rec_slot1, recur_pop(sc));
  sc->value = oprec_if_a_a_if_a_a_opl3a_l3aq(sc);        /* second l3a */
  slot_set_value(sc->rec_slot3, recur_pop(sc));
  slot_set_value(sc->rec_slot2, recur_pop(sc));
  slot_set_value(sc->rec_slot1, recur_pop(sc));
  recur_push_unchecked(sc, sc->value);
  set_car(sc->t2_1, oprec_if_a_a_if_a_a_opl3a_l3aq(sc)); /* first l3a */
  set_car(sc->t2_2, recur_pop(sc));
  return(sc->rec_fn(sc, sc->t2_1));
}

static s7_pointer op_recur_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code)
{
  opinit_if_a_a_if_a_a_opl3a_l3aq(sc, code);
  return(oprec_if_a_a_if_a_a_opl3a_l3aq(sc));
}


/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */
static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, s7_pointer code)
{
  const s7_pointer caller = rec_call_clause(code);
  const bool la_op = a_is_cadr(caller);
#if !With_Gmp
  const s7_pointer c_op = car(caller);
  if ((is_symbol(c_op)) &&
      ((is_slot(global_slot(c_op))) &&
       ((is_global(c_op)) ||
	(s7_t_slot(sc, c_op) == global_slot(c_op)))))
    {
      const s7_pointer s_func = global_value(c_op), slot = let_slots(sc->curlet);
      if (is_c_function(s_func))
	{
	  sc->pc = 0;
	  sc->rec_test_o = sc->opts[0];
	  if (bool_optimize(sc, rec_test_clause(code))) /* (zero? x) */
	    {
	      const int32_t start_pc = sc->pc;
	      sc->rec_result_o = sc->opts[start_pc];
	      if (is_t_integer(slot_value(slot)))
		{
		  sc->rec_i_ii_f = s7_i_ii_function(s_func);
		  if ((sc->rec_i_ii_f) &&
		      (int_optimize(sc, rec_done_clause(code)))) /* x as return */
		    {
		      sc->rec_a1_o = sc->opts[sc->pc];
		      if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* x in (+ x ...) */
			{
			  sc->rec_a2_o = sc->opts[sc->pc];
			  if (int_optimize(sc, cdr(rec_call_clause(caller)))) /* arg of recur call: (- x 1) */
			    {
			      sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot)));
			      slot_set_value(slot, sc->rec_val1);
			      return(Opt_Int);
			    }}}}}}}
#endif
  /* not int: a_op: (lis (cons (car lis) (copy-list-1 (cdr lis)))),
   *         la_op: ((car lis) (copy-list-1 (cdr lis))),
   *         opt3: ((cdr lis))
   * (if (not (pair? lis)) lis (cons (car lis) (copy-list (cdr lis))))
   *
   * not int: a_op: (1 (lcm n (flcm (- n 1)))),
   *         la_op: (n (flcm (- n 1))),
   *         opt3: ((- n 1))
   * (if (<= n 1) 1 (lcm n (flcm (- n 1)))) 1 1
   */
  rec_set_test(sc, rec_test_clause(code));
  rec_set_res(sc, rec_done_clause(code));
  rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller));  /* a arg */
  rec_set_f2(sc, cdr(rec_call_clause(caller)));          /* la arg */
  sc->rec_slot1 = let_slots(sc->curlet);
  sc->rec_fn = fn_proc(caller);
  sc->rec_loc = 0;
  return(Opt_Ptr);
}

static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc)
{
  s7_int i1;
  if (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));
  const 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);
  tick_tc(sc, OP_RECUR_COND_A_A_A_A_opA_L2Aq);
  rec_set_test(sc, cadr(code));
  rec_set_res(sc, cdadr(code));
  {
    const s7_pointer 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 */
  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));
  {
    s7_pointer 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));
  {
    s7_pointer p = cdr(rec_call_clause(caller));  /* (L)AA */
    rec_set_f5(sc, p);
    rec_set_f6(sc, cdr(p));
  }
  sc->rec_fn = fn_proc(caller);
  sc->rec_slot1 = let_slots(sc->curlet);
  sc->rec_slot2 = next_slot(sc->rec_slot1);
  sc->rec_loc = 0;
}

static s7_pointer oprec_cond_a_a_a_l2a_opa_l2aq(s7_scheme *sc)
{
  if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
  if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F)
    {
      recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
      slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
      slot_set_value(sc->rec_slot1, recur_pop(sc));
      return(oprec_cond_a_a_a_l2a_opa_l2aq(sc)); /* first l2a above */
    }
  recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
  recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
  slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
  slot_set_value(sc->rec_slot1, recur_pop(sc));
  if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
    set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
  else
    if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F)
      {
	recur_push_unchecked(sc, sc->rec_f2f(sc, sc->rec_f2p));
	slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
	slot_set_value(sc->rec_slot1, recur_pop(sc));
	set_car(sc->t2_2, oprec_cond_a_a_a_l2a_opa_l2aq(sc)); /* first l2a above */
      }
    else
      {
	recur_push_unchecked(sc, sc->rec_f4f(sc, sc->rec_f4p));
	recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
	slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
	slot_set_value(sc->rec_slot1, recur_pop(sc));
	set_car(sc->t2_2, oprec_cond_a_a_a_l2a_opa_l2aq(sc));
	set_car(sc->t2_1, recur_pop(sc));
	set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
      }
  set_car(sc->t2_1, recur_pop(sc));
  return(sc->rec_fn(sc, sc->t2_1));
}

static s7_pointer op_recur_if_a_a_if_a_l2a_opa_l2aq(s7_scheme *sc, s7_pointer code) /* if version, same logic as cond above */
{
  opinit_cond_a_a_a_l2a_opa_l2aq(sc, code);
  return(oprec_cond_a_a_a_l2a_opa_l2aq(sc));
}

/* -------- cond_a_a_a_l2a_lopa_l2aq -------- */

static opt_pid_t opinit_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc, s7_pointer code)
{
  const s7_pointer caller = rec_call_clause(code);
  tick_tc(sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq);
  sc->rec_slot1 = let_slots(sc->curlet);
  sc->rec_slot2 = next_slot(sc->rec_slot1);

#if !With_Gmp
  if ((is_t_integer(slot_value(sc->rec_slot1))) &&
      (is_t_integer(slot_value(sc->rec_slot2))))
    {
      sc->pc = 0;
      sc->rec_test_o = sc->opts[0];
      if (bool_optimize(sc, cadr(code)))
	{
	  sc->rec_result_o = sc->opts[sc->pc];
	  if (int_optimize(sc, cdadr(code)))
	    {
	      const s7_pointer l2a1 = caddr(code);
	      sc->rec_a1_o = sc->opts[sc->pc];
	      if (bool_optimize(sc, l2a1))
		{
		  sc->rec_a2_o = sc->opts[sc->pc];
	  	  if (int_optimize(sc, cdadr(l2a1)))
		    {
		      sc->rec_a3_o = sc->opts[sc->pc];
		      if (int_optimize(sc, cddadr(l2a1)))
			{
			  const s7_pointer l2a2 = cadr(cadddr(code)), l2a3 = caddr(l2a2);
			  sc->rec_a4_o = sc->opts[sc->pc];
			  if (int_optimize(sc, cdr(l2a2)))
			    {
			      sc->rec_a5_o = sc->opts[sc->pc];
			      if (int_optimize(sc, cdr(l2a3)))
				{
				  sc->rec_a6_o = sc->opts[sc->pc];
				  if (int_optimize(sc, cddr(l2a3)))
				    {
				      sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot1)));
				      slot_set_value(sc->rec_slot1, sc->rec_val1);
				      sc->rec_val2 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot2)));
				      slot_set_value(sc->rec_slot2, sc->rec_val2);
				      if (sc->pc != 8)
					return(Opt_Int);
				      sc->rec_fb1 = 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);
				    }}}}}}}}} /* 9! most in s7.c */
#endif
  rec_set_test(sc, cadr(code));
  rec_set_res(sc, cdadr(code));
  {
    s7_pointer p = caddr(code);
    rec_set_f1(sc, p);
    p = cdadr(p);      /* not sc->rec_f1p = car(caddr(code)) */
    rec_set_f2(sc, p);
    rec_set_f3(sc, cdr(p));
  }
  rec_set_f4(sc, cdr(caller));
  {
    s7_pointer p = rec_call_clause(caller);
    rec_set_f5(sc, p);
    rec_set_f6(sc, cdr(p));
  }
  sc->rec_loc = 0;
  return(Opt_Ptr);
}

static s7_int oprec_i_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc)
{
  s7_int i1, i2;
  if (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)
{
  if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o));
  if (sc->rec_fb2(sc->rec_a1_o))
    {
      const s7_int 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));
    }
  {
    const s7_int i1 = sc->rec_fi4(sc->rec_a4_o);
    const s7_int 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)
{
  const 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)
{
  if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F);
  {
    const s7_pointer 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));
  {
    const s7_pointer 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_aap(s7_scheme *sc)
{
  push_stack_no_args_direct(sc, OP_SAFE_C_AAP_1);
  sc->code = opt3_pair(sc->code); /* cadddr */
}

static void op_safe_c_aap_1(s7_scheme *sc)
{
  set_car(sc->elist_7, sc->value); /* sc->value (and other temps) can be changed by fx call, but aap itself can't be fxified */
  sc->args = fx_call(sc, cdr(sc->code));
  sc->z = fx_call(sc, cddr(sc->code));
  set_car(sc->t3_1, sc->args);
  set_car(sc->t3_2, sc->z);
  set_car(sc->t3_3, car(sc->elist_7));
  sc->z = sc->unused;
  set_car(sc->elist_7, sc->unused);
  sc->value = fn_proc(sc->code)(sc, sc->t3_1);
}

static void op_safe_c_aap_2(s7_scheme *sc)
{
  sc->args = fx_call(sc, cdr(sc->code));
  sc->z = fx_call(sc, cddr(sc->code));
  {
    const s7_pointer mv = lookup_checked(sc, cadr(opt3_pair(sc->code)));
    if (!s7_is_proper_list(sc, mv))
      sole_arg_wrong_type_error_nr(sc, sc->apply_values_symbol, mv, A_Proper_List_String);
    sc->args = cons_unchecked(sc, sc->args, cons(sc, sc->z, mv));
  }
  sc->code = initial_value(sc->list_values_symbol);
  sc->value = apply_c_function_unopt(sc, sc->code, sc->args);
}

static void op_safe_c_sps(s7_scheme *sc)
{
  /* check_stack_size(sc); */
  push_stack_no_args_direct(sc, OP_SAFE_C_SPS_1);
  sc->code = caddr(sc->code);
}

static void op_safe_c_sps_1(s7_scheme *sc)
{
  set_car(sc->t3_2, sc->value);
  set_car(sc->t3_1, lookup(sc, cadr(sc->code)));
  set_car(sc->t3_3, lookup(sc, opt3_sym(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))
	{
	  sc->args = fx_call(sc, cdr(code)); /* was using car(sc->elist_7) here? */
	  sc->value = fx_call(sc, cddr(code));
	  sc->value = c_function_call(func)(sc, with_list_t2(sc, sc->args, sc->value));
	  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); /* continue */
    }
  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);
  sc->value = c_function_call(sc->code)(sc, set_c_function_star_args(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);
  sc->value = c_function_call(sc->code)(sc, set_c_function_star_defaults(sc, 0)); /* no args passed, so all default */
}

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 */
  sc->value = c_function_call(sc->code)(sc, set_c_function_star_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);
  sc->value = c_function_call(sc->code)(sc, set_c_function_star_args(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)
{
  const 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)
{
  const 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)
{
  const 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_checked(sc, cadr(sc->code)))); /* see cutlet example in s7test -> "arg unbound" */
}
/* 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)) ? for_each_closure(sc, sc->temp8, sc->value) : 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)) ? for_each_closure_2(sc, sc->temp8, sc->value, sc->args) : 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)
{
  const 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)); /* i.e. append sc->value to sc->args */
    }
  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 sc->value = c_function_call(sc->code)(sc, sc->args);
}

static void op_safe_c_3p(s7_scheme *sc)
{ /* thook: (let-set! h 'result ((let-ref h 'x) (let-ref h 'y))), tmv: (+ 1 (values 2 3 4) -4) */
  check_stack_size(sc);
  push_stack_no_args_direct(sc, OP_SAFE_C_3P_1);
  sc->code = cadr(sc->code);
}

/* safe_c_cpp -> sc->args = cadr(sc->code); push 3p_2; sc->code = caddr(sc->code)
 * safe_c_spp -> sc->args = lookup(cadr); same as above
 * ssp/sca exist
 */

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)
{
  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);
  {
    s7_pointer p;
    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 sc->value = c_function_call(sc->code)(sc, sc->args);
}

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)
{
  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);
  {
    const s7_pointer func = opt1_lambda(sc->code);
    s7_pointer args;
    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_slot_checked(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_slot_checked(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) /* inline tset 14 call 35 */
{
  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)
{
  const 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)))
    {
      /* if (s7_Debugging) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
      clear_optimize_op(sc->code);
      return(false); /* goto Unopt */
    }
  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); /* goto Eval */
}

static bool op_pair_pair_s(s7_scheme *sc)
{
  if (!is_pair(car(sc->code))) /* s7test: (for-each (macro* (a . b) (#_list-values 'cons a b)) #(0 1) (list '(values +) -1)) -- almost never happens */
    {
      /* if (s7_Debugging) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
      clear_optimize_op(sc->code);
      return(false); /* goto Unopt (was continue) */
    }
  /* if (s7_Debugging) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
  push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */
  sc->value = lookup_checked(sc, caar(sc->code));
  sc->code = car(sc->code);
  return(true);      /* goto Eval_Args_Top */
}

static bool op_pair_sym(s7_scheme *sc)
{
  if (!is_symbol(car(sc->code)))  /* s7test: (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) ! sc->code is (-1) */
    {
      /* if (s7_Debugging) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
      clear_optimize_op(sc->code);
      return(false); /* goto Unopt (was continue) */
    }
  sc->value = lookup_global(sc, car(sc->code));
  return(true);      /* goto Eval_Args_Top = op_eval_args */
}

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);
  /* goto Apply in eval */
}

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));
  /* goto Apply in eval */
}

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);
  /* goto Apply in eval */
}

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);
  /* goto Apply in eval */
}

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); /* goto Top_No_Pop */
    }
  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, (is_normal_symbol(car(head))) ? OP_PAIR_PAIR_S : OP_PAIR_PAIR);
    }
  else set_optimize_op(code, (is_normal_symbol(car(head))) ? OP_PAIR_PAIR_S : 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)));
  }
  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 token_t read_dot(s7_scheme *sc, s7_pointer port)
{
  const int32_t c = inchar(port);
  if (c != EOF)
    {
      backchar(c, port);
      if ((!char_ok_in_a_name[c]) && (c != 0))
	return(Token_Dot);
    }
  else
    {
      sc->strbuf[0] = '.';
      return(Token_Dot);
    }
  sc->strbuf[0] = '.';
  return(Token_Atom);  /* i.e. something that can start with a dot like a number */
}

static token_t token(s7_scheme *sc) /* inline here is slower */
{
  const int32_t c = port_read_white_space(current_input_port(sc))(sc, current_input_port(sc));
  switch (c)
    {
    case '(':  return(Token_Left_Paren);
    case ')':  return(Token_Right_Paren);
    case '.':  return(read_dot(sc, current_input_port(sc)));
    case '\'': return(Token_Quote);
    case ';':  return(port_read_semicolon(current_input_port(sc))(sc, current_input_port(sc)));
    case '"':  return(Token_Double_Quote);
    case '`':  return(Token_Back_Quote);
    case ',':  return(read_comma(sc, current_input_port(sc)));
    case '#':  return(read_sharp(sc, current_input_port(sc)));
    case '\0':
    case EOF:  return(Token_Eof);
    default:
      sc->strbuf[0] = (unsigned char)c; /* every Token_Atom return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */
      return(Token_Atom);
    }
}

static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer port)
{
  /* possible "\xn...;" char (write creates these things, so we have to read them)
   *   but we could have crazy input like "\x -- with no trailing double quote
   */
  for (int32_t c_ctr = 0; ; c_ctr++)
    {
      int32_t d1, d2, c = inchar(port);
      if (c == '"')                  /* "\x" -> error, "\x44" or "\x44;" -> #\D */
	{
	  if (c_ctr == 0)            /* "\x" */
 	    read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
	  backchar(c, port);         /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */
	  return(i);
	}
      if (c == ';')
	{
	  if (c_ctr == 0)            /* "\x;" */
 	    read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
	  return(i);                 /* "\x44;" */
	}
      if (c == EOF)                  /* "\x<eof> */
	{
	  read_error_nr(sc, "#<eof> in midst of hex-char");
	  return(i);
	}
      d1 = digits[c];
      if (d1 >= 16)                  /* "\x4H", also "\x44H" which Guile thinks is ok -- it apparently reads 2 digits and quits? */
	{
	  if (c_ctr == 0)
	    read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
	  backchar(c, 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<eof> */
	{
	  read_error_nr(sc, "#<eof> in midst of hex-char");
	  return(i);
	}
      d2 = digits[c];
      if (d2 >= 16)
	{
	  if (c_ctr == 0)
	    read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
	  backchar(c, 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 */
	    {
	      const 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 */
		{
		  const s7_pointer result = unknown_string_constant(sc, c);
		  if (!is_character(result)) return(result);
		  sc->strbuf[i++] = character(result);
		}
	      /* #f here would give confusing error message "end of input", so return #t=bad backslash.
	       *     this is not optimal. It's easy to forget that backslash needs to be backslashed.
	       * the white_space business half-implements Scheme's \<newline>...<eol>... or \<space>...<eol>...
	       *   feature -- the characters after \ are flushed if they're all white space and include a newline.
	       *   (string->number "1\   2") is 12??  Too bizarre.
	       */
	    }
	  break;

	default:
	  sc->strbuf[i++] = (unsigned char)c;
	  break;
	}
      if (i >= sc->strbuf_size)
	resize_strbuf(sc, i);
    }
}

static void read_double_quote(s7_scheme *sc)
{
  sc->value = read_string_constant(sc, current_input_port(sc));
  if (sc->value == sc->F)                                /* can happen if input code ends in the middle of a string */
    string_read_error_nr(sc, "end of input encountered while in a string");
  if (sc->value == sc->T)
    read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
  if (sc->safety > Immutable_Vector_Safety) set_immutable_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) (if (string=? 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:
	  {
	    s7_pointer val = port_read_sharp(current_input_port(sc))(sc, current_input_port(sc));
	    if (val == sc->no_value)
	      {
		if (sc->tok == Token_Right_Paren)
		  return(val);
		sc->tok = token(sc);
		val = read_expression(sc);
	      }
	    return(val);
	  }

	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.
   * Another way to get here is: (read (call-with-input-file "asdf" #_and)) where call-with-input-file
   * closes the port it opens, but it was passed as the first argument to #_and and returned, so
   * read sees a closed input port (its filename has been freed and set to NULL).
   */
  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);
      if (Eval_Print) fprintf(stderr, "  %s[%d]: %s\n", __func__, __LINE__, display(sc->value));
      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 = 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 (Eval_Print) 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 (Eval_Print) 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)
{
  token_t c = token(sc);
  if (c != Token_Right_Paren) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */
    {
      if (c == Token_Sharp_Const) /* #; as comment that disappears probably, see r7rs tests */
	{
	  const s7_pointer val = cons(sc, car(sc->args), sc->value);
	  if (read_sharp_const(sc))
	    {
	      sc->value = val;
	      return(Goto_Start);
	    }}
      if (is_pair(sc->value))
	{
	  for (s7_pointer p = sc->value; is_pair(p); p = cdr(p))
	    sc->args = cons(sc, car(p), sc->args);
	  sc->tok = c;
	  return(Goto_Read_Tok);
	}
      back_up_stack(sc);
      read_error_nr(sc, "stray dot?");            /* (+ 1 . 2 3) or (list . ) */
    }
  /* args = previously read stuff, value = thing just after the dot and before the ')':
   *   (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1)
   * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a)
   */
  sc->value = any_list_reverse_in_place(sc, sc->value, sc->args);
  return((stack_top_op(sc) == OP_READ_LIST) ? Goto_Pop_Read_List : Goto_Start);
}

static bool op_read_quote(s7_scheme *sc) /* '<datum> -> (#_quote <datum) in s7, not (quote <datum>) because quote is not immutable */
{
  /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */
  if ((sc->safety > Immutable_Vector_Safety) &&
      ((is_pair(sc->value)) || (is_any_vector(sc->value)) || (is_string(sc->value))))
    set_immutable(sc->value);
  sc->value = list_2(sc, (sc->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) [here sc->value is 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) : 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) : 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) : 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
   *   <read each entry...>: push op_read_float_vector (no op_read_list), read, eval,
   *   fill sc->floats, when right-paren make new vector [for multidims, get list->frame]
   */
}

static bool op_read_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) : 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) : 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 ((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))
      {
	if (funclet_function(let) != func) return(false); /* this is confused */
	break;
      }
  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 (Eval_Print) 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)));
	      if (/* (!safe_case) && */ (one_form) && (is_code_constant(sc, car(body))))
		set_optimize_op(code, hop + OP_THUNK_C);
	      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 (Eval_Print) 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));
}

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 (Eval_Print) 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 */
      }

    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 */
}

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 (Eval_Print) 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));
}

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));

  if (!func) unbound_variable_error_nr(sc, car(sc->code));
  if (Eval_Print) 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));
}

static bool op_unknown_aa(s7_scheme *sc) /* we assume in eval that this always returns true (it does -- fixup_unknown_op also 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 (Eval_Print) 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));
}

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 (!func) unbound_variable_error_nr(sc, car(sc->code));
  if (Eval_Print) 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 */
  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 (Eval_Print) 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(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;

      /* T_CLOSURE_STAR almost never happens (9 in s7test.scm, very few others) */
    case T_BACRO: case T_MACRO:           return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func)));
    case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func)));
    }
  return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
}

static bool unknown_any(s7_scheme *sc, s7_pointer func, s7_pointer code)
{
  sc->last_function = func;
  if (is_null(cdr(code))) return(op_unknown(sc));
  if ((is_null(cddr(code))) && (is_normal_symbol(cadr(code)))) return(op_unknown_s(sc));
  set_opt3_arglen(cdr(code), proper_list_length(cdr(code)));
  return(op_unknown_np(sc));
}


/* ---------------- eval type checkers ---------------- */

#if WITH_GCC
#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));})
#else
#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P)))
#endif

#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))))
#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P))))

static bool c_function_is_ok_cadr_caddr(s7_scheme *sc, s7_pointer p)
{
  return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, caddr(p))));
}

static bool c_function_is_ok_cadr_cadadr(s7_scheme *sc, s7_pointer p)
{
  return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p))));  /* cadadr(P) */
}

static bool c_function_is_ok_cadr_caddadr(s7_scheme *sc, s7_pointer p)
{
  return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* caddadr(p) */
}

/* closure_is_ok_1 checks the type and the body length indications
 * closure_is_fine_1 just checks the type (safe or unsafe closure)
 * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1
 * closure_np_is_ok accepts safe/unsafe etc
 */

static /* inline */ bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
{
  const s7_pointer clo = lookup_unexamined(sc, car(code));
  if ((clo == opt1_lambda_unchecked(code)) ||
      ((clo) && /* this fixup check does save time (e.g. cb) */
       (low_type_bits(clo) == type) &&
       ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */
       (set_opt1_lambda(code, clo))))
    return(true);
  sc->last_function = clo;
  return(false);
}

static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
{
  const s7_pointer clo = lookup_unexamined(sc, car(code));
  if ((clo == opt1_lambda_unchecked(code)) ||
      ((clo) &&
       ((low_type_bits(clo) & (Type_Mask | T_Safe_Closure)) == type) &&
       ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) &&
       (set_opt1_lambda(code, clo))))
    return(true);
  sc->last_function = clo;
  return(false);
}

static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code)
{
  const s7_pointer clo = lookup_unexamined(sc, car(code));
  if ((clo == opt1_lambda_unchecked(code)) ||
      ((clo) &&
       (is_closure(clo)) &&
       (set_opt1_lambda(code, clo))))
    return(true);
  sc->last_function = clo;
  return(false);
}

/* 20-Jun-24 calls=closure_is_*, misses=symbol_ctr != 1
   s7test: calls: 974814,   misses: 550785
   full:   calls: 11433106, misses: 6406461
   tlet:   calls: 3600032,  misses: 1900012
   tlamb:  calls: 33000005, misses: 11999999
   tset:   calls: 1329500,  misses: 998
   lt:     calls: 1374000,  misses: 232936
   tmat:   calls: 222206,   misses: 0 (tobj, tsort, tform, tread, tfft, thash, etc)
   so symbol_ctr==1 is valuable
 */

#define closure_is_ok(Sc, Code, Type, Args)        ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args)))
#define closure_np_is_ok(Sc, Code)                 ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code)))
#define closure_is_fine(Sc, Code, Type, Args)      ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args)))
#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args)))

static /* inline */ bool closure_is_eq(s7_scheme *sc)
{
  sc->last_function = lookup_unexamined(sc, car(sc->code));
  return(sc->last_function == opt1_lambda_unchecked(sc->code));
}

static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args)
{
  int32_t arity = closure_star_arity_to_int(sc, val);
  return((arity < 0) || ((arity * 2) >= args));
}

static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
{
  const s7_pointer val = lookup_unexamined(sc, car(code));
  if ((val == opt1_lambda_unchecked(code)) ||
      ((val) &&
       ((low_type_bits(val) & (T_Safe_Closure | Type_Mask)) == type) &&
       (star_arity_is_ok(sc, val, args)) &&
       (set_opt1_lambda(code, val))))
    return(true);
  sc->last_function = val;
  return(false);
}

/* closure_is_fine: */
#define Fine_Unsafe_Closure      (T_CLOSURE)
#define Fine_Safe_Closure        (T_CLOSURE      | T_Safe_Closure)

/* closure_star_is_fine: */
#define Fine_Unsafe_Closure_Star (T_CLOSURE_STAR)
#define Fine_Safe_Closure_Star   (T_CLOSURE_STAR | T_Safe_Closure)

/* closure_is_ok: */
#define Ok_Unsafe_Closure_P      (T_CLOSURE                       | T_One_Form)
#define Ok_Safe_Closure_P        (T_CLOSURE      | T_Safe_Closure | T_One_Form)
#define Ok_Unsafe_Closure_M      (T_CLOSURE                       | T_Multiform)
#define Ok_Safe_Closure_M        (T_CLOSURE      | T_Safe_Closure | T_Multiform)
#define Ok_Safe_Closure_A        (T_CLOSURE      | T_Safe_Closure | T_One_Form_Fx_Arg)
/* since T_Has_Methods is on if there might be methods, this can protect us from that case */

static no_return void eval_apply_error_nr(s7_scheme *sc)
{
  error_nr(sc, sc->syntax_error_symbol, /* apply_error_nr expanded */
	   set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~$?", 29),
		       ((is_symbol_and_keyword(sc->code)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, sc->code)),
		       sc->code,
		       cons(sc, sc->code, sc->args)));
  /* (inlet 'abs #<lambda (x)>) -> error:attempt to apply an integer 0 in (0)?
   *   sc->cur_code here is '(x)  from eval_args4 '(#<lambda (x) >) -> unopt_trailers '(x) from unknown_sharp_constant
   */
}


/* ---------------- eval ---------------- */
static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
#if Eval_Print && s7_Debugging
    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)));
#endif
  sc->cur_op = first_op;
  goto Top_No_Pop;

  while (true) /* "continue" in this procedure refers to this loop */
    {
      pop_stack(sc);
      goto Top_No_Pop;

    Begin:
      if (is_pair(cdr(sc->code)))
	{
	  set_current_code(sc, sc->code);
	  push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
	}
      sc->code = car(sc->code);

    Eval:
      sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_bits) */

    Top_No_Pop:
#if Eval_Print && s7_Debugging
      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)));
#endif
      /* 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)
	{
	case OP_SAFE_C_NC: if (!c_function_is_ok(sc, sc->code)) break;   /* break refers to the switch statement */
	case HOP_SAFE_C_NC: sc->value = fn_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */

	case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto Eval; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */
	case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue;

	case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue;

	case OP_SAFE_C_NS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_NS: sc->value = fx_c_ns(sc, sc->code); continue;

	case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue;

	case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue;

	case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue;

	case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code))  {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_AAP:    if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_AAP:   op_safe_c_aap(sc); goto Eval;
	case OP_SAFE_C_AAP_1:  op_safe_c_aap_1(sc); continue;
	case OP_SAFE_C_AAP_2:  op_safe_c_aap_2(sc); continue;

	case OP_SAFE_C_SPS:    if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SPS:   op_safe_c_sps(sc); goto Eval;
	case OP_SAFE_C_SPS_1:  op_safe_c_sps_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_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_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_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue;

	case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue;

	case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue;

	case OP_SAFE_C_CCS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_CCS: sc->value = fx_c_ccs(sc, sc->code); continue;

	case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue;

	case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue;

	case OP_SAFE_C_opNCq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opNCq: sc->value = fx_c_opncq(sc, sc->code); continue;

	case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue;

	case OP_SAFE_C_op_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break;
	case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue;     /* lg cb (splits to not) */

	case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break;
	case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; /* tlet sg (splits to not) */

	case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break;
	case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; /* lg cb (splits to not etc) */

	case OP_SAFE_C_PS:    if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_PS:   op_safe_c_ps(sc); goto Eval;
	case OP_SAFE_C_PS_1:  op_safe_c_ps_1(sc); continue;

	case OP_SAFE_C_PC:    if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_PC:   op_safe_c_pc(sc); goto Eval;
	case OP_SAFE_C_PC_1:  op_safe_c_pc_1(sc); continue;

	case OP_SAFE_C_SP:    if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_SP:   op_safe_c_sp(sc); goto Eval;
	case OP_SAFE_C_SP_1:  op_safe_c_sp_1(sc); continue;

	case OP_SAFE_CONS_SP_1:     sc->value = cons(sc, sc->args, sc->value); continue;
	case OP_SAFE_ADD_SP_1:      op_safe_add_sp_1(sc); continue;
	case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue;

	case OP_SAFE_C_AP: if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_AP: op_safe_c_ap(sc); goto Eval;

	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 splice_safe_c_sp_mv */

	case OP_SAFE_C_PP:      if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_PP:     op_safe_c_pp(sc);      goto Eval;
	case OP_SAFE_C_PP_1:    op_safe_c_pp_1(sc);    goto Eval;
	case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto Eval;
	case OP_SAFE_C_PP_5:    op_safe_c_pp_5(sc);    continue;

	case OP_SAFE_C_3P:      if (!c_function_is_ok(sc, sc->code)) break;
	case HOP_SAFE_C_3P:     op_safe_c_3p(sc);      goto Eval;
	case OP_SAFE_C_3P_1:    op_safe_c_3p_1(sc);    goto Eval;
	case OP_SAFE_C_3P_2:    op_safe_c_3p_2(sc);    goto Eval;
	case OP_SAFE_C_3P_3:    op_safe_c_3p_3(sc);    continue;
	case OP_SAFE_C_3P_1_MV: op_safe_c_3p_1_mv(sc); goto Eval;
	case OP_SAFE_C_3P_2_MV: op_safe_c_3p_2_mv(sc); goto Eval;
	case OP_SAFE_C_3P_3_MV: op_safe_c_3p_3_mv(sc); continue;

	case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue;

	case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue;

	case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue;

	case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue;

	case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue;

	case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue;

	case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue;

	case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue;

	case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue;

	case OP_SAFE_C_op_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break;
	case HOP_SAFE_C_op_opSSqq_S: sc->value = fx_c_op_opssqq_s(sc, sc->code); continue;

	case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue;

	case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue;

	case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue;

	case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue;

	case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue;

	case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue;

	case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue;

	case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue;

	case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue;

	case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue;

	case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue;

	case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue;

	case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
	case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue;


	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 */


	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_THUNK_C: if (!closure_is_ok(sc, sc->code, Ok_Unsafe_Closure_P, 0)) {if (op_unknown(sc)) goto Eval; continue;}
	case HOP_THUNK_C: if (op_thunk_c(sc)) goto Eval; continue;

	case OP_SAFE_THUNK: if (!closure_is_fine(sc, sc->code, Fine_Safe_Closure, 0)) {if (op_unknown(sc)) goto Eval; continue;}
	case HOP_SAFE_THUNK: op_safe_thunk(sc); goto Eval;

	case OP_THUNK_ANY: if (!closure_is_fine(sc, sc->code, Fine_Unsafe_Closure, 1)) break; /* symbol as arglist */
	case HOP_THUNK_ANY: op_thunk_any(sc); goto Begin;

	case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, Fine_Safe_Closure, 1)) break; /* symbol as arglist */
	case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto Eval;

	case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, Ok_Safe_Closure_A, 0)) {if (op_unknown(sc)) goto Eval; continue;}
	case HOP_SAFE_THUNK_A: sc->value = op_safe_thunk_a(sc, sc->code); continue;

	case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, Fine_Unsafe_Closure, 1)) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_CLOSURE_S: op_closure_s(sc); goto Eval;

	case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, Ok_Unsafe_Closure_P, 1)) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto Eval;

	case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, Fine_Safe_Closure, 1)) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto Eval;

	case OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, Ok_Safe_Closure_P, 1)) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto Eval;

	case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, Ok_Safe_Closure_A, 1)) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue;

	case OP_SAFE_CLOSURE_S_TO_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue;

	case OP_SAFE_CLOSURE_S_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue;

	case OP_SAFE_CLOSURE_A_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_a(sc)) goto Eval; continue;}
	case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_proc(sc->code)(sc, sc->code); continue;

	case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, Fine_Unsafe_Closure, 1))  {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;              goto Unopt; /* car is pair ((if x car cadr) ...) */
	case OP_PAIR_PAIR_S: if (op_pair_pair_s(sc)) goto Eval_Args_Top;   goto Unopt;
	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;      goto Unopt;

	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;
	  /* perhaps in_place is safe here: args=list_1(sc->value) if eval_set2, mv if eval_set2_mv */

	case OP_EVAL_SET2_MV: /* <inds> = sc->value is a mv */
	  push_stack(sc, OP_EVAL_SET2_NO_MV, sc->value, sc->code); /* sc->value = inds */
	  goto Eval_Set2;

	case OP_EVAL_SET2: /* <ind> = sc->value is a normal value */
	  push_stack(sc, OP_EVAL_SET2_NO_MV, list_1(sc, sc->value), sc->code); /* sc->value = ind */
	Eval_Set2:
	  sc->code = sc->args; /* value */
	  sc->cur_op = optimize_op(sc->code);
	  goto Top_No_Pop;

	case OP_EVAL_SET3_NO_MV: op_eval_set3_no_mv(sc); goto Apply; /* <val> is a normal value */

	case OP_EVAL_SET3_MV: /* <inds> = sc->value is a mv */
	  sc->args = (is_null(sc->args)) ? sc->value : pair_append(sc, sc->args, T_Lst(sc->value));
	  goto Eval_Set3;

	case OP_EVAL_SET3: /* <ind> = sc->value is a normal value */
	  sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : pair_append(sc, sc->args, list_1(sc, sc->value)); /* not in_place here */
	Eval_Set3:
	  op_eval_set3(sc);
	  goto Top_No_Pop;

	case OP_EVAL_ARGS1: 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; /* only call on eval_args_no_eval_args */
	      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 (Eval_Print) 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: sc->value = c_function_call(sc->code)(sc, sc->args);  continue;
	    case T_C_FUNCTION_STAR:       sc->value = c_function_call(sc->code)(sc, set_c_function_star_args(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 type in midstream -- normally we fall through */

	Apply_Lambda:
	case OP_APPLY_LAMBDA:
	  inline_apply_lambda(sc);
	  goto Begin;

	case OP_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto Eval; goto Begin;

	case OP_MACROEXPAND_1:
	  switch (op_macroexpand_1(sc)) {case Goto_Begin: goto Begin; case Goto_Eval: goto Eval; case Goto_Start: continue; default: goto Apply_Lambda;}
	case OP_MACROEXPAND:
	  switch (op_macroexpand(sc)) {case Goto_Begin: goto Begin; case Goto_Eval: goto Eval; case Goto_Start: continue; default: goto Apply_Lambda;}


	Heapsort: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto Apply;
	case OP_SORT1: op_sort1(sc); goto Apply;
	case OP_SORT2: if (op_sort2(sc)) continue; goto Heapsort;
	case OP_SORT:  if (!op_sort(sc)) goto Heapsort;
	case OP_SORT3: if (op_sort3(sc)) continue; goto Heapsort;
	case OP_SORT_PAIR_END:   sc->value = vector_into_list(sc, sc->value, car(sc->args)); continue;
	case OP_SORT_VECTOR_END: sc->value = vector_into_fi_vector(sc->value, car(sc->args)); continue;
	case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); continue;

#if s7_Debugging
	case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */
	  fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr);
	  sc->map_call_ctr--;
	  if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;}
	  continue;
#endif
	case OP_MAP_GATHER: inline_op_map_gather(sc);
	case OP_MAP: if (op_map(sc)) continue; goto Apply;

	case OP_MAP_GATHER_1: inline_op_map_gather(sc);
	case OP_MAP_1: if (op_map_1(sc)) continue; goto Begin;

	case OP_MAP_GATHER_2:
	case OP_MAP_GATHER_3: inline_op_map_gather(sc);
	case OP_MAP_2: if (op_map_2(sc)) continue; goto Eval;

	case OP_FOR_EACH:   if (op_for_each(sc)) continue;   goto Apply;
	case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto Begin;

	case OP_FOR_EACH_2:
	case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto Eval;

	case OP_MEMBER_IF:
	case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto Apply;

	case OP_ASSOC_IF:
	case OP_ASSOC_IF1:  if (op_assoc_if(sc)) continue;  goto Apply;


	Safe_Dotimes:         /* check_do */
	case OP_SAFE_DOTIMES: /* gen form */
	  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;
	    }

	Safe_Do:             /* from check_do */
	case OP_SAFE_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;
	    }

	Dotimes_P:           /* from check_do */
	case OP_DOTIMES_P:
	  switch (op_dotimes_p(sc))
	    {
	    case Goto_Do_End_Clauses: goto Do_End_Clauses;
	    case Goto_Do_Unchecked:   goto Do_Unchecked;
	    default:                  goto Eval;
	    }

	Dox:                  /* from check_do */
	case OP_DOX:
	  switch (op_dox(sc)) /* lg fft exit map-hash */
	    {
	    case Goto_Do_End_Clauses: goto Do_End_Clauses;
	    case Goto_Start:          continue;
	    case Goto_Top_No_Pop:     goto Top_No_Pop; /* includes dox_step_o */
	    default:		      goto Begin;
	  }

	Do_No_Body:
	case OP_DO_NO_BODY_NA_VARS:        op_do_no_body_na_vars(sc); goto Eval;
	case OP_DO_NO_BODY_NA_VARS_STEP:   if (op_do_no_body_na_vars_step(sc)) goto Do_End_Clauses; goto Eval;
	case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_vars_step_1(sc)) goto Do_End_Clauses; goto Eval;

	case OP_DO_NO_VARS_NO_OPT:   op_do_no_vars_no_opt(sc); /* fall through */
	case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto Do_End_Clauses; goto Begin;
	case OP_DO_NO_VARS:	     if (op_do_no_vars(sc))          goto Do_End_Clauses; goto Begin;
	case OP_SAFE_DOTIMES_STEP_O: if (op_safe_dotimes_step_o(sc)) goto Do_End_Clauses; goto Eval;
	case OP_SAFE_DOTIMES_STEP:   if (op_safe_dotimes_step(sc))   goto Do_End_Clauses; goto Eval;
	case OP_SAFE_DO_STEP:        if (op_safe_do_step(sc))        goto Do_End_Clauses; goto Begin;
	case OP_SIMPLE_DO:           if (op_simple_do(sc))           goto Do_End_Clauses; goto Begin;
	case OP_SIMPLE_DO_STEP:      if (op_simple_do_step(sc))      goto Do_End_Clauses; goto Begin;
	case OP_DOTIMES_STEP_O:      if (op_dotimes_step_o(sc))      goto Do_End_Clauses; goto Eval;
	case OP_DOX_INIT:            if (op_dox_init(sc))            goto Do_End_Clauses; goto Begin;
	case OP_DOX_STEP:            if (op_dox_step_1(sc))          goto Do_End_Clauses; op_dox_step(sc);   goto Begin;
	case OP_DOX_STEP_O:          if (op_dox_step_1(sc))          goto Do_End_Clauses; op_dox_step_o(sc); goto Eval;
	case OP_DOX_NO_BODY:         op_dox_no_body(sc);             continue;
	case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc);     goto Do_End_Clauses;

	case OP_DO_INIT: if (op_do_init(sc)) goto Do_End; goto Eval; /* looping if need eval for init */

	case OP_DO:
	  if (is_null(check_do(sc)))
	    switch (optimize_op(sc->code))
	      {
 	      case OP_DOX:	    goto Dox;
 	      case OP_SAFE_DOTIMES: goto Safe_Dotimes;
 	      case OP_DOTIMES_P:    goto Dotimes_P;
 	      case OP_SAFE_DO:	    goto Safe_Do;
	      case OP_DO_NO_BODY_NA_VARS: goto Do_No_Body;
 	      case OP_DO_NO_VARS:   if (op_do_no_vars(sc)) goto Do_End_Clauses; goto Begin;
	      case OP_DOX_NO_BODY:  op_dox_no_body(sc); continue;
	      case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto Do_End_Clauses;
	      default:              if (op_simple_do(sc)) goto Do_End_Clauses; goto Begin;
	      }
	case OP_DO_UNCHECKED:
	  op_do_unchecked(sc);
	Do_Unchecked:
	  if (do_unchecked(sc)) goto Eval;

	Do_End:
	case OP_DO_END:
	  if (op_do_end(sc)) goto Eval;

	case OP_DO_END1:
	  if (is_true(sc, sc->value))
	    {
	      goto_t next = op_do_end_true(sc);
	      if (next == Goto_Start) continue;
	      if (next == Goto_Eval) goto Eval;
	      goto Feed_To;
	    }
	  else
	    {
	      goto_t next = op_do_end_false(sc);
	      if (next == Goto_Begin) goto Begin;
	      if (next == Goto_Do_End) goto Do_End;
	      /* fall through */
	    }

	case OP_DO_STEP:  if (op_do_step(sc))  goto Do_End; goto Eval;
	case OP_DO_STEP2: if (op_do_step2(sc)) goto Do_End; goto Eval;

	Do_End_Clauses:
	  if (do_end_clauses(sc)) continue;
	Do_End_Code:
	  {
	    goto_t next = do_end_code(sc);
	    if (next == Goto_Eval) goto Eval;
	    if (next == Goto_Start) continue;
	    goto Feed_To;
	  }


	case OP_BEGIN_UNCHECKED:
	  set_current_code(sc, sc->code);
	  sc->code = T_Pair(cdr(sc->code));
	  goto Begin;

	case OP_BEGIN:
	  if (op_begin(sc, sc->code)) continue;
	  sc->code = T_Pair(cdr(sc->code));

	case OP_BEGIN_HOOK:
	  if (sc->begin_hook)
	    {
	      /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */
	      set_current_code(sc, sc->code);
	      if (call_begin_hook(sc))
		return(sc->F);
	    }
	case OP_BEGIN_NO_HOOK:
	  set_current_code(sc, car(sc->code)); /* better error message if unbound variable: (define (func) (let ((sig 0)) 0) (lcm sig)) (func) */
	  goto Begin;

	case OP_BEGIN_2_UNCHECKED:
	  push_stack_no_args(sc, OP_EVAL, caddr(sc->code));
	  sc->code = cadr(sc->code);
	  goto Eval;

	case OP_BEGIN_AA: sc->value = fx_begin_aa(sc, sc->code); continue;
	case OP_BEGIN_NA: sc->value = fx_begin_na(sc, sc->code); continue;


	case OP_EVAL: goto Eval;
	case OP_EVAL_STRING: op_eval_string(sc); goto Eval;

	case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue;
	case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue;

	case OP_DEFINE_FUNCHECKED: define_funchecked(sc);   continue;
	case OP_DEFINE_CONSTANT1:  op_define_constant1(sc); continue;

	case OP_DEFINE_CONSTANT_UNCHECKED:
	  push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code));
	  goto Defcons;

	case OP_DEFINE_CONSTANT:
	  if (op_define_constant(sc)) continue;

	case OP_DEFINE_STAR: case OP_DEFINE:
	  check_define(sc);

	Defcons:
	case OP_DEFINE_STAR_UNCHECKED:
	case OP_DEFINE_UNCHECKED:
	  if (op_define_unchecked(sc)) goto Top_No_Pop;

	case OP_DEFINE1: if (op_define1(sc)) goto Apply;
	case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue;

	case OP_SET_opSq_A:     if (op_set_opsq_a(sc))     goto Apply; continue;
	case OP_SET_opSAq_A:	if (op_set_opsaq_a(sc))    goto Apply; continue;
	case OP_SET_opSAq_P:    if (op_set_opsaq_p(sc))    goto Apply; goto Eval;
	case OP_SET_opSAq_P_1:  if (op_set_opsaq_p_1(sc))  goto Apply; continue;
	case OP_SET_opSAAq_A:	if (op_set_opsaaq_a(sc))   goto Apply; continue;
	case OP_SET_opSAAq_P:   if (op_set_opsaaq_p(sc))   goto Apply; goto Eval;
	case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto Apply; continue;

	case OP_INCREMENT_BY_1: inline_op_increment_by_1(sc); continue;
	case OP_DECREMENT_BY_1: op_decrement_by_1(sc); continue;
	case OP_INCREMENT_SS:   op_increment_ss(sc);   continue;
	case OP_INCREMENT_SA:   op_increment_sa(sc);   continue;
	case OP_INCREMENT_SAA:  op_increment_saa(sc);  continue;

	case OP_SET_S_C:        op_set_s_c(sc);  continue;
	case OP_SET_S_S:        op_set_s_s(sc);  continue;
	case OP_SET_S_A:        op_set_s_a(sc);  continue;
	case OP_SET_S_P:        op_set_s_p(sc);  goto Eval;
 	case OP_SET_SP_1:	op_set_sp_1(sc); continue;
	case OP_SET_CONS:       op_set_cons(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 -- cadr is settee: (set! (V 0) 2) etc */
	    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 except (set! (with-let (inlet :v (vector 1 2)) (v 0)) '(3 4)) */
	      }
	  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, s_lookup(Sc, opt2_sym(cdr(Sc->code)), Sc->code), opt3_byte(cdr(Sc->code))))
	  #define if_is_type_t_p(Sc) if (gen_type_match(Sc, t_lookup(Sc, opt2_sym(cdr(Sc->code)), Sc->code), opt3_byte(cdr(Sc->code))))
	  #define if_is_not_type_s_p(Sc) if (!gen_type_match(Sc, s_lookup(Sc, opt2_sym(cdr(Sc->code)), 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_T_P:   if_is_type_t_p(sc) {sc->code = opt1_any(sc->code); goto Eval;} sc->value = sc->unspecified; continue; /* titer 140 */
	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_T_R:   if_is_type_t_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_T_P_A: if_is_type_t_p(sc) {sc->code = opt1_any(sc->code); goto Eval;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; /* tstar 33 hash 22 */
	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;
	case OP_IF_IS_TYPE_T_A_P: if_is_type_t_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto Eval; /* cb 37 */

	  #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; /* 1 body expr here and below */
	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_MV:  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_EXPANSION: case OP_EXPANSION_STAR:
	case OP_MACRO: case OP_BACRO: case OP_MACRO_STAR: case OP_BACRO_STAR:
	  op_macro(sc);
	  continue;

	case OP_LAMBDA:                sc->value = op_lambda(sc, sc->code);           continue;
	case OP_LAMBDA_UNCHECKED:      sc->value = op_lambda_unchecked(sc, sc->code); continue;
	case OP_LAMBDA_STAR:           op_lambda_star(sc);                            continue;
	case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc);                  continue;


	case OP_CASE:                     /* car(sc->code) is the selector */
	  /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */
	  if (check_case(sc)) goto Eval; else goto G_G;  /* selector is a symbol or constant, stupid "else" to shut up the compiler */

	case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code));
	G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto Top_No_Pop; goto Feed_To;
	case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code));
	case OP_CASE_E_S:   op_case_e_s(sc); goto Eval;
#if !With_Gmp
	case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S); sc->code = cadr(sc->code); goto Eval;
	case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code));
	case OP_CASE_I_S:   if (op_case_i_s(sc)) continue; goto Eval;
#endif
	case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */
	case OP_CASE_G_S:   op_case_g_s(sc); goto Eval;

	case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code));
	case OP_CASE_E_G:   if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto Top_No_Pop; goto Feed_To;
	case OP_CASE_A_S_G:  /* splitting this case out matters in lint */
	  sc->value = fx_call(sc, cdr(sc->code));
	  if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto Top_No_Pop; else goto Feed_To;

	case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); sc->code = cadr(sc->code); goto Eval;
	case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S); sc->code = cadr(sc->code); goto Eval;
	case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); sc->code = cadr(sc->code); goto Eval;
	case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G); sc->code = cadr(sc->code); goto Eval;
#if !With_Gmp
	case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue;
#endif
	case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue;
	case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue;
	case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue;


	case OP_ERROR_QUIT:
	  if (sc->stack_end <= sc->stack_start) stack_reset(sc);  /* sets stack_end to stack_start, then pushes op_eval_done, (can <= be <?) */
	  return(sc->F);

	case OP_ERROR_HOOK_QUIT:
	  op_error_hook_quit(sc);

	case OP_EVAL_DONE:
	  return(sc->F);

	case OP_SPLICE_VALUES:         /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */
	  sc->value = splice_in_values(sc, sc->args);
	  continue;

	case OP_GC_PROTECT: case OP_BARRIER: case OP_NO_VALUES:
	case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2:
#if Eval_Print && s7_Debugging
	  fprintf(stderr, "  flush %s\n", op_names[sc->cur_op]);
#endif
	  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) /* not otiose -- at this point stack_top_op can be lots of other read ops */
		  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);
		if (stack_top_op(sc) == OP_READ_LIST) goto Pop_Read_List;
		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_call_expansion(sc))
		  {
		  case Goto_Begin:        goto Begin;
		  case Goto_Apply_Lambda: goto Apply_Lambda;
		  case Goto_Start:
		  default:                continue;
		  }
	      break;

	    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;
	    case Token_Eof:          missing_close_paren_error_nr(sc); /* this can happen! (let () #||#<end-of-file> */
	    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;
	    case Goto_Read_Tok: /* from op_read_dot */
	    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", __func__, __LINE__, (int)(sc->cur_op));
	    if (sc->cur_op < Num_Ops)
	      fprintf(stderr, ", %s\n", op_names[sc->cur_op]);
	    else fprintf(stderr, "\n");
	  }
#endif
	  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 (Eval_Print) 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 */
	  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 clause is not a pair: ~S", 36), clause));
  return(cons(sc, cond_expand_clause_to_tree(sc, car(clause)),
	      (is_null(cdr(clause))) ? sc->nil : cond_expand_clause_to_tree(sc, cdr(clause))));
}

static s7_pointer g_cond_expand(s7_scheme *sc, s7_pointer args) /* (reader-cond clause . clauses) */
{
  #define H_cond_expand "(cond-expand clauses) is a way to use cond with *features* without writing honest Scheme code."
  if (!is_pair(args))
    error_nr(sc, sc->syntax_error_symbol, set_elist_1(sc, wrap_string(sc, "cond-expand has no clauses?", 27)));
  for (s7_pointer clauses = args; is_pair(clauses); clauses = cdr(clauses))
    {
      const s7_pointer clause = car(clauses);
      if (!is_pair(clause))
	error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand clause is not a pair: ~S", 36), clause));
      if (((is_symbol(car(clause))) &&
	   ((car(clause) == sc->else_symbol) ||
	    (is_a_feature(car(clause), global_value(sc->features_symbol))))) ||
	  ((is_pair(car(clause))) &&
	   (s7_eval(sc, cond_expand_clause_to_tree(sc, car(clause)), sc->rootlet) == sc->T)))
	{
	  if (is_null(cddr(clause)))
	    return(cadr(clause));
	  return(g_apply_values(sc, list_1(sc, cdr(clause))));
	}
      else
	if ((!is_pair(car(clause))) && (!is_symbol(car(clause))))
	  error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand car(clause) is not a symbol or a pair: ~S", 53), clause));
    }
  return(sc->no_value);
}
#endif


/* -------------------------------- s7_heap_scan -------------------------------- */
#if s7_Debugging
static void mark_holdee(s7_pointer holder, s7_pointer holdee, const char *root)
{
  holdee->holders++;
  if (holder) holdee->holder = holder;
  if (root) holdee->root = root;
}

static void mark_stack_holdees(s7_scheme *sc, s7_pointer stack, s7_int top)
{
  if (stack_elements(stack))
    {
      const s7_pointer heap0 = *(sc->heap);
      const s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size);
      for (s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++)
	{
	  s7_pointer x = *tp++;
	  if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-code");
	  x = *tp++;
	  if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-let");
	  x = *tp++;
	  if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-args");
	}}
}

static void mark_hash_table_holdees(s7_scheme *unused_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_slot_checked(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL);
	  if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL);
	  if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL);
	}
      break;

    case T_C_FUNCTION_STAR:
      if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p)))
	for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg))
	  mark_holdee(p, car(arg), NULL);
      break;

    case T_CLOSURE: case T_CLOSURE_STAR:
    case T_MACRO: case T_MACRO_STAR:
    case T_BACRO: case T_BACRO_STAR:
      mark_holdee(p, closure_pars(p), NULL);
      mark_holdee(p, closure_body(p), NULL);
      mark_holdee(p, closure_let(p), NULL);
      mark_holdee(p, closure_setter_or_map_list(p), NULL);
      break;

    case T_CONTINUATION:
      mark_holdee(p, continuation_op_stack(p), NULL);
      mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p));
      break;

    default: break; /* includes T_C_OBJECT */
    }
}

void s7_heap_analyze(s7_scheme *sc);
void s7_heap_analyze(s7_scheme *sc)
{
  /* clear possible previous data */
  for (s7_int k = 0; k < sc->heap_size; k++)
    {
      s7_pointer obj = sc->heap[k];
      obj->root = NULL;
      obj->holders = 0;
      obj->holder = NULL;
    }
  /* now parcel out all the holdings */
  for (s7_int k = 0; k < sc->heap_size; k++)
    save_holder_data(sc, sc->heap[k]);
  {
    s7_pointer *tmps = sc->free_heap_top;
    s7_pointer *tmps_top = tmps + sc->gc_temps_size;
    if (tmps_top > sc->previous_free_heap_top) tmps_top = sc->previous_free_heap_top;
    while (tmps < tmps_top)
      {
	s7_pointer p = *tmps++;
	mark_holdee(NULL, p, "gc temp");
      }}
  mark_holdee(NULL, sc->v, "sc->v");
  mark_holdee(NULL, sc->w, "sc->w");
  mark_holdee(NULL, sc->x, "sc->x");
  mark_holdee(NULL, sc->y, "sc->y");
  mark_holdee(NULL, sc->z, "sc->z");
  mark_holdee(NULL, sc->temp1, "sc->temp1");
  mark_holdee(NULL, sc->temp2, "sc->temp2");
  mark_holdee(NULL, sc->temp3, "sc->temp3");
  mark_holdee(NULL, sc->temp4, "sc->temp4");
  mark_holdee(NULL, sc->temp5, "sc->temp5");
  mark_holdee(NULL, sc->temp6, "sc->temp6");
  mark_holdee(NULL, sc->temp7, "sc->temp7");
  mark_holdee(NULL, sc->temp8, "sc->temp8");
  mark_holdee(NULL, sc->temp9, "sc->temp9");
  mark_holdee(NULL, sc->rec_p1, "sc->rec_p1");
  mark_holdee(NULL, sc->rec_p2, "sc->rec_p2");
  mark_holdee(NULL, car(sc->t1_1), "car(sc->t1_1)");
  mark_holdee(NULL, car(sc->t2_1), "car(sc->t2_1)");
  mark_holdee(NULL, car(sc->t2_2), "car(sc->t2_2)");
  mark_holdee(NULL, car(sc->t3_1), "car(sc->t3_1)");
  mark_holdee(NULL, car(sc->t3_2), "car(sc->t3_2)");
  mark_holdee(NULL, car(sc->t3_3), "car(sc->t3_3)");
  mark_holdee(NULL, car(sc->t4_1), "car(sc->t4_1)");
#if WITH_T4_N
  mark_holdee(NULL, car(sc->t4_2), "car(sc->t4_2)");
  mark_holdee(NULL, car(sc->t4_3), "car(sc->t4_3)");
  mark_holdee(NULL, car(sc->t4_4), "car(sc->t4_4)");
#endif
  mark_holdee(NULL, car(sc->u1_1), "car(sc->u1_1)");
  mark_holdee(NULL, car(sc->plist_1), "car(sc->plist_1)");
  mark_holdee(NULL, car(sc->plist_2), "car(sc->plist_2)");
  mark_holdee(NULL, car(sc->plist_3), "car(sc->plist_3)");
  mark_holdee(NULL, car(sc->plist_4), "car(sc->plist_4)");
  mark_holdee(NULL, car(sc->qlist_2), "car(sc->qlist_2)");
  mark_holdee(NULL, car(sc->qlist_3), "car(sc->qlist_3)");
  mark_holdee(NULL, car(sc->elist_1), "car(sc->elist_1)");
  mark_holdee(NULL, car(sc->elist_2), "car(sc->elist_2)");
  mark_holdee(NULL, car(sc->elist_3), "car(sc->elist_3)");
  mark_holdee(NULL, car(sc->elist_4), "car(sc->elist_4)");
  mark_holdee(NULL, car(sc->elist_5), "car(sc->elist_5)");
  mark_holdee(NULL, car(sc->elist_6), "car(sc->elist_6)");
  mark_holdee(NULL, car(sc->elist_7), "car(sc->elist_7)");
  mark_holdee(NULL, car(sc->plist_2_2), "cadr(sc->plist_2)");
  mark_holdee(NULL, cadr(sc->plist_3), "cadr(sc->plist_3)");
  mark_holdee(NULL, cadr(sc->elist_2), "cadr(sc->elist_2)");
  mark_holdee(NULL, cadr(sc->elist_3), "cadr(sc->elist_3)");
  mark_holdee(NULL, cadr(sc->qlist_2), "cadr(sc->qlist_2)");
  mark_holdee(NULL, caddr(sc->plist_3), "caddr(sc->plist_3)");
  mark_holdee(NULL, caddr(sc->elist_3), "caddr(sc->elist_3)");
  mark_holdee(NULL, sc->code, "sc->code");
  mark_holdee(NULL, sc->value, "sc->value");
  mark_holdee(NULL, sc->args, "sc->args");
  mark_holdee(NULL, sc->curlet, "sc->curlet");
  mark_holdee(NULL, sc->stack, "sc->stack");
  mark_holdee(NULL, sc->default_random_state, "sc->default_random_state");
  mark_holdee(NULL, sc->temp_error_hook, "sc->temp_error_hook");
  mark_holdee(NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults");
  mark_holdee(NULL, sc->protected_objects, "sc->protected_objects");
  mark_holdee(NULL, sc->protected_setters, "sc->protected_setters");
  mark_holdee(NULL, sc->protected_setter_symbols, "sc->protected_setter_symbols");
  mark_holdee(NULL, sc->error_type, "sc->error_type");
  mark_holdee(NULL, sc->error_data, "sc->error_data");
  mark_holdee(NULL, sc->error_code, "sc->error_code");
  mark_holdee(NULL, sc->error_line, "sc->error_line");
  mark_holdee(NULL, sc->error_file, "sc->error_file");
  mark_holdee(NULL, sc->error_position, "sc->error_position");
#if With_History
  mark_holdee(NULL, sc->error_history, "sc->error_history");
#endif

  for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt))
    mark_holdee(NULL, g->p, "permanent object");

  for (s7_int i = 0; i < sc->protected_objects_size; i++)
    if (vector_element(sc->protected_objects, i) != sc->unused)
      mark_holdee(NULL, vector_element(sc->protected_objects, i), "gc protected object");

  for (s7_int i = 0; i < sc->protected_setters_loc; i++)
    mark_holdee(NULL, vector_element(sc->protected_setters, i), "gc protected setter");

  for (s7_int i = 0; i < sc->setters_loc; i++)
    mark_holdee(NULL, cdr(sc->setters[i]), "setter");

  for (s7_int i = 0; i <= sc->format_depth; i++)
    if (sc->fdats[i])
      mark_holdee(NULL, sc->fdats[i]->curly_arg, "fdat curly_arg");
  {
    s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc);
    for (s7_pointer *p = sc->input_port_stack; p < tp; p++)
      mark_holdee(NULL, *p, "input stack");
  }
  {
    s7_pointer *p = sc->op_stack;
    s7_pointer *tp = sc->op_stack_now;
    while (p < tp) {s7_pointer x = *p++; mark_holdee(NULL, x, "op stack");}
  }
  if (sc->rec_stack)
    for (s7_int i = 0; i < sc->rec_loc; i++)
      mark_holdee(NULL, sc->rec_els[i], "sc->rec_els");
  {
    gc_list_t *gp = sc->opt1_funcs;
    for (s7_int i = 0; i < gp->loc; i++)
      {
	s7_pointer p = T_Pair(gp->list[i]);
	mark_holdee(NULL, opt1_any(p), "opt1_funcs");
      }}
  for (int32_t i = 1; i < Num_Safe_Lists; i++)
    if ((is_pair(sc->safe_lists[i])) &&
	(safe_list_is_in_use(sc->safe_lists[i])))
      for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
	mark_holdee(NULL, car(p), "safe_lists");

  for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg");
  for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg");
  for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range");
  for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range");
  for (s7_pointer slot = sc->rootlet_slots; is_slot_checked(slot); slot = next_slot(slot)) mark_holdee(slot, slot_value(slot), symbol_name(slot_symbol(slot)));
#if With_History
  for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3))
    {
      mark_holdee(NULL, car(p1), "eval history1");
      mark_holdee(NULL, car(p2), "eval history2");
      mark_holdee(NULL, car(p3), "eval history3");
      p1 = cdr(p1);
      if (p1 == sc->eval_history1) break;
    }
#else
  mark_holdee(NULL, sc->cur_code, "current code");
#endif
}

void s7_heap_scan(s7_scheme *sc, int32_t typ);
void s7_heap_scan(s7_scheme *sc, int32_t typ)
{
  bool found_one = false;
  for (s7_int k = 0; k < sc->heap_size; k++)
    {
      const s7_pointer obj = sc->heap[k];
      if (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);
}

static s7_pointer g_heap_analyze(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_heap_analyze "(heap-analyze) gets heap data for subsequent heap-scan"
  #define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol)
  s7_heap_analyze(sc);
  return(sc->F);
}

static s7_pointer g_heap_holder(s7_scheme *sc, s7_pointer args)
{
  #define H_heap_holder "(heap-holder obj) returns the object pointing to obj"
  #define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T)
  s7_pointer obj = car(args);
  if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) return(sc->F);
  return((obj->holder) ? obj->holder : s7_make_string(sc, obj->root));
}

static s7_pointer g_heap_holders(s7_scheme *sc, s7_pointer args)
{
  #define H_heap_holders "(heap-holders obj) returns the number of objects pointing to obj"
  #define Q_heap_holders s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T)
  return(make_integer(sc, car(args)->holders));
}

/* random debugging stuff */
static s7_pointer g_show_stack(s7_scheme *sc, s7_pointer args)
{
  #define H_show_stack "(show-stack ((limit 20)))"
  #define Q_show_stack s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol)
  if ((!is_null(args)) && (s7_is_integer(car(args))))
    {
      const s7_int old_limit = sc->max_show_stack_frames;
      sc->max_show_stack_frames = s7_integer(car(args));
      s7_show_stack(sc);
      sc->max_show_stack_frames = old_limit;
    }
  else s7_show_stack(sc);
  return(sc->F);
}

void s7_show_op_stack(s7_scheme *sc);
void s7_show_op_stack(s7_scheme *sc)
{
  if (sc->op_stack < sc->op_stack_now)
    {
      fprintf(stderr, "op_stack:\n");
      for (s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; (p < tp); p++)
	fprintf(stderr, "  %s\n", display(*p));
    }
  else fprintf(stderr, "op_stack is empty\n");
}

static s7_pointer g_show_op_stack(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_show_op_stack "(show-op-stack) displays the current op_stack"
  #define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol)
  s7_show_op_stack(sc);
  return(sc->F);
}

static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer unused_args)
{
  #define H_is_op_stack "(op-stack?) returns #t if there are entries in the op_stack"
  #define Q_is_op_stack s7_make_signature(sc, 1, sc->is_boolean_symbol)
  return(make_boolean(sc, (sc->op_stack < sc->op_stack_now)));
}
#endif


/* -------------------------------- *s7* let -------------------------------- */

static s7_int starlet_length(void) {return(sl_Num_Fields - 1);}

static s7_pointer g_starlet_set_fallback(s7_scheme *sc, s7_pointer args)
{
  const s7_pointer sym = cadr(args);
  if (!is_symbol(sym))
    sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]);
  if (starlet_symbol_id(sym) == sl_No_Field)
    error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym));
  return(starlet_set_1(sc, sym, caddr(args)));
}

static s7_pointer g_starlet_ref_fallback(s7_scheme *sc, s7_pointer args);

static s7_pointer make_starlet(s7_scheme *sc)  /* *s7* is semipermanent -- 20-May-21 */
{
  const s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "#<*s7*-set>", g_starlet_set_fallback, 3, 0, false, "*s7* writer"));
  const s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "#<*s7*-ref>", g_starlet_ref_fallback, 2, 0, false, "*s7* reader"));
  const s7_pointer star = alloc_pointer(sc);
  set_full_type(star, T_LET | T_Safe_Procedure | T_Unheap | T_Has_Methods | T_Has_Let_Ref_Fallback | T_Has_Let_Set_Fallback);
  let_set_id(star, ++sc->let_number);
  let_set_outlet(star, sc->rootlet);
  symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1);
  slot_set_next(slot1, Slot_End);
  symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2);
  slot_set_next(slot2, slot1);
  let_set_slots(star, slot2);
  set_immutable_slot(slot1);         /* make the *s7* let-ref|set! fallbacks immutable */
  set_immutable_slot(slot2);
  set_immutable_let(star);
  sc->starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, star)); /* define_constant returns the symbol */
  if ((s7_Debugging) && (sl_Num_Fields >= 256)) fprintf(stderr, "too many *s7* fields!\n");
  for (int32_t i = 1; i < (int32_t)sl_Num_Fields; i++)
    {
      s7_pointer sym = make_symbol_with_strlen(sc, starlet_names[i]);
      starlet_symbol_set_id(sym, (starlet_t)i);
    }
  return(star);
}

static void add_symbol_table(s7_scheme *sc, s7_pointer mu_let)
{
  /* check the symbol table, counting gensyms etc */
  s7_int num_syms = 0, gens = 0, keys = 0, mx_list = 0, mxs = 0;
  s7_pointer *els = vector_elements(sc->symbol_table);
  for (s7_int i = 0; i < Symbol_Table_Size; i++)
    {
      s7_int k = 0;
      for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms), k++)
	{
	  num_syms++;
	  if (is_gensym(car(syms))) gens++;
	  if (is_keyword(car(syms))) keys++;
	}
      if (k > mx_list) {mx_list = k; mxs = 1;}
      else if (k == mx_list) mxs++;
    }
  add_slot_unchecked_with_id(sc, mu_let, sc->symbol_table_symbol,
			     s7_inlet(sc,
			       s7_list(sc, 10,
				       sc->size_symbol, make_integer(sc, Symbol_Table_Size),
				       make_symbol(sc, "max-bin", 7), cons(sc, make_integer(sc, mx_list), make_integer(sc, mxs)),
				       make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, num_syms), make_integer(sc, num_syms - gens - keys)),
				       make_symbol(sc, "gensyms", 7), make_integer(sc, gens),
				       make_symbol(sc, "keys", 4),    make_integer(sc, keys))));
}

static s7_pointer kmg(s7_scheme *sc, s7_int bytes)
{
  #define Kmg_Bufsize 128
  block_t *b = mallocate(sc, Kmg_Bufsize);
  int32_t len;
  if (bytes < 1000)
    len = snprintf((char *)block_data(b), Kmg_Bufsize, "%" ld64, bytes);
  else
    if (bytes < 1000000)
      len = snprintf((char *)block_data(b), Kmg_Bufsize, "%.1fk", bytes / 1000.0);
    else
      if (bytes < 1000000000)
	len = snprintf((char *)block_data(b), Kmg_Bufsize, "%.1fM", bytes / 1000000.0);
      else len = snprintf((char *)block_data(b), Kmg_Bufsize, "%.1fG", bytes / 1000000000.0);
  return(cons(sc, make_integer(sc, bytes), block_to_string(sc, b, len)));
}

static void add_gc_list_sizes(s7_scheme *sc, s7_pointer mu_let)
{
  /* check the gc lists (finalizations), at startup there are strings/input-strings from the s7_eval_c_string calls for make-hook et el */
  const s7_int len = sc->strings->size + sc->vectors->size + sc->input_ports->size + sc->output_ports->size + sc->input_string_ports->size +
                     sc->continuations->size + sc->c_objects->size + sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size +
                     sc->multivectors->size + sc->weak_refs->size + sc->weak_hash_iterators->size + sc->opt1_funcs->size;

  const int32_t loc = sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + sc->output_ports->loc + sc->input_string_ports->loc +
                      sc->continuations->loc + sc->c_objects->loc + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc +
                      sc->multivectors->loc + sc->weak_refs->loc + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc;

  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists", 8),
   s7_inlet(sc,
     s7_list(sc, 6,
	     make_symbol(sc, "active/total", 12), cons(sc, make_integer(sc, loc), make_integer(sc, len)),
	     make_symbol(sc, "total-bytes", 11), kmg(sc, len * sizeof(s7_pointer)),
	     make_symbol(sc, "lists", 5),
       s7_inlet(sc,
         s7_list(sc, 28,
	   sc->string_symbol,                    cons(sc, make_integer(sc, sc->strings->loc),             make_integer(sc, sc->strings->size)),
	   sc->vector_symbol,                    cons(sc, make_integer(sc, sc->vectors->loc),             make_integer(sc, sc->vectors->size)),
	   sc->hash_table_symbol,                cons(sc, make_integer(sc, sc->hash_tables->loc),         make_integer(sc, sc->hash_tables->size)),
	   make_symbol(sc, "multivector", 11),   cons(sc, make_integer(sc, sc->multivectors->loc),        make_integer(sc, sc->multivectors->size)),
	   make_symbol(sc, "input", 5),          cons(sc, make_integer(sc, sc->input_ports->loc),         make_integer(sc, sc->input_ports->size)),
	   make_symbol(sc, "output", 6),         cons(sc, make_integer(sc, sc->output_ports->loc),        make_integer(sc, sc->output_ports->size)),
	   make_symbol(sc, "input-string", 12),  cons(sc, make_integer(sc, sc->input_string_ports->loc),  make_integer(sc, sc->input_string_ports->size)),
	   make_symbol(sc, "continuation", 12),  cons(sc, make_integer(sc, sc->continuations->loc),       make_integer(sc, sc->continuations->size)),
	   make_symbol(sc, "c-object", 8),       cons(sc, make_integer(sc, sc->c_objects->loc),           make_integer(sc, sc->c_objects->size)),
	   sc->gensym_symbol,                    cons(sc, make_integer(sc, sc->gensyms->loc),             make_integer(sc, sc->gensyms->size)),
	   make_symbol(sc, "undefined", 9),      cons(sc, make_integer(sc, sc->undefineds->loc),          make_integer(sc, sc->undefineds->size)),
	   make_symbol(sc, "weak-ref", 8),       cons(sc, make_integer(sc, sc->weak_refs->loc),           make_integer(sc, sc->weak_refs->size)),
	   make_symbol(sc, "weak-hash-iter", 14),cons(sc, make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)),
	   make_symbol(sc, "opt1-func", 9),      cons(sc, make_integer(sc, sc->opt1_funcs->loc),          make_integer(sc, sc->opt1_funcs->size)))))));
}

/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids
 *   using ca 100 cells for the let slots/values.  We would need the fallbacks anyway for 'files et al.
 *   Since most of the fields need special setters, it's actually less code this way.  See old/s7-let-s7.c.
 */

#if !_WIN32 /* (!MS_Windows) */
  #include <sys/resource.h>
#endif

static s7_pointer memory_usage(s7_scheme *sc)
{
  s7_int len, in_use = 0, all_len = 0;
  gc_list_t *gp;
  s7_int ts[Num_Types];

#if !_WIN32 /* (!MS_Windows) */
  struct rusage info;
  struct timeval ut;
#endif

  const s7_pointer mu_let = s7_inlet(sc, sc->nil);
  const s7_int gc_loc = gc_protect_1(sc, mu_let);

  check_free_heap_size(sc, 2048);

#if !_WIN32 /* (!MS_Windows) */
  getrusage(RUSAGE_SELF, &info);
#ifdef __APPLE__
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss));
  /* apple docs say this is in kilobytes, but apparently that is an error */
#else
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss * 1024));
  /* why does this number sometimes have no relation to RES in top? */
#endif
  ut = info.ru_utime;
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time", 12), make_real(sc, ut.tv_sec + (floor(ut.tv_usec / 1000.0) / 1000.0)));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock)));
#endif
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "elapsed-time", 12), make_real(sc, (double)(my_clock() - sc->overall_start_time) / ticks_per_second()));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, let_length(sc, sc->rootlet)));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9),
			     cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer)))));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size", 9), make_integer(sc, sizeof(s7_cell)));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-freed", 14), make_integer(sc, sc->gc_total_freed));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-time", 13), make_real(sc, (double)(sc->gc_true_total_time) / ticks_per_second()));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-calls", 8), make_integer(sc, sc->gc_true_calls));

  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small-ints", 10),
			     cons(sc, make_integer(sc, Num_Small_Ints), kmg(sc, Num_Small_Ints * sizeof(s7_cell))));
  add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-cells", 15),
			     cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell))));
  {
    s7_int i = 0;
    for (gc_obj_t *g = sc->semipermanent_objects; g; i++, g = (gc_obj_t *)(g->nxt));
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-objects", 17), make_integer(sc, i));
  }
  {
    s7_int i = 0;
    for (gc_obj_t *g = sc->semipermanent_lets; g; i++, g = (gc_obj_t *)(g->nxt));
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-lets", 14), make_integer(sc, i));
  }
  /* safe_lists */
  {
    s7_int live = 0, lines_in_use = 0, line_used = 0;
    for (s7_int i = 1; i < Num_Safe_Lists; i++)
      if (is_pair(sc->safe_lists[i]))
	{
	  live++;
	  if (safe_list_is_in_use(sc->safe_lists[i])) {lines_in_use++; line_used = i;}
	}
#if s7_Debugging
    begin_temp(sc->y, sc->nil);
    for (s7_int i = Num_Safe_Lists - 1; i > 0; i--) /* omit safe_lists[0]=() since it is never used */
      sc->y = cons(sc, make_integer(sc, sc->safe_list_uses[i]), sc->y);
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10),
			       (lines_in_use == 0) ? list_3(sc, small_int(live), Int_Zero, sc->y) :
			                             list_4(sc, small_int(live), small_int(lines_in_use), small_int(line_used), sc->y));
    end_temp(sc->y);
#else
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10),
			       (lines_in_use == 0) ? list_2(sc, small_int(live), Int_Zero) :
			                              list_3(sc, small_int(live), small_int(lines_in_use), small_int(line_used)));
#endif
  }
  /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */
  if ((s7_Debugging) && (sc->heap_size > sc->max_heap_size))
    fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size);
  for (s7_int i = 0; i < Num_Types; i++) ts[i] = 0;
  for (s7_int k = 0; k < sc->heap_size; k++)
    ts[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)));
  /* vectors */
  {
    s7_int vlen = 0, vs = 0, flen = 0, fvs = 0, clen = 0, cvs = 0, ilen = 0, ivs = 0, blen = 0, bvs = 0;
    gp = sc->vectors;
    for (s7_int k = 0; k < 2; k++, gp = sc->multivectors)
      for (s7_int i = 0; i < gp->loc; i++)
	{
	  const s7_pointer vec = gp->list[i];
	  if (is_float_vector(vec))
	    {fvs++; flen += vector_length(vec);}
	  else
	    if (is_int_vector(vec))
	      {ivs++; ilen += vector_length(vec);}
	    else
	      if (is_complex_vector(vec))
		{cvs++; clen += vector_length(vec);}
	      else
		if (is_byte_vector(vec))
		  {bvs++; blen += vector_length(vec);}
		else {vs++; vlen += vector_length(vec);}
	}
    all_len += blen + ilen * sizeof(s7_int) + flen * sizeof(s7_double) + vlen * sizeof(s7_pointer);
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "vectors", 7),
			       s7_inlet(sc,
			         s7_list(sc, 12,
				   make_symbol(sc, "total", 5),   make_integer(sc, sc->vectors->loc + sc->multivectors->loc),
				   make_symbol(sc, "normal", 6),  cons(sc, make_integer(sc, vs), make_integer(sc, vlen)),
				   make_symbol(sc, "float", 5),   cons(sc, make_integer(sc, fvs), make_integer(sc, flen)),
				   make_symbol(sc, "int", 3),     cons(sc, make_integer(sc, ivs), make_integer(sc, ilen)),
				   make_symbol(sc, "complex", 7), cons(sc, make_integer(sc, cvs), make_integer(sc, clen)),
				   make_symbol(sc, "byte", 4),    cons(sc, make_integer(sc, bvs), make_integer(sc, blen)))));
  }
  /* hash-tables */
  {
    s7_int hlen = 0;
    gp = sc->hash_tables;
    for (s7_int i = 0; i < gp->loc; i++)
    {
      const s7_pointer table = gp->list[i];
      hlen += ((hash_table_size(table)) * sizeof(hash_entry_t *));
      hlen += (hash_table_entries(table) * sizeof(hash_entry_t));
    }
    all_len += hlen; /* was adding all_len?? 11-Apr-25 */
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "hash-tables", 11),
			       cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen)));
  }
  /* ports */
  add_slot_unchecked_with_id(sc, mu_let,
			     make_symbol(sc, "input-port-stack", 16),
			     cons(sc, make_integer(sc, sc->input_port_stack_loc), make_integer(sc, sc->input_port_stack_size)));
  gp = sc->input_ports;
  len = 0;
  for (s7_int i = 0; i < gp->loc; i++)
    {
      s7_pointer port = gp->list[i];
      if (port_data(port)) len += port_data_size(port);
    }
  add_slot_unchecked_with_id(sc, mu_let,
			     make_symbol(sc, "input-ports", 11),
			     cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len)));

  gp = sc->input_string_ports;
  len = 0;
  for (s7_int i = 0; i < gp->loc; i++)
    {
      s7_pointer port = gp->list[i];
      if (port_data(port)) len += port_data_size(port);
    }
  add_slot_unchecked_with_id(sc, mu_let,
			     make_symbol(sc, "input-string-ports", 18),
			     cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, len)));

  {
    int32_t files = 0, strings = 0, closed_strings = 0, functions = 0, unknowns = 0;
    gp = sc->output_ports;
    len = 0;
    for (s7_int i = 0; i < gp->loc; i++)
      {
	const s7_pointer port = gp->list[i];
	if (port_data(port)) len += port_data_size(port);
	if (is_string_port(port))
	  {
	    strings++;
	    if (port_is_closed(port)) closed_strings++;
	  }
	else if (is_file_port(port)) files++; else if (is_function_port(port)) functions++; else unknowns++;
      }
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "output-ports", 12),
			       list_3(sc, cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len)),
				      make_symbol(sc, "string/file/func/?", 18),
				      list_4(sc, cons(sc, make_integer(sc, strings), make_integer(sc, closed_strings)),
					     make_integer(sc, files), make_integer(sc, functions), make_integer(sc, unknowns))));
  }

#if s7_Debugging
  {
    s7_int i = 0;
    for (s7_pointer ports = sc->format_ports; ports; i++, ports = (s7_pointer)port_next(ports));
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "format-ports-allocated/free/inuse", 33),
			       list_3(sc, make_integer(sc, sc->format_ports_allocated), make_integer(sc, i), make_integer(sc, sc->format_ports_allocated - i)));
    for (i = 0, len = 0; i < sc->file_names_top; i++) len += string_length(sc->file_names[i]);
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "file-names", 10),
			       cons(sc, make_integer(sc, sc->file_names_top), make_integer(sc, len)));
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "c-functions", 11),
			       cons(sc, make_integer(sc, sc->c_functions_allocated), make_integer(sc, sc->c_functions_allocated * (sizeof(c_proc_t) + sizeof(s7_cell)))));
  }
#endif

  /* continuations (sketchy!) */
  gp = sc->continuations;
  len = 0;
  for (s7_int i = 0; i < gp->loc; i++)
    if (is_continuation(gp->list[i]))
      len += continuation_stack_size(gp->list[i]);
  if (len > 0)
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "continuations", 13),
			       cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer))));
  /* c-objects */
  if (sc->c_objects->loc > 0)
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc));
  if (sc->num_c_object_types > 0)
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "c-types", 7),
			       cons(sc, make_integer(sc, sc->num_c_object_types),
				    make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t)))));
				    /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */
#if With_Gmp
  add_slot_unchecked_with_id(sc, mu_let,
			     make_symbol(sc, "bignums", 7),
			     s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc),
				     make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc),
				     make_integer(sc, sc->big_random_states->loc)));
#endif
  /* free-lists (mallocate) */
  {
    s7_int k;
#if s7_Debugging
    s7_int num_blocks = 0;
    s7_pointer ff, frees = make_big_list(sc, Num_Block_Lists, sc->nil);
    s7_pointer fa, allocs = make_big_list(sc, Num_Block_Lists, sc->nil);
    s7_pointer fb, borrows = make_big_list(sc, Num_Block_Lists, sc->nil);
    ff = frees;
    fa = allocs;
    fb = borrows;
#endif
    begin_temp(sc->y, sc->nil);
    len = 0;
    for (s7_int i = 0; i < Top_Block_List; i++)
      {
	k = 0;
	for (block_t *b = sc->block_lists[i]; b; b = block_next(b), k++); /* these are the free blocks awaiting mallocate */
	sc->y = cons(sc, make_integer(sc, k), sc->y);
	len += ((sizeof(block_t) + (1LL << i)) * k);
#if s7_Debugging
	num_blocks += k;
	set_car(ff, make_integer(sc, sc->blocks_freed[i])); ff = cdr(ff);
	set_car(fa, make_integer(sc, sc->blocks_mallocated[i])); fa = cdr(fa);
	set_car(fb, make_integer(sc, sc->blocks_borrowed[i])); fb = cdr(fb);
#endif
      }
    k = 0;
    for (block_t *b = sc->block_lists[Top_Block_List]; b; b = block_next(b), k++)
      len += (sizeof(block_t) + block_size(b));
    sc->y = cons(sc, make_integer(sc, k), sc->y);
    sc->y = proper_list_reverse_in_place(sc, sc->y);
#if s7_Debugging
    num_blocks += k;
    set_car(ff, make_integer(sc, sc->blocks_freed[Top_Block_List]));
    set_car(fa, make_integer(sc, sc->blocks_mallocated[Top_Block_List]));
    set_car(fb, make_integer(sc, sc->blocks_borrowed[Top_Block_List]));
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "blocks-allocated/available/in-use", 33),
			       list_3(sc, make_integer(sc, sc->blocks_allocated), make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated - num_blocks)));
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10),
			       s7_inlet(sc, cons(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)),
						 list_4(sc, cons(sc, make_symbol(sc, "bins", 4), sc->y),
							cons(sc, make_symbol(sc, "allocs", 6), allocs),
							cons(sc, make_symbol(sc, "frees", 5), frees),
							cons(sc, make_symbol(sc, "borrows", 7), borrows)))));
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "wrapper-uses", 12),
			       s7_inlet(sc, s7_list(sc, 7,
						    cons(sc, make_symbol(sc, "strings", 7), make_integer(sc, sc->string_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "integers", 8), make_integer(sc, sc->integer_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "reals", 5), make_integer(sc, sc->real_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "complexes", 9), make_integer(sc, sc->complex_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "lets", 4), make_integer(sc, sc->let_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "slots", 5), make_integer(sc, sc->slot_wrapper_allocs)),
						    cons(sc, make_symbol(sc, "c-pointers", 10), make_integer(sc, sc->c_pointer_wrapper_allocs)))));
#else
    add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10),
			       s7_inlet(sc, list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)),
						   cons(sc, make_symbol(sc, "bins", 4), sc->y))));
#endif
    end_temp(sc->y);
    add_slot_unchecked_with_id(sc, mu_let,
			       make_symbol(sc, "approximate-s7-size", 19),
			       kmg(sc, ((sc->semipermanent_cells + Num_Small_Ints + sc->heap_size) * (sizeof(s7_pointer) + sizeof(s7_cell))) +
				   ((2 * sc->heap_size + Symbol_Table_Size + sc->stack_size) * sizeof(s7_pointer)) +
				   len + all_len));
  }
  s7_gc_unprotect_at(sc, gc_loc);
  /* sc->opts: Opts_Size * sizeof(opt_info) == 32768 currently */
  return(mu_let);
}

static s7_pointer sl_c_types_to_list(s7_scheme *sc)
{
  begin_temp(sc->y, sc->nil);
  for (int32_t i = 0; i < sc->num_c_object_types; i++)           /* c-object type (tag) is i */
    sc->y = cons(sc, sc->c_object_types[i]->scheme_name, sc->y);
  sc->y = proper_list_reverse_in_place(sc, sc->y);               /* so car(types) has tag 0 */
  return_with_end_temp(sc->y);
}

static s7_pointer sl_file_names_to_list(s7_scheme *sc)
{
  begin_temp(sc->y, sc->nil);
  for (int32_t i = 0; i <= sc->file_names_top; i++)
    sc->y = cons(sc, sc->file_names[i], sc->y);
  sc->y = proper_list_reverse_in_place(sc, sc->y);
  return_with_end_temp(sc->y);
}

static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val)
{
#if With_Gmp
  return(s7_int_to_big_integer(sc, s7_integer_clamped_if_gmp(sc, val)));
#else
  return(val);
#endif
}

static s7_pointer sl_history_to_list(s7_scheme *sc)
{
#if With_History
  return(sanitize_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code));
#else
  return(sc->cur_code);
#endif
}

static s7_pointer sl_active_catches_to_list(s7_scheme *sc)
{
  s7_pointer lst = sc->nil;
  for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4)
    switch (stack_op(sc->stack, op_loc))
      {
      case OP_CATCH_ALL:
	lst = cons(sc, sc->T, lst);
	break;
      case OP_CATCH_2: case OP_CATCH_1: case OP_CATCH:
	lst = cons(sc, catch_tag(stack_code(sc->stack, op_loc)), lst);
	break;
      }
  return(reverse_in_place_unchecked(sc, sc->nil, lst));
}

static s7_pointer sl_stack_entries_to_list(s7_scheme *sc, s7_pointer stack, s7_int top)
{
  s7_pointer lst = sc->nil;       /* the stack can contain  anything (like #<unused>): 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);
      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 s7_Debugging
      {
	const opcode_t op = stack_op(stack, i);
	if ((op >= 0) && (op < Num_Ops)) entry = cons_unchecked(sc, make_symbol_with_strlen(sc, op_names[op]), entry);
      }
#endif
      lst = cons_unchecked(sc, entry, lst);
      sc->y = lst;
    }
  end_temp(sc->y);
  return(reverse_in_place_unchecked(sc, sc->nil, lst));
}

static s7_pointer sl_gc_protected_objects_to_list(s7_scheme *sc)
{
  const s7_pointer nv = s7_vector_copy(sc, sc->protected_objects);
  s7_pointer *vals = vector_elements(nv);
  const s7_int len = vector_length(nv);
  for (s7_int i = 0; i < len; i++)
    if (vals[i] == sc->unused)
      vals[i] = sc->F;
  return(nv);
}

static s7_pointer starlet(s7_scheme *sc, s7_int choice)
{
  switch (choice)
    {
    case sl_Accept_All_Keyword_Arguments:  return(make_boolean(sc, sc->accept_all_keyword_arguments));
    case sl_Autoloading:                   return(make_boolean(sc, sc->is_autoloading));
    case sl_Bignum_Precision:              return(make_integer(sc, sc->bignum_precision));
    case sl_Catches:                       return(sl_active_catches_to_list(sc));
    case sl_Cpu_Time:                      return(make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC)); /* cpu, not wall-clock time */
    case sl_C_Types:                       return(sl_c_types_to_list(sc));
    case sl_Debug:                         return(make_integer(sc, sc->debug));
    case sl_Default_Hash_Table_Length:     return(make_integer(sc, sc->default_hash_table_length));
    case sl_Default_Random_State:          return(sc->default_random_state);
    case sl_Default_Rationalize_Error:     return(make_real(sc, sc->default_rationalize_error));
    case sl_Equivalent_Float_Epsilon:      return(make_real(sc, sc->equivalent_float_epsilon));
    case sl_Expansions:                    return(make_boolean(sc, sc->is_expanding));
    case sl_File_Names: case sl_Filenames: return(sl_file_names_to_list(sc));
    case sl_Float_Format_Precision:        return(make_integer(sc, sc->float_format_precision));
    case sl_Free_Heap_Size:                return(make_integer(sc, sc->free_heap_top - sc->free_heap));
    case sl_gc_Freed:                      return(make_integer(sc, sc->gc_freed));
    case sl_Gc_Info:                       return(list_3(sc, make_integer(sc, sc->gc_calls), make_integer(sc, sc->gc_total_time), make_integer(sc, ticks_per_second())));
    case sl_Gc_Protected_Objects:          return(sl_gc_protected_objects_to_list(sc));
    case sl_Gc_Resize_Heap_By_4_Fraction:  return(make_real(sc, sc->gc_resize_heap_by_4_fraction));
    case sl_Gc_Resize_Heap_Fraction:       return(make_real(sc, sc->gc_resize_heap_fraction));
    case sl_Gc_Stats:                      return(make_integer(sc, sc->gc_stats));
    case sl_Gc_Temps_Size:                 return(make_integer(sc, sc->gc_temps_size));
    case sl_Gc_Total_Freed:                return(make_integer(sc, sc->gc_total_freed));
    case sl_Hash_Table_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);
}

s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym) {return(s7_starlet_ref(sc, sym));}

static s7_pointer g_starlet_ref_fallback(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym = cadr(args);
  if (!is_symbol(sym))
    sole_arg_wrong_type_error_nr(sc, sc->let_ref_symbol, sym, sc->type_names[T_SYMBOL]);
  if (is_keyword(sym))
    sym = keyword_symbol(sym);
  return(starlet(sc, starlet_symbol_id(sym)));
}

static s7_pointer starlet_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer symbol, value;
  iterator_position(iterator)++;
  if (iterator_position(iterator) >= sl_Num_Fields)
    return(iterator_quit(sc, iterator));
  symbol = make_symbol_with_strlen(sc, starlet_names[iterator_position(iterator)]);

  if ((iterator_position(iterator) == sl_Stack) ||
      (iterator_position(iterator) == sl_Gc_Protected_Objects) ||
      (iterator_position(iterator) == sl_Memory_Usage))
    value = sc->F;  /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */
  else
    {
      const s7_pointer osw = sc->w;  /* protect against starlet list making [sc->w not in use here?] */
      value = starlet(sc, starlet_symbol_id(symbol));
      if ((s7_Debugging) && (osw != sc->w)) fprintf(stderr, "s7.c[%d]: osw: %s, sc->w: %s, symbol_id: %d %s\n",
						    __LINE__, display(osw), display(sc->w), starlet_symbol_id(symbol), display(symbol));
      sc->w = osw;
    }
  if (iterator_carrier(iterator))
    {
      const s7_pointer 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)
{
  s7_double fv;
  if (!is_real(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]);
  fv = s7_real(val);
  if (is_NaN(fv)) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be nan?", 16));
  if (fv <= 0.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29));
  if (fv > 1.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be greater than 1.0", 33));
  return(fv);
}

static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
  if (s7_integer_clamped_if_gmp(sc, val) <= 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29));
  return(val);
}

static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
  if (s7_integer_clamped_if_gmp(sc, val) < 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25));
  return(val);
}

static s7_pointer sl_set_history_size(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
#if With_History
  s7_pointer p1, p2;
  s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* was geq?!? */
  if (iv > Max_History_Size) iv = Max_History_Size; /* if 1M, tests can be slow -- assume user wants one such test */
  if (iv > sc->true_history_size)
    {
      /* splice in the new cells, reattach the circles */
      s7_pointer p3;
      const s7_pointer next1 = cdr(sc->eval_history1);
      const s7_pointer next2 = cdr(sc->eval_history2);
      const s7_pointer next3 = cdr(sc->history_pairs);
      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;
    }
#else
  sc->history_size = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
#endif
  return(val);
}

#if With_Gmp
static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision)
{
  const mp_prec_t bits = (mp_prec_t)precision;
  if (precision <= 1)                   /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */
    sole_arg_out_of_range_error_nr(sc, wrap_string(sc, "set! (*s7* 'bignum-precision)", 29), wrap_integer(sc, precision), wrap_string(sc, "has to be greater than 1", 24));
  mpfr_set_default_prec(bits);
  mpc_set_default_precision(bits);
  global_slot(sc->pi_symbol)->object.slt.val = big_pi(sc); /* don't check immutable flag here (if debugging) -- i.e. don't use slot_set_value! */
  return(sc->F);
}
#endif

static no_return void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val)
{
  set_elist_6(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): the ~:D list element ~S is ~A but should be ~A", 86),
	      val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ);
  error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6);
}

static no_return void sl_stacktrace_out_of_range_error_nr(s7_scheme *sc, s7_pointer accessor, s7_pointer lst, s7_pointer arg, s7_pointer descr)
{
  error_nr(sc, sc->out_of_range_symbol,
	   set_elist_5(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): ~S => ~S is out of range (~A)", 69), lst, accessor, arg, descr));
}

static s7_pointer sl_set_stacktrace_defaults(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  s7_int code_cols;
  if (!is_pair(val))
    starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]);
  if (s7_list_length(sc, val) != 5)
    starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21));

  if (!s7_is_integer(car(val)))          /* max_frames, default 30 */
    sl_stacktrace_wrong_type_error_nr(sc, 1, car(val), wrap_string(sc, "an integer (max stack frames)", 29), val);
  {
    s7_int i = s7_integer_clamped_if_gmp(sc, car(val));
    if ((i <= 0) || (i > s7_Int32_Max)) /* keep these in sync with g_stacktrace */
      sl_stacktrace_out_of_range_error_nr(sc, sc->car_symbol, val, car(val), wrap_string(sc, "should be 0 < max-frames <= 2^32", 32));
  }
  if (!s7_is_integer(cadr(val)))         /* code_cols, default 45 */
    sl_stacktrace_wrong_type_error_nr(sc, 2, cadr(val), wrap_string(sc, "an integer (code columns)", 25), val);
  code_cols = s7_integer_clamped_if_gmp(sc, cadr(val));
  if ((code_cols <= 8) || (code_cols > 1024))
    sl_stacktrace_out_of_range_error_nr(sc, sc->cadr_symbol, val, cadr(val), wrap_string(sc, "should be 8 < code-columns <= 1024", 34));

  if (!s7_is_integer(caddr(val)))        /* total_cols, default 80 */
    sl_stacktrace_wrong_type_error_nr(sc, 3, caddr(val), wrap_string(sc, "an integer (total columns)", 26), val);
  {
    const 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);
  {
    const s7_int i = s7_integer_clamped_if_gmp(sc, cadddr(val));
    if ((i <= 0) || (i > s7_Int32_Max))
      sl_stacktrace_out_of_range_error_nr(sc, sc->cadddr_symbol, val, cadddr(val), wrap_string(sc, "should be 0 < comment-position <= 2^32", 38));
  }
  if (!is_boolean(s7_list_ref(sc, val, 4)))  /* as_comment, default #f */
    sl_stacktrace_wrong_type_error_nr(sc, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (output-as-comment)", 29), val);

  sc->stacktrace_defaults = copy_proper_list(sc, val);
  return(val);
}

static s7_pointer sl_set_gc_stats(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (is_boolean(val))
    {
      sc->gc_stats = ((val == sc->T) ? Gc_Stats : 0);
      return(val);
    }
  if (!s7_is_integer(val))
    starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->gc_stats = s7_integer_clamped_if_gmp(sc, val);
  if (sc->gc_stats >= 16) /* gc_stats is uint32_t */
    {
      sc->gc_stats = 0;
      starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29));
    }
  return(val);
}

static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) /* ticks_per_second is not settable */
{
  if (val == sc->F) /* for profile.scm?? seems like a bad idea! */
    {
      sc->gc_total_time = 0;
      sc->gc_calls = 0;
    }
  else
    if ((is_pair(val)) && (s7_is_integer(car(val))) &&
	(is_pair(cdr(val))) && (s7_is_integer(cadr(val)))) /* caddr is ticks_per_second which can't sensibly be set */
      {
	sc->gc_total_time = s7_integer(car(val));
	sc->gc_calls = s7_integer(cadr(val));
      }
    else starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of two or three integers (the third is ignored)", 60));
  return(sc->F);
}

static s7_pointer sl_set_profile(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!s7_is_integer(val))
    starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
  sc->profile = s7_integer_clamped_if_gmp(sc, val);
  sc->debug_or_profile = ((sc->debug  > 1) || (sc->profile > 0));
  if (sc->profile > 0)
    {
      if (!is_a_feature(make_symbol(sc, "profile.scm", 11), s7_symbol_value(sc, sc->features_symbol)))
	s7_load(sc, "profile.scm");
      if (!sc->profile_data)
	make_profile_info(sc);
      if (!sc->profile_out)
	sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL);
    }
  return(val);
}

static s7_pointer sl_set_debug(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  sc->debug = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
  sc->debug_or_profile = ((sc->debug  > 1) || (sc->profile > 0));
  if ((sc->debug > 0) &&
      (!is_a_feature(make_symbol(sc, "debug.scm", 9), s7_symbol_value(sc, sc->features_symbol))))
    s7_load(sc, "debug.scm");
  return(val);
}

static s7_pointer sl_set_number_separator(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_character(val))
    starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_CHARACTER]);
  if ((is_char_numeric(val)) || (is_char_whitespace(val)) || (!t_number_separator_p[character(val)]) ||
      (character(val) == 'i') || (character(val) == 'e') || (character(val) == 'E'))
    /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to catch +n_a_n.0 */
    starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a printing, non-numeric character", 33));
  sc->number_separator = character(val);
  return(val);
}

static s7_pointer sl_set_bignum_precision(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int prec = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (prec > (1LL << 32)) /* sc->bignum_precision is uint32_t */
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_2(sc, wrap_string(sc, "(set! (*s7* 'bignum-precision) ~S): new value must be less than (ash 1 32) == 4294967296", 88), val));
  sc->bignum_precision = prec;
#if With_Gmp
  set_bignum_precision(sc, sc->bignum_precision);
  mpfr_set_prec(sc->mpfr_1, sc->bignum_precision);
  mpfr_set_prec(sc->mpfr_2, sc->bignum_precision);
  mpc_set_prec(sc->mpc_1, sc->bignum_precision);
  mpc_set_prec(sc->mpc_2, sc->bignum_precision);
#endif
  return(val);
}

static s7_pointer sl_set_default_hash_table_length(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* protect against this being 9223372036854775807, then being used as a hash-table's size */
  if (iv > sc->max_vector_length)       /* these range limits are from g_make_hash_table */
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'default-hash-table-length) ~D), which is greater than (*s7* 'max-vector-length), ~D", 96),
			 val, wrap_integer(sc, sc->max_vector_length)));
  if (iv >= (1LL << 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));
  if (iv > sc->max_heap_size)
    starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be greater than (*s7* 'max-heap-size)", 46));
  if (iv > sc->heap_size)
    resize_heap_to(sc, iv);
  return(val);
}

static s7_pointer sl_set_max_heap_size(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (iv < sc->heap_size)  /* heap can't be made smaller currently */
    starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be less than the current heap size", 43));
  else sc->max_heap_size = iv; /* else needed??? */
  return(val);
}

static s7_pointer sl_set_initial_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (iv > 1048576) /* just a guess, some joker might try setting this to (*s7* 'most-positive-fixnum)... */
    starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it doesn't need to be this big", 30));
  sc->initial_string_port_length = iv;
  return(val);
}

static s7_pointer sl_set_max_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (iv < sc->initial_string_port_length)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-string-port-length) ~S): new value should not be less than the initial string port length: ~D", 110),
			 val, wrap_integer(sc, sc->initial_string_port_length)));
  sc->max_string_port_length = iv;
  return(val);
}

static s7_pointer sl_set_max_stack_size(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (iv < Initial_Stack_Size)
    error_nr(sc, sc->out_of_range_symbol,
	     set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-stack-size) ~S): new value should not be less than the initial stack size: ~D", 94),
			 val, wrap_integer(sc, Initial_Stack_Size)));
  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]);
#if !With_Gmp
  random_seed(sc->default_random_state) = random_seed(val);
  random_carry(sc->default_random_state) = random_carry(val);
#endif
  return(val);
}

static s7_pointer sl_set_float_format_precision(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  /* float-format-precision should not be huge => hangs in snprintf -- limit by bits in mantissa? */
  s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
  sc->float_format_precision = (iv < Max_Float_Format_Precision) ? iv : Max_Float_Format_Precision;
  return(val);
}

static s7_pointer sl_set_undefined_constant_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->undefined_constant_warnings = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_undefined_identifier_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->undefined_identifier_warnings = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_accept_all_keyword_arguments(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->accept_all_keyword_arguments = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_autoloading(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->is_autoloading = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_profile_prefix(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if ((!is_symbol(val)) && (val != sc->F)) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14));
  sc->profile_prefix = val;
  return(val);
}

static s7_pointer sl_set_profile_info(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (val != sc->F) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23));
  return(clear_profile_info(sc));
}

static s7_pointer sl_set_muffle_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->muffle_warnings = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_openlets(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->has_openlets = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_gc_temps_size(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
  if (sc->gc_temps_size > sc->heap_size) sc->gc_temps_size = sc->heap_size;
  return(make_integer(sc, sc->gc_temps_size));
}

static s7_pointer sl_set_expansions(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  sc->is_expanding = s7_boolean(sc, val);
  return(val);
}

static s7_pointer sl_set_history_enabled(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
  return(make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val))));
}

#if With_r7rs
/* seems ok in gcc 12.2, clang 15, tcc 0.9.27 -- why did I think xxd was needed? */
static const char r7rs_scm[] = "(provide 'r7rs.scm) \n\
(define (vector-map p . args) (apply vector (apply map p args))) \n\
(define (string-map p . args) (apply string (apply map p args))) \n\
(define vector-for-each for-each) \n\
(define string-for-each for-each) \n\
(define* (vector->string v (start 0) end) \n\
  (let ((stop (or end (length v)))) \n\
    (copy v (make-string (- stop start)) start stop))) \n\
(define* (string->vector s (start 0) end) \n\
  (let ((stop (or end (length s)))) \n\
    (copy s (make-vector (- stop start)) start stop))) \n\
(define list-copy copy) \n\
(define vector-copy string->vector) \n\
(define r7rs-string-copy substring) \n\
(define* (vector-copy! dest at src (start 0) end) \n\
  (if (not at) \n\
      (copy dest) \n\
      (if (not src) \n\
	  (copy (subvector dest at)) \n\
	  (if (integer? src) \n\
	      (copy (subvector dest at src)) \n\
	      (let ((len (or end (length src)))) \n\
		(if (or (not (eq? dest src)) \n\
			(<= at start)) \n\
		    (do ((i at (+ i 1)) \n\
			 (k start (+ k 1))) \n\
			((= k len) dest) \n\
		      (set! (dest i) (src k))) \n\
		    (do ((i (- (+ at len) start 1) (- i 1)) \n\
			 (k (- len 1) (- k 1))) \n\
			((< k start) dest) \n\
		      (set! (dest i) (src k))))))))) \n\
(define string-copy! vector-copy!) \n\
(define bytevector byte-vector) \n\
(define bytevector? byte-vector?) \n\
(define make-bytevector make-byte-vector) \n\
(define bytevector-ref byte-vector-ref) \n\
(define bytevector-set! byte-vector-set!) \n\
(define bytevector-copy! vector-copy!) \n\
(define (bytevector->list bv) (copy bv (make-list (length bv)))) \n\
(define (boolean=? . args) \n\
  (or (null? args) \n\
      (and (boolean? (car args)) \n\
	   (let loop ((obj (car args)) (lst (cdr args))) \n\
	     (or (null? lst) \n\
		 (and (eq? obj (car lst)) \n\
		      (loop obj (cdr lst)))))))) \n\
(define (symbol=? . args) \n\
  (or (null? args) \n\
      (and (symbol? (car args)) \n\
	   (let loop ((obj (car args)) (lst (cdr args))) \n\
	     (or (null? lst) \n\
		 (and (eq? obj (car lst)) \n\
		      (loop obj (cdr lst)))))))) \n\
(define char-foldcase char-downcase) \n\
(define string-foldcase string-downcase) \n\
(define (digit-value c) (and (char-numeric? c) (- (char->integer c) (char->integer #\\0)))) \n\
(define (finite? n) (and (number? n) (not (nan? n)) (not (infinite? n)))) \n\
(define exact-integer? integer?) \n\
(define (exact-integer-sqrt i) (let ((sq (floor (sqrt i)))) (values sq (- i (* sq sq))))) \n\
(define inexact exact->inexact) \n\
(define exact inexact->exact) \n\
(define (square x) (* x x)) \n\
(define truncate-quotient quotient) \n\
(define truncate-remainder remainder) \n\
(define floor-remainder modulo) \n\
(define (floor-quotient x y) (floor (/ x y))) \n\
(define (input-port-open? p) (not (port-closed? p))) \n\
(define (output-port-open? p) (not (port-closed? p))) \n\
(define (port? p) (or (input-port? p) (output-port? p))) \n\
(define binary-port? port?) \n\
(define textual-port? port?) \n\
(define (close-port p) (if (input-port? p) (close-input-port p) (close-output-port p))) \n\
(define open-binary-input-file open-input-file) \n\
(define open-binary-output-file open-output-file) \n\
(define (call-with-port port proc) (let ((res (proc port))) (if res (close-port port)) res)) \n\
(define bytevector-u8-ref byte-vector-ref) \n\
(define bytevector-u8-set! byte-vector-set!) \n\
(define bytevector-u8 (dilambda (lambda (b k) (b k)) (lambda (b k c) (set! (b k) c)))) \n\
(define bytevector-length length) \n\
(define bytevector-copy vector-copy!) \n\
(define bytevector-append append) \n\
(define* (write-bytevector bv (port (current-output-port)) (start 0) end) \n\
  (write-bytes port (subvector bv start (or end (length bv)))) \n\
  bv) \n\
(define* (read-bytevector! bv (port (current-input-port)) (start 0) end) \n\
  (let ((v (subvector bv start (or end (length bv))))) \n\
    (let ((nv (read-bytes port (length v) v))) \n\
      (if (zero? (vector-length nv)) #<eof> nv)))) \n\
(define* (read-bytevector k port) \n\
  (let ((bv (read-bytes port k))) \n\
    (if (zero? (vector-length bv)) #<eof> bv))) \n\
(define (get-output-bytevector port) (string->byte-vector (get-output-string port))) \n\
(define (open-input-bytevector bv) (open-input-string (byte-vector->string bv))) \n\
(define open-output-bytevector open-output-string) \n\
(define read-u8 read-byte) \n\
(define write-u8 write-byte) \n\
(define u8-ready? char-ready?) \n\
(define peek-u8 peek-char) \n\
(define* (utf8->string v (start 0) end) \n\
  (if (string? v) \n\
      (substring v start (or end (length v))) \n\
      (substring (byte-vector->string v) start (or end (length v))))) \n\
(define* (string->utf8 s (start 0) end) \n\
  (if (byte-vector? s) \n\
      (copy (subvector s start (or end (length s)))) \n\
      (string->byte-vector (utf8->string s start end)))) \n\
(define write-simple write) \n\
(define (eof-object) #<eof>) \n\
(define-macro (features) '*features*) \n\
(define write-shared write) \n\
(define write-simple write) \n\
(define interaction-environment curlet) \n\
(define-macro (include . files) \n\
  `(begin \n\
     ,@(map (lambda (file) \n\
	      `(load ,file (outlet (curlet)))) \n\
	    files))) \n\
(set! *#readers* (cons (cons #\\; (lambda (s) (if (string=? s \";\") (read)) (values))) *#readers*)) \n\
(define-macro (define-values vars expression) \n\
  `(if (not (null? ',vars)) \n\
       (varlet (curlet) ((lambda ,vars (curlet)) ,expression)))) \n\
(define-macro (let-values vars . body) \n\
  (if (null? vars) \n\
      `(let () ,@body) \n\
      (if (and (pair? vars) \n\
	       (pair? (car vars)) \n\
	       (null? (cdar vars))) \n\
	  `((lambda ,(caar vars) \n\
	      ,@body) \n\
	    ,(cadar vars)) \n\
	  `(with-let (apply sublet (curlet) \n\
			    (list ,@(map (lambda (v) \n\
					   `((lambda ,(car v) \n\
					       (values ,@(map (lambda (name) \n\
								(values (symbol->keyword name) name)) \n\
							      (let args->proper-list ((args (car v))) \n\
								(cond ((symbol? args) \n\
								       (list args)) \n\
								      ((not (pair? args)) \n\
								       args) \n\
								      ((pair? (car args)) \n\
								       (cons (caar args) (args->proper-list (cdr args)))) \n\
								      (else \n\
								       (cons (car args) (args->proper-list (cdr args))))))))) \n\
					     ,(cadr v))) \n\
					 vars))) \n\
	     ,@body)))) \n\
(define-macro (let*-values vals . body) \n\
  (if (null? vals) \n\
      `(let () ,@body) \n\
      (let ((args ()) \n\
	    (exprs ())) \n\
	(for-each \n\
	 (lambda (arg+expr) \n\
	   (set! args (cons (car arg+expr) args)) \n\
	   (set! exprs (cons (cadr arg+expr) exprs))) \n\
	 vals) \n\
	(let ((form `((lambda ,(car args) ,@body) ,(car exprs)))) \n\
	  (if (not (null? (cdr args))) \n\
	      (for-each \n\
	       (lambda (arg expr) \n\
		 (set! form (list (list 'lambda arg form) expr))) \n\
	       (cdr args) \n\
	       (cdr exprs))) \n\
	  form)))) \n\
(define-macro (case-lambda . choices) \n\
  `(lambda args \n\
     (cond ,@(map (lambda (choice) \n\
		    (if (symbol? (car choice)) \n\
			`(else (apply (lambda ,(car choice) ,@(cdr choice)) args)) \n\
			(if (negative? (length (car choice))) \n\
			    `((>= (length args) ,(abs (length (car choice)))) \n\
			      (apply (lambda ,(car choice) ,@(cdr choice)) args)) \n\
			    `((= (length args) ,(length (car choice))) \n\
			      (apply (lambda ,(car choice) ,@(cdr choice)) args))))) \n\
		  (if (and (pair? choices) \n\
			   (string? (car choices))) \n\
		      (cdr choices) ; ignore documentation string \n\
		      choices))))) \n\
(define* (make-parameter init converter) \n\
  (let* ((convert (or converter (lambda (x) x))) \n\
	 (old-values ()) \n\
	 (value (convert init))) \n\
    (lambda () value))) \n\
(define-macro (parameterize vars . body) \n\
  `(dynamic-wind \n\
       (lambda () \n\
	 ,@(map (lambda (var) \n\
		  `(with-let (funclet ,(car var)) \n\
		     (set! old-values (cons value old-values)) \n\
		     (set! value (convert ,(cadr var))))) \n\
		vars)) \n\
       (lambda () \n\
         ,@body) \n\
       (lambda () \n\
	 ,@(map (lambda (var) \n\
		  `(with-let (funclet ,(car var)) \n\
		     (set! value (car old-values)) \n\
		     (set! old-values (cdr old-values)))) \n\
		vars)))) \n\
(apply define (symbol (object->string '(scheme base))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme r5rs))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme read))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme write))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme time))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme file))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme cxr))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme inexact))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme char))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme complex))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme eval))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme process-context))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme case-lambda))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme lazy))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme load))) (inlet) ()) \n\
(apply define (symbol (object->string '(scheme repl))) (inlet) ()) \n\
(define-macro (define-library libname . body) \n\
  `(define ,(symbol (object->string libname)) \n\
     (with-let (sublet (unlet) \n\
			 (cons 'import import) \n\
			 (cons '*export* ()) \n\
			 (cons 'export (define-macro (,(gensym) . names) \n\
					 `(set! *export* (append ',names *export*))))) \n\
       ,@body \n\
       (apply inlet \n\
	      (map (lambda (entry) \n\
		     (if (or (member (car entry) '(*export* export import)) \n\
			     (and (pair? *export*) \n\
				  (not (member (car entry) *export*)))) \n\
			 (values) \n\
			 entry)) \n\
		   (curlet)))))) \n\
(unless (defined? 'r7rs-import-library-filename) \n\
  (define (r7rs-import-library-filename libs) \n\
    (when (pair? libs) \n\
      (unless (eq? (caar libs) 'scheme) \n\
        (let ((lib-filename (let loop ((lib (if (memq (caar libs) '(only except prefix rename)) \n\
						(cadar libs) \n\
						(car libs))) \n\
				       (name \"\")) \n\
			      (set! name (string-append name (symbol->string (car lib)))) \n\
			      (if (null? (cdr lib)) \n\
				  (string-append name \".scm\") \n\
				  (begin \n\
				    (set! name (string-append name \"/\")) \n\
				    (loop (cdr lib) name)))))) \n\
	  (unless (member lib-filename (*s7* 'file-names)) \n\
	    (load lib-filename)))) \n\
      (r7rs-import-library-filename (cdr libs))))) \n\
(define-macro (import . libs) \n\
  `(begin \n\
     (r7rs-import-library-filename ',libs) \n\
     (varlet (curlet) \n\
       ,@(map (lambda (lib) \n\
		(case (car lib) \n\
		  ((only) \n\
		   `((lambda (e names) \n\
		       (apply inlet \n\
			      (map (lambda (name) \n\
				     (cons name (e name))) \n\
				   names))) \n\
		     (symbol->value (symbol (object->string (cadr ',lib)))) \n\
		     (cddr ',lib))) \n\
		  ((except) \n\
		   `((lambda (e names) \n\
		       (apply inlet \n\
			      (map (lambda (entry) \n\
				     (if (member (car entry) names) \n\
					 (values) \n\
					 entry)) \n\
				   e))) \n\
		     (symbol->value (symbol (object->string (cadr ',lib)))) \n\
		     (cddr ',lib))) \n\
		  ((prefix) \n\
		   `((lambda (e prefx) \n\
		       (apply inlet \n\
			      (map (lambda (entry) \n\
				     (cons (string->symbol \n\
					    (string-append (symbol->string prefx) \n\
							   (symbol->string (car entry)))) \n\
					   (cdr entry))) \n\
				   e))) \n\
		     (symbol->value (symbol (object->string (cadr ',lib)))) \n\
		     (caddr ',lib))) \n\
		  ((rename) \n\
		   `((lambda (e names) \n\
		       (apply inlet \n\
			      (map (lambda (entry) \n\
				     (let ((info (assoc (car entry) names))) \n\
				       (if info \n\
					   (cons (cadr info) (cdr entry)) \n\
					   entry))) \n\
				   e))) \n\
		     (symbol->value (symbol (object->string (cadr ',lib)))) \n\
		     (cddr ',lib))) \n\
		  (else \n\
		   `(let ((sym (symbol (object->string ',lib)))) \n\
		      (if (not (defined? sym)) \n\
			  (format () \"~A not loaded~%\" sym) \n\
			  (symbol->value sym)))))) \n\
	      libs)))) \n\
(define (make-promise obj) \n\
  (if (promise? obj) \n\
      obj \n\
      (list (cons #t (lambda () obj)) '+promise+))) \n\
(define (promise? obj) \n\
  (and (pair? obj) \n\
       (pair? (cdr obj)) \n\
       (eq? (cadr obj) '+promise+))) \n\
(define-macro (delay expr) \n\
  `(list (cons #f (lambda () ,expr)) '+promise+)) \n\
(define-macro (delay-force expr) \n\
  `(make-promise ,expr)) \n\
(define (force promise) \n\
  (if (caar promise) \n\
      (if (procedure? (cdar promise)) \n\
	  ((cdar promise)) \n\
	  (cdar promise)) \n\
      (let ((promise* ((cdar promise)))) \n\
        (set-car! (car promise) #t) \n\
	(set-cdr! (car promise) promise*) \n\
	promise*))) \n\
(define (jiffies-per-second) 1000000000) \n\
(define (current-jiffy) \n\
  (let ((res (clock_gettime CLOCK_REALTIME))) \n	\
    (+ (* 1000000000 (cadr res)) (caddr res)))) \n\
(define (current-second) (* 1.0 (time (c-pointer 0 'time_t*)))) \n\
(define get-environment-variable getenv) \n\
(define get-environment-variables getenvs) \n\
(define (os-type) (car (uname))) \n\
(define (cpu-architecture) (cadr (uname))) \n\
(define (machine-name) (caddr (uname))) \n\
(define (os-version) (string-append (list-ref (uname) 3) \" \" (list-ref (uname) 4))) \n\
(define (implementation-name) (copy \"s7\")) \n\
(define (implementation-version) (substring (*s7* 'version) 3 7)) \n\
(unless (defined? 'null-environment) (define (null-environment . args) (rootlet))) \n\
(define (environment . args) (rootlet)) \n\
(define (command-line) \n\
  (let ((lst ())) \n\
    (with-input-from-file \"/proc/self/cmdline\" \n\
      (lambda () \n\
	(do ((c (read-char) (read-char)) \n\
	     (s \"\")) \n\
	    ((eof-object? c) \n\
	     (reverse lst)) \n\
	  (if (char=? c #\\null) \n\
	      (begin \n\
		(set! lst (cons s lst)) \n\
		(set! s \"\")) \n\
	      (set! s (string-append s (string c))))))))) \n\
(define-macro (define-record-type type make ? . fields) \n\
  (let ((obj (gensym)) \n\
	(typ (gensym)) \n\
	(args (map (lambda (field) \n\
		     (values (list 'quote (car field)) \n\
			     (let ((par (memq (car field) (cdr make)))) \n\
			       (and (pair? par) (car par))))) \n\
		   fields))) \n\
    `(begin \n\
       (define (,? ,obj) \n\
	 (and (let? ,obj) \n\
	      (eq? (let-ref ,obj ',typ) ',type))) \n\
       (define ,make \n\
         (inlet ',typ ',type ,@args)) \n\
       ,@(map \n\
	  (lambda (field) \n\
	    (when (pair? field) \n\
	      (if (null? (cdr field)) \n\
		  (values) \n\
		  (if (null? (cddr field)) \n\
		      `(define (,(cadr field) ,obj) \n\
			 (let-ref ,obj ',(car field))) \n\
		      `(begin \n\
			 (define (,(cadr field) ,obj) \n\
			   (let-ref ,obj ',(car field))) \n\
			 (define (,(caddr field) ,obj val) \n\
			   (let-set! ,obj ',(car field) val))))))) \n\
	  fields) \n\
       ',type))) \n\
(define-record-type box-type (box value) box? (value unbox set-box!)) \n\
";

static void r7rs_init(s7_scheme *sc)
{
  sc->access_symbol = make_symbol(sc, "access", 6);
  sc->unlink_symbol = make_symbol(sc, "unlink", 6);
  sc->time_symbol = make_symbol(sc, "time", 4);
  sc->clock_gettime_symbol = make_symbol(sc, "clock_gettime", 13);
  sc->getenvs_symbol = make_symbol(sc, "getenvs", 7);
  sc->uname_symbol = make_symbol(sc, "uname", 5);

#ifdef CLOCK_REALTIME
  s7_define(sc, sc->curlet, make_symbol(sc, "CLOCK_REALTIME", 14), make_integer(sc, (s7_int)CLOCK_REALTIME));
#endif
#ifdef F_OK
  s7_define(sc, sc->curlet, make_symbol(sc, "F_OK", 4), make_integer(sc, (s7_int)F_OK));
#endif
  s7_define(sc, sc->curlet, sc->getenvs_symbol,
            s7_make_typed_function_with_environment(sc, "getenvs", g_getenvs, 0, 0, false, "(getenvs) returns all the environment variables in an alist",
						    s7_make_signature(sc, 1, sc->is_pair_symbol), sc->curlet));
  s7_define(sc, sc->curlet, sc->clock_gettime_symbol,
            s7_make_typed_function_with_environment(sc, "clock_gettime", g_clock_gettime, 1, 0, false, "clock_gettime",
						    s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_integer_symbol), sc->curlet));
  s7_define(sc, sc->curlet, sc->uname_symbol,
            s7_make_typed_function_with_environment(sc, "uname", g_uname, 0, 0, false, "uname",
						    s7_make_signature(sc, 1, sc->is_pair_symbol), sc->curlet));
  s7_define(sc, sc->curlet, sc->unlink_symbol,
            s7_make_typed_function_with_environment(sc, "unlink", g_unlink, 1, 0, false, "int unlink(char*)",
						    s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->curlet));
  s7_define(sc, sc->curlet, sc->access_symbol,
            s7_make_typed_function_with_environment(sc, "access", g_access, 2, 0, false, "int access(char* int)",
						    s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_string_symbol, sc->is_integer_symbol), sc->curlet));
  s7_define(sc, sc->curlet, sc->time_symbol,
            s7_make_typed_function_with_environment(sc, "time", g_time, 1, 0, false, "int time(time_t*)",
						    s7_make_signature(sc, 2, sc->is_integer_symbol, make_symbol(sc, "time_t*", 7)), sc->curlet));
  sc->r7rs_inited = true;
}

static void change_scheme_version(s7_scheme *sc, s7_pointer val) /* val is (*s7* 'scheme-version) at this point */
{
  if (val == sc->r7rs_symbol)
    {
      const s7_pointer args = sc->args;
      gc_protect_via_stack(sc, args);
      r7rs_init(sc);
      s7_load_c_string_with_environment(sc, r7rs_scm, strlen(r7rs_scm), sc->curlet);
      sc->args = args;
      unstack_gc_protect(sc);
    }
  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));
      s7_define(sc, sc->curlet, sc->string_copy_symbol, global_value(sc->substring_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));
	  set_initial_value(sc->string_copy_symbol, initial_value(sc->substring_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_global_value(sc->string_copy_symbol, sc->global_string_copy);
	  if (is_slot(global_slot(sc->delay_symbol))) set_global_value(sc->delay_symbol, sc->global_delay);
	  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);
	  set_initial_value(sc->string_copy_symbol, sc->initial_string_copy);
	  set_initial_value(sc->delay_symbol, sc->initial_delay);
	  /* 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);
	  s7_define(sc, sc->curlet, sc->string_copy_symbol, sc->global_string_copy);
	  s7_define(sc, sc->curlet, sc->delay_symbol, sc->global_delay);
	  /* and local reference to #_eq? ?? */
	}}
}
#endif

static s7_pointer sl_set_scheme_version(s7_scheme *sc, s7_pointer sym, s7_pointer 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 (sc->scheme_version == sc->s7_symbol)
    sc->saved_sharp_readers = slot_value(sc->sharp_readers);

  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 (val == sc->s7_symbol)
    slot_set_value(sc->sharp_readers, sc->saved_sharp_readers);
#if With_r7rs
  change_scheme_version(sc, val);
#endif
  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 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)); abort();}
      if (is_symbol_and_keyword(sym)) {fprintf(stderr, "%s[%d]: %s is a keyword\n", __func__, __LINE__, display(sym)); abort();}
      if (starlet_symbol_id(sym) == sl_No_Field) {fprintf(stderr, "%s[%d]: %s is not an *s7* field\n", __func__, __LINE__, display(sym)); abort();}
    }
  switch (starlet_symbol_id(sym))
    {
    case sl_Accept_All_Keyword_Arguments:  return(sl_set_accept_all_keyword_arguments(sc, sym, val));
    case sl_Autoloading:                   return(sl_set_autoloading(sc, sym, val));
    case sl_Bignum_Precision:              return(sl_set_bignum_precision(sc, sym, val));
    case sl_Catches:                       sl_unsettable_error_nr(sc, sym);
    case sl_Cpu_Time:                      sl_unsettable_error_nr(sc, sym);
    case sl_C_Types:                       sl_unsettable_error_nr(sc, sym);
    case sl_Debug:                         return(sl_set_debug(sc, sym, val));
    case sl_Default_Hash_Table_Length:     return(sl_set_default_hash_table_length(sc, sym, val));
    case sl_Default_Random_State:          return(sl_set_default_random_state(sc, sym, val));
    case sl_Default_Rationalize_Error:     sc->default_rationalize_error = sl_real_geq_0(sc, sym, val); return(val);
    case sl_Equivalent_Float_Epsilon:      sc->equivalent_float_epsilon = sl_real_geq_0(sc, sym, val); return(val);
    case sl_Expansions:                    return(sl_set_expansions(sc, sym, val));
    case sl_File_Names: case sl_Filenames: sl_unsettable_error_nr(sc, sym);
    case sl_Float_Format_Precision:        return(sl_set_float_format_precision(sc, sym, val));
    case sl_Free_Heap_Size:                sl_unsettable_error_nr(sc, sym);
    case sl_gc_Freed:                      sl_unsettable_error_nr(sc, sym);
    case sl_Gc_Total_Freed:                sl_unsettable_error_nr(sc, sym);
    case sl_Gc_Protected_Objects:          sl_unsettable_error_nr(sc, sym);
    case sl_Gc_Temps_Size:                 return(sl_set_gc_temps_size(sc, sym, val));
    case sl_Gc_Resize_Heap_Fraction:       sc->gc_resize_heap_fraction = sl_real_0_to_1(sc, sym, val); return(val);
    case sl_Gc_Resize_Heap_By_4_Fraction:  sc->gc_resize_heap_by_4_fraction = sl_real_0_to_1(sc, sym, val); return(val);
    case sl_Gc_Stats:                      return(sl_set_gc_stats(sc, sym, val));
    case sl_Gc_Info:                       return(sl_set_gc_info(sc, sym, val));
    case sl_Hash_Table_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);
}

s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value)
{
  if (is_symbol(sym))
    {
      if (is_keyword(sym))
	sym = keyword_symbol(sym);
      if (starlet_symbol_id(sym) != sl_No_Field)
	return(starlet_set_1(sc, sym, new_value));
    }
  return(sc->undefined);
}

s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) {return(s7_starlet_set(sc, sym, new_value));}
#define Num_Unsettable_Fields 19

static void init_starlet_immutable_field(void)
{
  const int32_t unsettable_fields[Num_Unsettable_Fields] = {
    sl_Catches, sl_Cpu_Time, sl_C_Types, sl_Filenames, sl_File_Names, sl_Free_Heap_Size, sl_gc_Freed, sl_Gc_Protected_Objects,
    sl_Gc_Total_Freed, sl_Major_Version, sl_Memory_Usage, sl_Minor_Version, sl_Most_Negative_Fixnum, sl_Most_Positive_Fixnum,
    sl_Rootlet_Size, sl_Stack, sl_Stack_size, sl_Stack_top, sl_Version};

  starlet_immutable_field = (bool *)Calloc(sl_Num_Fields, sizeof(bool));
  for (int32_t i = 0; i < Num_Unsettable_Fields; i++) starlet_immutable_field[unsettable_fields[i]] = true;
}

/* (let-temporarily (((*s7* 'safety) 1)) (object->string (inlet *s7*) :readable)): this uses :fields reversed with immutable! on the filenames */


/* ---------------- gdbinit annotated stacktrace ---------------- */
#if !MS_Windows
/* s7bt, s7btfull: gdb stacktrace decoding */

static const char *decoded_name(s7_scheme *sc, const s7_pointer p)
{
  if (p == sc->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("#<eof>");
  if (p == sc->undefined)           return("#<undefined>");
#if s7_Debugging
  if (p == sc->unspecified)         return("#<unspecified>");
  if (p == sc->no_value)            return("#<no-value>");
  if (p == sc->do_unspecified)      return("#<do-unspecified>");
#else
  if (is_unspecified(p))            return("#<unspecified>");
#endif
  if (p == sc->unused)              return("#<unused>");
  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 s7_Debugging
  {
    const char *dname = pointer_to_name(sc, p, __func__);
    if (dname) return(dname);
  }
#endif
  if (p == sc->value)   return("s7->value");
  if (p == sc->args)    return("s7->args");
  if (p == sc->code)    return("s7->code");
  return((p == sc->stack) ? "stack" : NULL);
}

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);
  {
    /* check the heap */
    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;
      uint8_t *bt;
      block_t *bt_block;

      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)))
				      {
					const 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);
    }
  return("");
}
#endif


/* -------------------------------- initialization -------------------------------- */
static void init_fx_function(void)
{
  fx_function = (s7_function *)Calloc(Num_Ops, sizeof(s7_function));

  fx_function[HOP_SAFE_C_NC] = fx_c_nc;
  fx_function[HOP_SAFE_C_S] = fx_c_s;
  fx_function[HOP_SAFE_C_SC] = fx_c_sc;
  fx_function[HOP_SAFE_C_CS] = fx_c_cs;
  fx_function[HOP_SAFE_C_CQ] = fx_c_cq;
  fx_function[HOP_SAFE_C_FF] = fx_c_ff;
  fx_function[HOP_SAFE_C_SS] = fx_c_ss;
  fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq;
  fx_function[HOP_SAFE_C_opSq] = fx_c_opsq;
  fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq;
  fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq;
  fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq;
  fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s;
  fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c;
  fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs;
  fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
  fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
  fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
  fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s;
  fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq;
  fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c;
  fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c;
  fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s;
  fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq;
  fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq;
  fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq;
  fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq;
  fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq;
  fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq;
  fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq;
  fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq;
  fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq;
  fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq;
  fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq;
  fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s;

  fx_function[HOP_SAFE_C_SSC] = fx_c_ssc;
  fx_function[HOP_SAFE_C_SSS] = fx_c_sss;
  fx_function[HOP_SAFE_C_SCS] = fx_c_scs;
  fx_function[HOP_SAFE_C_SCC] = fx_c_scc;
  fx_function[HOP_SAFE_C_CSS] = fx_c_css;
  fx_function[HOP_SAFE_C_CSC] = fx_c_csc;
  fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
  fx_function[HOP_SAFE_C_NS] = fx_c_ns;

  fx_function[HOP_SAFE_C_A] = fx_c_a;
  fx_function[HOP_SAFE_C_AA] = fx_c_aa;
  fx_function[HOP_SAFE_C_SA] = fx_c_sa;
  fx_function[HOP_SAFE_C_AS] = fx_c_as;
  fx_function[HOP_SAFE_C_CA] = fx_c_ca;
  fx_function[HOP_SAFE_C_AC] = fx_c_ac;
  fx_function[HOP_SAFE_C_AAA] = fx_c_aaa;
  fx_function[HOP_SAFE_C_CAC] = fx_c_cac;
  fx_function[HOP_SAFE_C_CSA] = fx_c_csa;
  fx_function[HOP_SAFE_C_SCA] = fx_c_sca;
  fx_function[HOP_SAFE_C_SAS] = fx_c_sas;
  fx_function[HOP_SAFE_C_SAA] = fx_c_saa;
  fx_function[HOP_SAFE_C_SSA] = fx_c_ssa;
  fx_function[HOP_SAFE_C_ASS] = fx_c_ass;
  fx_function[HOP_SAFE_C_AGG] = fx_c_agg;
  fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
  fx_function[HOP_SAFE_C_NA] = fx_c_na;
  fx_function[HOP_SAFE_C_4A] = fx_c_4a;
  fx_function[HOP_SAFE_C_opAq] = fx_c_opaq;
  fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq;
  fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq;
  fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s;
  fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq;
  fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq;

  fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment;

  fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
  fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
  fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a;
  fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a;
  fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a;
  fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a;
  fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
  fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc;
  fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc;

  fx_function[OP_COND_NA_NA] = fx_cond_na_na;
#if !With_Gmp
  fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a;
#endif
  fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a;
  fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a;
  fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a;
  fx_function[OP_IF_A_C_C] = fx_if_a_c_c;
  fx_function[OP_IF_A_A] = fx_if_a_a;
  fx_function[OP_IF_S_A_A] = fx_if_s_a_a;
  fx_function[OP_IF_A_A_A] = fx_if_a_a_a;
  fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a;
  fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
  fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a;
  fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a;
  fx_function[OP_OR_2A] = fx_or_2a;
  fx_function[OP_OR_S_2] = fx_or_s_2;
  fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2;
  fx_function[OP_OR_3A] = fx_or_3a;
  fx_function[OP_OR_N] = fx_or_n;
  fx_function[OP_AND_2A] = fx_and_2a;
  fx_function[OP_AND_S_2] = fx_and_s_2;
  fx_function[OP_AND_3A] = fx_and_3a;
  fx_function[OP_AND_N] = fx_and_n;
  fx_function[OP_BEGIN_NA] = fx_begin_na;
  fx_function[OP_BEGIN_AA] = fx_begin_aa;
  fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a;
  fx_function[OP_WITH_LET_S] = fx_with_let_s;

  fx_function[OP_IMPLICIT_STARLET_REF_S] =    fx_implicit_starlet_ref_s;
  fx_function[OP_IMPLICIT_LET_REF_C] =        fx_implicit_let_ref_c;
  fx_function[OP_IMPLICIT_HASH_TABLE_REF_A] = fx_implicit_hash_table_ref_a;
  fx_function[OP_IMPLICIT_PAIR_REF_A] =       fx_implicit_pair_ref_a;
  fx_function[OP_IMPLICIT_C_OBJECT_REF_A] =   fx_implicit_c_object_ref_a;
  fx_function[OP_IMPLICIT_VECTOR_REF_A] =     fx_implicit_vector_ref_a;

  /* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */
  /*   these choices make only a small difference (< 1%) in timings except in tclo */
  fx_function[OP_TC_AND_A_OR_A_LA] = op_tc_and_a_or_a_la;
  fx_function[OP_TC_OR_A_AND_A_LA] = op_tc_or_a_and_a_la;
  fx_function[OP_TC_OR_A_A_AND_A_A_LA] = op_tc_or_a_a_and_a_a_la;
  fx_function[OP_TC_AND_A_OR_A_L2A] = op_tc_and_a_or_a_l2a;
  fx_function[OP_TC_OR_A_AND_A_L2A] = op_tc_or_a_and_a_l2a;
  fx_function[OP_TC_AND_A_OR_A_L3A] = op_tc_and_a_or_a_l3a;
  fx_function[OP_TC_OR_A_AND_A_L3A] = op_tc_or_a_and_a_l3a;
  fx_function[OP_TC_AND_A_OR_A_A_LA] = op_tc_and_a_or_a_a_la;
  fx_function[OP_TC_OR_A_AND_A_A_LA] = op_tc_or_a_and_a_a_la;
  fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la;
  fx_function[OP_TC_IF_A_Z_L2A] = fx_tc_if_a_z_l2a;
  fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a;
  fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la;
  fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z;
  fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la;
  fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z;
  fx_function[OP_TC_IF_A_Z_IF_A_L2A_Z] = fx_tc_if_a_z_if_a_l2a_z;
  fx_function[OP_TC_IF_A_Z_IF_A_Z_L2A] = fx_tc_if_a_z_if_a_z_l2a;
  fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a;
  fx_function[OP_TC_IF_A_Z_IF_A_Z_L3A] = fx_tc_if_a_z_if_a_z_l3a;
  fx_function[OP_TC_IF_A_Z_IF_A_L3A_Z] = fx_tc_if_a_z_if_a_l3a_z;
  fx_function[OP_TC_CASE_LA] = fx_tc_case_la;
  fx_function[OP_TC_CASE_L2A] = fx_tc_case_l2a;
  fx_function[OP_TC_CASE_L3A] = fx_tc_case_l3a;
  fx_function[OP_TC_OR_A_AND_A_A_L3A] = op_tc_or_a_and_a_a_l3a;
  fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la;
  fx_function[OP_TC_LET_IF_A_Z_L2A] = fx_tc_let_if_a_z_l2a;
  fx_function[OP_TC_LET_WHEN_L2A] = op_tc_let_when_l2a;
  fx_function[OP_TC_LET_COND] = fx_tc_let_cond;
  fx_function[OP_TC_COND_N] = fx_tc_cond_n;
  fx_function[OP_TC_COND_A_Z_A_L2A_L2A] = fx_tc_cond_a_z_a_l2a_l2a;
  fx_function[OP_TC_WHEN_LA] = op_tc_when_la;
  fx_function[OP_TC_WHEN_L2A] = op_tc_when_l2a;
  fx_function[OP_TC_WHEN_L3A] = op_tc_when_l3a;

  fx_function[OP_RECUR_IF_A_A_opLA_LAq] = op_recur_if_a_a_opla_laq;
  fx_function[OP_RECUR_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_opl2a_l2aq;
  fx_function[OP_RECUR_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_opl3a_l3aq;
  fx_function[OP_RECUR_IF_A_A_opA_LAq] = op_recur_if_a_a_opa_laq;
  fx_function[OP_RECUR_IF_A_A_opA_L2Aq] = op_recur_if_a_a_opa_l2aq;
  fx_function[OP_RECUR_IF_A_A_opA_L3Aq] = op_recur_if_a_a_opa_l3aq;
  fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a;
  fx_function[OP_RECUR_IF_A_A_IF_A_A_opLA_LAq] = op_recur_if_a_a_if_a_a_opla_laq;
  fx_function[OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_if_a_a_opl2a_l2aq;
  fx_function[OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_if_a_a_opl3a_l3aq;
  fx_function[OP_RECUR_AND_A_OR_A_L2A_L2A] = op_recur_and_a_or_a_l2a_l2a;
  fx_function[OP_RECUR_IF_A_A_opLA_LA_LAq] = op_recur_if_a_a_opla_la_laq;
  fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a;
  fx_function[OP_RECUR_IF_A_A_opA_LA_LAq] = op_recur_if_a_a_opa_la_laq;
  fx_function[OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq] = op_recur_if_a_a_if_a_l2a_opa_l2aq;
  fx_function[OP_RECUR_COND_A_A_A_A_opA_L2Aq] = op_recur_cond_a_a_a_a_opa_l2aq;
  fx_function[OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq] = op_recur_cond_a_a_a_l2a_lopa_l2aq;
}

static void init_opt_functions(s7_scheme *sc)
{
#if !With_Pure_s7
  s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_7pp);

  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_unchecked);

  s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_pp);
  s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_ppp);
  s7_set_i_i_function(sc, global_value(sc->integer_length_symbol), integer_length_i_i);
  s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), string_length_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), vector_length_i_7p);
  s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), vector_to_list_p_p);
  s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), string_to_list_p_p);
  s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), vector_length_p_p);
  s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), is_exact_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), is_inexact_b_7p);
  s7_set_p_p_function(sc, global_value(sc->exact_to_inexact_symbol), exact_to_inexact_p_p);
  s7_set_p_p_function(sc, global_value(sc->inexact_to_exact_symbol), inexact_to_exact_p_p);
#endif

  s7_set_p_pp_function(sc, global_value(sc->complex_vector_ref_symbol), complex_vector_ref_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->complex_vector_ref_symbol), complex_vector_ref_p_pi);
  s7_set_p_pip_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_pip);
  s7_set_p_ppp_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_ppp);

  s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_p_pp);
  s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pi);
  s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pii);
  s7_set_p_pip_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_pip);
  s7_set_p_ppp_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_ppp);
  s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7pid);
  s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piid);

  s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_p_pp);
  s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pi);
  s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pii);
  s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7piii);
  s7_set_p_pip_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_pip);
  s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp);
  s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7pii);
  s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7piii);

  s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pi);
  s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pii);
  s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7pii);
  s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7piii);

  s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi);
  s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pii);
  s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip);
  s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_piip);
  s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi_unchecked);
  s7_set_p_pip_unchecked_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip_unchecked);
  s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol), vector_set_p_ppp);

  /* experiment, don't add byte-vector -- collides here with int-vector, this works only for these cases */
  s7_set_i_7piii_function(sc, global_value(sc->vector_ref_symbol), int_vector_ref_i_7piii);
  s7_set_i_7piii_function(sc, global_value(sc->vector_set_symbol), int_vector_set_i_7piii);
  s7_set_d_7piid_function(sc, global_value(sc->vector_set_symbol), float_vector_set_d_7piid);

  s7_set_p_pp_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi);
  s7_set_p_pip_function(sc, global_value(sc->list_set_symbol), list_set_p_pip);
  s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi_unchecked);
  s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), list_set_p_pip_unchecked);
  s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), cyclic_sequences_p_p);
  s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), let_ref);
  s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set_2); /* originally named "let_set" but that was unsearchable */
  s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi);
  s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pp);
  s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), string_set_p_pip);
  s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi_unchecked);
  s7_set_p_pip_unchecked_function(sc, global_value(sc->string_set_symbol), string_set_p_pip_unchecked);
  s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol), hash_table_ref_p_pp);
  s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol), hash_table_set_p_ppp);
  s7_set_p_ii_function(sc, global_value(sc->complex_symbol), complex_p_ii);
  s7_set_p_dd_function(sc, global_value(sc->complex_symbol), complex_p_dd);
  s7_set_p_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp);

  s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol), integer_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->caaaar_symbol), caaaar_p_p);
  s7_set_p_p_function(sc, global_value(sc->caaadr_symbol), caaadr_p_p);
  s7_set_p_p_function(sc, global_value(sc->caadar_symbol), caadar_p_p);
  s7_set_p_p_function(sc, global_value(sc->cadaar_symbol), cadaar_p_p);
  s7_set_p_p_function(sc, global_value(sc->cdaaar_symbol), cdaaar_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->cdadar_symbol), cdadar_p_p);
  s7_set_p_p_function(sc, global_value(sc->cddaar_symbol), cddaar_p_p);
  s7_set_p_p_function(sc, global_value(sc->cdaddr_symbol), cdaddr_p_p);
  s7_set_p_p_function(sc, global_value(sc->cdaadr_symbol), cdaadr_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);
#if !With_Gmp
  s7_set_d_7p_function(sc, global_value(sc->magnitude_symbol), magnitude_d_7p);
#endif
  s7_set_d_d_function(sc, global_value(sc->angle_symbol), angle_d_d);
  s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d);
  s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p);
  s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d);
  s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p);
  s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p);
  s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p);
  s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p);
  s7_set_p_p_function(sc, global_value(sc->sinh_symbol), sinh_p_p);
  s7_set_p_p_function(sc, global_value(sc->cosh_symbol), cosh_p_p);
  s7_set_p_p_function(sc, global_value(sc->asinh_symbol), asinh_p_p);
  s7_set_p_p_function(sc, global_value(sc->acosh_symbol), acosh_p_p);
  s7_set_p_p_function(sc, global_value(sc->atanh_symbol), atanh_p_p);
  s7_set_p_p_function(sc, global_value(sc->tanh_symbol), tanh_p_p);
  s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d);
  s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d);
  s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d);
  s7_set_p_d_function(sc, global_value(sc->sinh_symbol), sinh_p_d);
  s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d);
  s7_set_p_d_function(sc, global_value(sc->cosh_symbol), cosh_p_d);
  s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d);
  s7_set_p_d_function(sc, global_value(sc->exp_symbol), exp_p_d);

  s7_set_p_d_function(sc, global_value(sc->rationalize_symbol), rationalize_p_d);
  s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), rationalize_p_i);
  s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), rationalize_i_i);
  s7_set_p_p_function(sc, global_value(sc->truncate_symbol), truncate_p_p);
  s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p);
  s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p);
  s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p);
  s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp);
  s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p);
#if !With_Gmp
  s7_set_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp);
  /* same problem affects big_log|logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will fail in gmp s7 */
  s7_set_p_d_function(sc, global_value(sc->ceiling_symbol), ceiling_p_d);
  s7_set_p_d_function(sc, global_value(sc->floor_symbol), floor_p_d);
  s7_set_p_d_function(sc, global_value(sc->truncate_symbol), truncate_p_d);
  s7_set_p_d_function(sc, global_value(sc->round_symbol), round_p_d);
#endif
  s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol), remainder_d_7dd);
  s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol), remainder_i_7ii);
  s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol), quotient_i_7ii);
  s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol), modulo_d_7dd);
  s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii);
  s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd);
  s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd);
  s7_set_p_ii_function(sc, global_value(sc->add_symbol), add_p_ii);
  s7_set_p_dd_function(sc, global_value(sc->subtract_symbol), subtract_p_dd);
  s7_set_p_ii_function(sc, global_value(sc->subtract_symbol), subtract_p_ii);

  s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->modulo_symbol), modulo_p_pi);
  s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), remainder_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->remainder_symbol), remainder_p_pi);
  s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), quotient_p_pp);
  s7_set_p_pi_function(sc, global_value(sc->quotient_symbol), quotient_p_pi);
  s7_set_p_pp_function(sc, global_value(sc->subtract_symbol), subtract_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp);
  s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp);
  s7_set_p_pp_function(sc, global_value(sc->multiply_symbol), multiply_p_pp);
  s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol), multiply_p_ppp);
  s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp);
  s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p);
  s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p); /* maybe add negate_d_p? or negate_d_d? also invert above */
  s7_set_p_p_function(sc, global_value(sc->is_even_symbol), is_even_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), is_odd_p_p);

  s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p);
  s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d);
  s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i);

  s7_set_p_d_function(sc, global_value(sc->float_vector_symbol), float_vector_p_d);
  s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), int_vector_p_i);
  s7_set_p_i_function(sc, global_value(sc->float_vector_symbol), float_vector_p_i);
  s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i);
  s7_set_p_i_function(sc, global_value(sc->round_symbol), round_p_i);
  s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i);
  s7_set_p_i_function(sc, global_value(sc->floor_symbol), floor_p_i);
  s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i);
  s7_set_p_i_function(sc, global_value(sc->ceiling_symbol), ceiling_p_i);
  s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i);
  s7_set_p_i_function(sc, global_value(sc->truncate_symbol), truncate_p_i);

  s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d);
  s7_set_d_d_function(sc, global_value(sc->atan_symbol), atan_d_d);
  s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd);
  s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d);
  s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p);
#if !With_Gmp
  s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii);
  s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d);
  s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d);
  s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7d);
  s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7p);
  s7_set_i_7d_function(sc, global_value(sc->truncate_symbol), truncate_i_7d);
#endif

  s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d);
  s7_set_d_d_function(sc, global_value(sc->subtract_symbol), subtract_d_d);
  s7_set_d_d_function(sc, global_value(sc->multiply_symbol), multiply_d_d);
  s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d);
  s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd);
  s7_set_d_id_function(sc, global_value(sc->add_symbol), add_d_id);
  s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), subtract_d_dd);
  s7_set_d_id_function(sc, global_value(sc->subtract_symbol), subtract_d_id);
  s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), multiply_d_dd);
  s7_set_d_id_function(sc, global_value(sc->multiply_symbol), multiply_d_id);
  s7_set_d_7dd_function(sc, global_value(sc->divide_symbol), divide_d_7dd);
  s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd);
  s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol), subtract_d_ddd);
  s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol), multiply_d_ddd);
  s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd);
  s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol), subtract_d_dddd);
  s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol), multiply_d_dddd);
  s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i);
  s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii);
  s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd);
  s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd);
  s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd);
  s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd);
  s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd);
  s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd);
  s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii);
  s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii);
  s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii);
  s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii);
  s7_set_i_i_function(sc, global_value(sc->subtract_symbol), subtract_i_i);
  s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii);
  s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii);
  s7_set_i_ii_function(sc, global_value(sc->subtract_symbol), subtract_i_ii);
  s7_set_i_iii_function(sc, global_value(sc->subtract_symbol), subtract_i_iii);
  s7_set_i_ii_function(sc, global_value(sc->multiply_symbol), multiply_i_ii);
  s7_set_i_iii_function(sc, global_value(sc->multiply_symbol), multiply_i_iii);

  s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i);
  s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii);
  s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii);
  s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii);
  s7_set_i_iii_function(sc, global_value(sc->logior_symbol), logior_i_iii);
  s7_set_i_iii_function(sc, global_value(sc->logxor_symbol), logxor_i_iii);
  s7_set_i_iii_function(sc, global_value(sc->logand_symbol), logand_i_iii);
  s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol), logbit_b_7ii);
  s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol), logbit_b_7pp);

  s7_set_i_7p_function(sc, global_value(sc->numerator_symbol), numerator_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->denominator_symbol), denominator_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), hash_table_entries_i_7p);
  s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_i_7p);
  s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_p_p);

  s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), s7_is_boolean);
  s7_set_b_p_function(sc, global_value(sc->is_byte_symbol), is_byte);
  s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), is_byte_vector_b_p);
  s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), s7_is_c_object);
  s7_set_b_p_function(sc, global_value(sc->is_char_symbol), s7_is_character);
  s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), s7_is_complex);
  s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), is_continuation_b_p);
  s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), s7_is_c_pointer);
  s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), s7_is_dilambda);
  s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), is_eof_object_b_p);
  s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), is_even_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p);
  s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b);
  s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), s7_is_float_vector);
  s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), is_gensym_b_p);
  s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), s7_is_hash_table);
  s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), is_infinite_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p);
  s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol), is_input_port_b);
  s7_set_b_p_function(sc, global_value(sc->is_integer_symbol), s7_is_integer);
  s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol), s7_is_int_vector);
  s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol), s7_is_keyword);
  s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let);
  s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b);
  s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b);
  s7_set_b_p_function(sc, global_value(sc->is_number_symbol), s7_is_number);
  s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), is_output_port_b);
  s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair);
  s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p);
  s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), is_port_closed_b_7p);
  s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), s7_is_procedure);
  s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), s7_is_proper_list);
  s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol), s7_is_random_state);
  s7_set_b_p_function(sc, global_value(sc->is_rational_symbol), s7_is_rational);
  s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real);
  s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol), is_sequence_b);
  s7_set_b_p_function(sc, global_value(sc->is_string_symbol), s7_is_string);
  s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol), s7_is_symbol);
  s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol), s7_is_syntax);
  s7_set_b_p_function(sc, global_value(sc->is_vector_symbol), s7_is_vector);
  s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol), is_iterator_b_7p);

  s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol), is_char_lower_case_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol), is_char_upper_case_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_b_7p);

  s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol), s7_is_openlet);
  s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol), iterator_is_at_end_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol), is_zero_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), is_negative_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), is_positive_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol), is_provided_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7p);
  s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), tree_memq_b_7pp);
  s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), tree_is_cyclic);
  s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_b_7pp);
  s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_p_pp);
  s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), s7_is_immutable);

  s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol), is_proper_list_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p);
  s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p);
  s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of);
  s7_set_p_p_function(sc, global_value(sc->type_name_symbol), s7_type_name);
  s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i);
  s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p);
  s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p);
  s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p);
  s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp);
  s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp);
  s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), list_tail_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), make_list_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp);
  s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_p_p);
  s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length);
  s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol), pair_line_number_p_p);
  s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol), port_line_number_p_p);
  s7_set_p_p_function(sc, global_value(sc->port_filename_symbol), port_filename_p_p);
  s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol), c_pointer_info_p_p);
  s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol), c_pointer_type_p_p);
  s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol), c_pointer_weak1_p_p);
  s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), c_pointer_weak2_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_p_p);
  s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), char_upcase_p_p);
  s7_set_p_p_function(sc, global_value(sc->read_char_symbol), read_char_p_p);
  s7_set_p_i_function(sc, global_value(sc->make_string_symbol), make_string_p_i);
  s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol), make_int_vector_p_ii);
  s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol), make_byte_vector_p_ii);
  s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp);
  s7_set_p_p_function(sc, global_value(sc->signature_symbol), s7_signature);
  s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p);
  s7_set_p_p_function(sc, global_value(sc->reverse_symbol), reverse_p_p);
  s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), object_to_let_p_p);
  s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p);
  s7_set_p_p_function(sc, global_value(sc->make_iterator_symbol), s7_make_iterator);

#if With_System_Extras
  s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), is_directory_b_7p);
  s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol), file_exists_b_7p);
#endif

  s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i);
  s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i);
  s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i);
  s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d);
  s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), is_positive_p_p);
  s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), is_negative_p_p);
  s7_set_p_p_function(sc, global_value(sc->real_part_symbol), real_part_p_p);
  s7_set_p_p_function(sc, global_value(sc->imag_part_symbol), imag_part_p_p);
  s7_set_d_7p_function(sc, global_value(sc->real_part_symbol), real_part_d_7p);
  s7_set_d_7p_function(sc, global_value(sc->imag_part_symbol), imag_part_d_7p); /* also angle, magnitude, but angle might return int etc */
  s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), is_positive_i);
  s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), is_positive_d);
  s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), is_negative_i);
  s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), is_negative_d);

  s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi);
  s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi);
  s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi);
  s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi);
  s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi);
  s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi);
  s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi);
  s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi);
  /* no ip pd dp! */
  s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi);
  s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi);
  s7_set_p_pi_function(sc, global_value(sc->add_symbol), add_p_pi);
  s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi);
  s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), multiply_p_pi);

  s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii);
  s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd);
  s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol), num_eq_b_7pp);
  s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii);
  s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd);

  s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii);
  s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd);
  s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp);
  s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii);
  s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd);

  s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii);
  s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd);
  s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii);
  s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd);
  s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp);

  s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii);
  s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd);
  s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd);
  s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii);
  s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp);

  s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii);
  s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd);
  s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii);
  s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd);
  s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp);

  s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq);
  s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv);
  s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp);
  s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol), s7_is_equal);
  s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol), s7_is_equivalent);
  s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol), is_equal_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol), is_equivalent_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol), char_eq_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->make_float_vector_symbol), make_float_vector_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->setter_symbol), setter_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->string_eq_symbol), string_eq_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->string_lt_symbol), string_lt_p_pp);
  s7_set_p_pp_function(sc, global_value(sc->string_gt_symbol), string_gt_p_pp);

  s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol), char_lt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol), char_leq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol), char_gt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol), char_geq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol), char_eq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol), string_lt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol), string_leq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol), string_gt_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol), string_geq_b_7pp);
  s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol), string_eq_b_7pp);

  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol), char_lt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol), char_leq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol), char_gt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol), char_geq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol), char_eq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol), string_lt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol), string_leq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol), string_gt_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol), string_geq_b_unchecked);
  s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol), string_eq_b_unchecked);

  s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol), is_aritable_b_7pp);
  s7_set_b_7p_function(sc, global_value(sc->goto_is_active_symbol), goto_is_active_b_7p);
}

static void init_features(s7_scheme *sc)
{
  s7_provide(sc, "s7");
  s7_provide(sc, "s7-" S7_VERSION);
  s7_provide(sc, "ratios"); /* changed from ratio 22-Aug-23; r7rs uses the plural */

#if Have_Complex_Numbers
  s7_provide(sc, "complex-numbers");
#endif
#if With_Gmp
  s7_provide(sc, "gmp");
#else
  s7_provide(sc, "ieee-float"); /* why would anyone care? -- this is for r7rs -- why singular this time? */
#endif
#if With_Pure_s7
  s7_provide(sc, "pure-s7");
#endif
#if With_r7rs
  s7_provide(sc, "r7rs"); /* should this (provide "r7rs.scm") as well? */
#endif
#if With_Notcurses
  s7_provide(sc, "notcurses");
#endif
#if With_Extra_Exponent_Markers
  s7_provide(sc, "dfls-exponents");
#endif
#if Have_Overflow_Checks
  s7_provide(sc, "overflow-checks");
#endif
#if With_System_Extras
  s7_provide(sc, "system-extras");
#endif
#if With_Immutable_Unquote
  s7_provide(sc, "immutable-unquote");
#endif
#if s7_Debugging
  s7_provide(sc, "debugging");
#endif
#if With_Number_Separator
  s7_provide(sc, "number-separator");
#endif
#if With_History
  s7_provide(sc, "history");
#endif
#if With_C_Loader
  s7_provide(sc, "dlopen");
#endif
#if !Disable_Autoload
  s7_provide(sc, "autoload");
#endif
#if !Disable_Deprecated
  s7_provide(sc, "deprecated");
#endif
#if s7_Aligned
  s7_provide(sc, "aligned");
#endif
#if Pointer_32
  s7_provide(sc, "32-bit");
#endif
#if With_Warnings
  s7_provide(sc, "warnings");
#endif

#ifdef __APPLE__
  s7_provide(sc, "osx");
#endif
#ifdef __linux__
  s7_provide(sc, "linux");
#endif
#ifdef __OpenBSD__
  s7_provide(sc, "openbsd");
#endif
#ifdef __NetBSD__
  s7_provide(sc, "netbsd");
#endif
#ifdef __FreeBSD__
  s7_provide(sc, "freebsd");
#endif
#if MS_Windows
  s7_provide(sc, "windows");
#endif
#ifdef __bfin__
  s7_provide(sc, "blackfin");
#endif
#ifdef __ANDROID__
  s7_provide(sc, "android");
#endif
#ifdef __MSYS__
  s7_provide(sc, "msys2");  /* from chai xiaoxiang */
#endif
#ifdef __MINGW32__          /* this is also defined in mingw64 */
  s7_provide(sc, "mingw");
#endif
#ifdef __CYGWIN__
  s7_provide(sc, "cygwin"); /* this is also defined in msys2 */
#endif
#ifdef __hpux
  s7_provide(sc, "hpux");
#endif
#if defined(__sun) && defined(__SVR4)
  s7_provide(sc, "solaris");
#endif

#ifdef __clang__ /* this defines __GNUC__ */
  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
#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 */
#endif
#ifdef __EMSCRIPTEN__
  s7_provide(sc, "emscripten");
#endif
#if MS_Windows
  s7_provide(sc, "msvc");
#endif
}

static void init_wrappers(s7_scheme *sc)
{
  s7_pointer cp, qp;
#if s7_Debugging
  sc->string_wrapper_allocs = 0;
  sc->integer_wrapper_allocs = 0;
  sc->real_wrapper_allocs = 0;
  sc->complex_wrapper_allocs = 0;
  sc->c_pointer_wrapper_allocs = 0;
  sc->let_wrapper_allocs = 0;
  sc->slot_wrapper_allocs = 0;
#endif
  sc->integer_wrappers = semipermanent_list(sc, Num_Integer_Wrappers);
  for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_full_type(p, T_INTEGER | T_Unheap);
#if s7_Debugging
      p->carrier_line = __LINE__;
#endif
      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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_full_type(p, T_REAL | T_Unheap);
#if s7_Debugging
      p->carrier_line = __LINE__;
#endif
      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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_full_type(p, T_COMPLEX | T_Unheap);
#if s7_Debugging
      p->carrier_line = __LINE__;
#endif
      set_real_part(p, 0.0);
      set_imag_part(p, 0.0);
      set_car(cp, p);
    }
  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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_full_type(p, T_STRING | T_Safe_Procedure | T_Unheap | T_Immutable | T_Wrapper);
      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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_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))
    {
      const s7_pointer p = alloc_pointer(sc);
      set_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, (s7_int)0, 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)
{
  const 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)
{
  const 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)
{
  const s7_pointer symbol = syntax(sc, name, op, min_args, max_args, doc);
  const 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 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 g_symbol_set(s7_scheme *sc, s7_pointer args) /* (set! (symbol <lst>) <val>) */
{
  if (is_null(cddr(args)))
    return(symbol_set_1(sc, g_symbol(sc, set_plist_1(sc, car(args))), cadr(args)));
  {
    const s7_int len = proper_list_length(args) - 1;
    const s7_pointer 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));
    }
    {
      const 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);
  /* not float-vector-set! here */

  sc->list_set_function = global_value(sc->list_set_symbol);
  set_is_setter(sc->list_set_symbol);

  sc->hash_table_set_function = global_value(sc->hash_table_set_symbol);
  set_is_setter(sc->hash_table_set_symbol);

  sc->let_set_function = global_value(sc->let_set_symbol);
  set_is_setter(sc->let_set_symbol);

  sc->string_set_function = global_value(sc->string_set_symbol);
  set_is_setter(sc->string_set_symbol);

  set_is_setter(sc->byte_vector_set_symbol);
  set_is_setter(sc->set_car_symbol);
  set_is_setter(sc->set_cdr_symbol);
  set_is_safe_setter(sc->byte_vector_set_symbol);
  set_is_safe_setter(sc->int_vector_set_symbol);
  set_is_safe_setter(sc->float_vector_set_symbol);
  set_is_safe_setter(sc->complex_vector_set_symbol);
  set_is_safe_setter(sc->string_set_symbol);

#if With_Pure_s7
  /* we need to be able at least to set (current-output-port) to #f */
  c_function_set_setter(global_value(sc->current_input_port_symbol),
			s7_make_safe_function(sc, "#<set-*stdin*>", g_set_current_input_port, 1, 0, false, "*stdin* setter"));
  c_function_set_setter(global_value(sc->current_output_port_symbol),
			s7_make_safe_function(sc, "#<set-*stdout*>", g_set_current_output_port, 1, 0, false, "*stdout* setter"));
#else
  set_is_setter(sc->set_current_input_port_symbol);
  set_is_setter(sc->set_current_output_port_symbol);
  c_function_set_setter(global_value(sc->current_input_port_symbol),  global_value(sc->set_current_input_port_symbol));
  c_function_set_setter(global_value(sc->current_output_port_symbol), global_value(sc->set_current_output_port_symbol));
#endif

  set_is_setter(sc->set_current_error_port_symbol);
  c_function_set_setter(global_value(sc->current_error_port_symbol), global_value(sc->set_current_error_port_symbol));
  /* despite the similar names, current-error-port is different from the other two, and a setter is needed
   *    in scheme because error and warn send output to it by default.  It is not a "dynamic variable".
   */

  c_function_set_setter(global_value(sc->car_symbol),                global_value(sc->set_car_symbol));
  c_function_set_setter(global_value(sc->cdr_symbol),                global_value(sc->set_cdr_symbol));
  c_function_set_setter(global_value(sc->hash_table_ref_symbol),     global_value(sc->hash_table_set_symbol));
  c_function_set_setter(global_value(sc->vector_ref_symbol),         global_value(sc->vector_set_symbol));
  c_function_set_setter(global_value(sc->float_vector_ref_symbol),   global_value(sc->float_vector_set_symbol));
  c_function_set_setter(global_value(sc->complex_vector_ref_symbol), global_value(sc->complex_vector_set_symbol));
  c_function_set_setter(global_value(sc->int_vector_ref_symbol),     global_value(sc->int_vector_set_symbol));
  c_function_set_setter(global_value(sc->byte_vector_ref_symbol),    global_value(sc->byte_vector_set_symbol));
  c_function_set_setter(global_value(sc->list_ref_symbol),           global_value(sc->list_set_symbol));
  c_function_set_setter(global_value(sc->let_ref_symbol),            global_value(sc->let_set_symbol));
  c_function_set_setter(global_value(sc->string_ref_symbol),         global_value(sc->string_set_symbol));
  c_function_set_setter(global_value(sc->outlet_symbol),
			s7_make_safe_function(sc, "#<set-outlet>", g_set_outlet, 2, 0, false, "outlet setter"));
  c_function_set_setter(global_value(sc->port_line_number_symbol),
			s7_make_safe_function(sc, "#<set-port-line-number>", g_set_port_line_number, 1, 1, false, "port-line setter"));
  c_function_set_setter(global_value(sc->port_string_symbol),
			s7_make_safe_function(sc, "#<set-port-string>", g_set_port_string, 2, 0, false, "port-string setter"));
  c_function_set_setter(global_value(sc->port_position_symbol),
			s7_make_safe_function(sc, "#<set-port-position>", g_set_port_position, 2, 0, false, "port-position setter"));
  c_function_set_setter(global_value(sc->vector_typer_symbol),
			s7_make_safe_function(sc, "#<set-vector-typer>", g_set_vector_typer, 2, 0, false, "vector-typer setter"));
  c_function_set_setter(global_value(sc->hash_table_key_typer_symbol),
			s7_make_safe_function(sc, "#<set-hash-table-key-typer>", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter"));
  c_function_set_setter(global_value(sc->hash_table_value_typer_symbol),
			s7_make_safe_function(sc, "#<set-hash-table-value-typer>", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter"));
  c_function_set_setter(global_value(sc->symbol_symbol),
			s7_make_safe_function(sc, "#<symbol-set>", g_symbol_set, 2, 0, true, "symbol setter"));
  c_function_set_setter(global_value(sc->symbol_initial_value_symbol),
			s7_make_safe_function(sc, "#<symbol-set-initial-value>", 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, "#<set-hook-functions>", g_hook_set_functions, 2, 0, false, "hook-functions setter"));
}

static void init_syntax(s7_scheme *sc)
{
  #define H_quote             "(quote obj) returns obj unevaluated.  'obj is an abbreviation for (quote obj)."
  #define H_if                "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \
if optional-false-stuff exists, it is evaluated."
  #define H_when              "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last"
  #define H_unless            "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last"
  #define H_begin             "(begin ...) evaluates each form in its body, returning the value of the last one"
  #define H_set               "(set! variable value) sets the value of variable to value."
  #define H_let               "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\
returning the value of the last form.  The let variables are local to it, and are not available for use until all have been initialized."
  #define H_let_star          "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \
returning the value of the last form.  The let* variables are local to it, and are available immediately."
  #define H_letrec            "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \
(i.e. you can define local recursive functions)"
  #define H_letrec_star       "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*"
  #define H_cond              "(cond (expr clause...)...) is like if..then.  Each expr is evaluated in order, and if one is not #f, \
the associated clauses are evaluated, whereupon cond returns."
  #define H_and               "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \
as soon as one of them returns #f.  If all are non-#f, it returns the last value."
  #define H_or                "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f.  \
If all are #f, or returns #f."
  #define H_case              "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \
match is found (via eqv?), the associated clauses are evaluated, and case returns."
  #define H_do                "(do (vars...) (loop control and return value) ...) is a do-loop."
  #define H_lambda            "(lambda args ...) returns a function."
  #define H_lambda_star       "(lambda* args ...) returns a function; the args list can have default values, \
the parameters themselves can be accessed via keywords."
  #define H_define            "(define var val) assigns val to the variable (symbol) var.  (define (func args) ...) is \
shorthand for (define func (lambda args ...))"
  #define H_define_star       "(define* (func args) ...) defines a function with optional/keyword arguments."
  #define H_define_constant   "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val."
  #define H_define_macro      "(define-macro (mac args) ...) defines mac to be a macro."
  #define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments."
  #define H_macro             "(macro args ...) defines an unnamed macro."
  #define H_macro_star        "(macro* args ...) defines an unnamed macro with optional/keyword arguments."
  #define H_expansion         "(expansion args ...) defines an unnamed expansion (reader macro)."
  #define H_expansion_star    "(expansion* args ...) defines an unnamed expansion (reader 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->expansion_symbol =         binder_syntax(sc,    "expansion",        OP_EXPANSION,         Int_Two,  Max_Arity,  H_expansion);
  sc->expansion_star_symbol =    binder_syntax(sc,    "expansion*",       OP_EXPANSION_STAR,    Int_Two,  Max_Arity,  H_expansion_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->expansion_symbol);
  set_is_escaper_syntax(sc->expansion_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->duplicate_identifier_symbol = make_symbol(sc, "duplicate-identifier", 20);
  /* in standard scheme this is a syntax error, but if so, the word "syntax" has become so nebulous as to mean anything.  These are
   *   error type indications, so the question should be: what is most convenient here for the programmer.  The same applies
   *   to #<do-unspecified> which is just a special case of #<unspecified> but helps debugging (I'm tempted to break out all
   *   the #<unspecified> cases).
   */
  sc->unbound_variable_symbol =     make_symbol(sc, "unbound-variable", 16);
  sc->wrong_type_arg_symbol =       make_symbol(sc, "wrong-type-arg", 14);
  sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args", 20);
  sc->format_error_symbol =         make_symbol(sc, "format-error", 12);
  sc->autoload_error_symbol =       make_symbol(sc, "autoload-error", 14);
  sc->out_of_range_symbol =         make_symbol(sc, "out-of-range", 12);
  sc->out_of_memory_symbol =        make_symbol(sc, "out-of-memory", 13);
  sc->io_error_symbol =             make_symbol(sc, "io-error", 8);
  sc->missing_method_symbol =       make_symbol(sc, "missing-method", 14);
  sc->number_to_real_symbol =       make_symbol(sc, "number_to_real", 14);
  sc->invalid_exit_function_symbol = make_symbol(sc, "invalid-exit-function", 21);
  sc->immutable_error_symbol =      make_symbol(sc, "immutable-error", 15);
  sc->division_by_zero_symbol =     make_symbol(sc, "division-by-zero", 16);
  sc->bad_result_symbol =           make_symbol(sc, "bad-result", 10);
  sc->no_setter_symbol =            make_symbol(sc, "no-setter", 9);
  sc->baffled_symbol =              make_symbol(sc, "baffled!", 8);
  sc->value_symbol =                make_symbol(sc, "value", 5);
  sc->type_symbol =                 make_symbol(sc, "type", 4);
  sc->position_symbol =             make_symbol(sc, "position", 8);
  sc->file_symbol =                 make_symbol(sc, "file", 4);
  sc->line_symbol =                 make_symbol(sc, "line", 4);
  sc->function_symbol =             make_symbol(sc, "function", 8);

  sc->else_symbol =                 make_symbol(sc, "else", 4);
  s7_make_slot(sc, sc->rootlet, sc->else_symbol, sc->else_symbol);
  set_initial_value(sc->else_symbol, s7_make_keyword(sc, "else")); /* 3-Oct-23 was #t */
  /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) -- #_* is read-time */

  sc->allow_other_keys_keyword =    s7_make_keyword(sc, "allow-other-keys");
  sc->rest_keyword =                s7_make_keyword(sc, "rest");
  sc->if_keyword =                  s7_make_keyword(sc, "if");       /* internal optimizer local-let marker */
  sc->readable_keyword =            s7_make_keyword(sc, "readable");
  sc->display_keyword =             s7_make_keyword(sc, "display");
  sc->write_keyword =               s7_make_keyword(sc, "write");
}

static void init_rootlet(s7_scheme *sc)
{
  /* most of init_rootlet (the built-in  functions for example), could be shared by all s7 instances.
   *   currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful.
   */
  enum {e_Any, e_Number, e_Vector, e_Hash_Table, e_Symbol, e_Let, e_List, e_Procedure, e_Iterator, e_Macro,
	e_C_Pointer, e_Port, e_String, e_C_Object, e_Boolean}; /* if this changes, see has_odd_bits symbol_category check */
  /* this symbol_category stuff is only half-implemented pending timing tests etc */
  init_syntax(sc);

  sc->owlet = init_owlet(sc);

  sc->wrong_type_arg_info = semipermanent_list(sc, 6);
  set_car(sc->wrong_type_arg_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is ~A but should be ~A"));

  sc->sole_arg_wrong_type_info = semipermanent_list(sc, 5);
  set_car(sc->sole_arg_wrong_type_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is ~A but should be ~A"));

  sc->out_of_range_info = semipermanent_list(sc, 5);
  set_car(sc->out_of_range_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is out of range (~A)"));

  sc->sole_arg_out_of_range_info = semipermanent_list(sc, 4);
  set_car(sc->sole_arg_out_of_range_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is out of range (~A)"));

  sc->gc_off = false;

  #define defun(Scheme_Name, C_Name, Req, Opt, Rst) \
    s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)

  #define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
    s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)

  #define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
    s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)

  #define bool_defun(Scheme_Name, C_Name, Opt_Args, SymId, Marker, Simple, Category) \
    define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt_Args, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter, Category)

  /* 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,  e_Symbol);
  sc->is_syntax_symbol =          bool_defun("syntax?",	         is_syntax,	     0, T_SYNTAX,       just_mark_vector,   true,  e_Any);
  sc->is_gensym_symbol =          bool_defun("gensym?",	         is_gensym,	     0, T_FREE,         mark_symbol_vector, true,  e_Symbol);
  sc->is_keyword_symbol =         bool_defun("keyword?",         is_keyword,	     0, T_FREE,         just_mark_vector,   true,  e_Symbol);
  sc->is_let_symbol =             bool_defun("let?",	         is_let,	     0, T_LET,          mark_vector_1,      false, e_Let);
  sc->is_openlet_symbol =         bool_defun("openlet?",         is_openlet,	     0, T_FREE,         mark_vector_1,      false, e_Let);
  sc->is_iterator_symbol =        bool_defun("iterator?",        is_iterator,	     0, T_ITERATOR,     mark_vector_1,      false, e_Iterator);
  sc->is_macro_symbol =           bool_defun("macro?",	         is_macro,	     0, T_FREE,         mark_vector_1,      false, e_Macro);
  sc->is_c_pointer_symbol =       bool_defun("c-pointer?",       is_c_pointer,	     1, T_C_POINTER,    mark_vector_1,      false, e_C_Pointer);
  sc->is_input_port_symbol =      bool_defun("input-port?",      is_input_port,	     0, T_INPUT_PORT,   mark_vector_1,      true,  e_Port);
  sc->is_output_port_symbol =     bool_defun("output-port?",     is_output_port,     0, T_OUTPUT_PORT,  mark_simple_vector, true,  e_Port);
  sc->is_eof_object_symbol =      bool_defun("eof-object?",      is_eof_object,	     0, T_EOF,          just_mark_vector,   true,  e_Any);
  sc->is_integer_symbol =         bool_defun("integer?",         is_integer,	     0, (With_Gmp) ? T_FREE : T_INTEGER, mark_simple_vector, true, e_Number);
  sc->is_byte_symbol =            bool_defun("byte?",	         is_byte,	     0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_number_symbol =          bool_defun("number?",	         is_number,	     0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_real_symbol =            bool_defun("real?",	         is_real,	     0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_float_symbol =           bool_defun("float?",           is_float,           0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_complex_symbol =         bool_defun("complex?",         is_complex,	     0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_rational_symbol =        bool_defun("rational?",        is_rational,	     0, T_FREE,         mark_simple_vector, true,  e_Number);
  sc->is_random_state_symbol =    bool_defun("random-state?",    is_random_state,    0, T_RANDOM_STATE, mark_simple_vector, true,  e_Any);
  sc->is_char_symbol =            bool_defun("char?",	         is_char,	     0, T_CHARACTER,    just_mark_vector,   true,  e_Any);
  sc->is_string_symbol =          bool_defun("string?",	         is_string,	     0, T_STRING,       mark_simple_vector, true,  e_String);
  sc->is_list_symbol =            bool_defun("list?",	         is_list,	     0, T_FREE,         mark_vector_1,      false, e_List);
  sc->is_pair_symbol =            bool_defun("pair?",	         is_pair,	     0, T_PAIR,         mark_vector_1,      false, e_List);
  sc->is_proper_list_symbol =     bool_defun("proper-list?",     is_proper_list,     0, T_FREE,         mark_vector_1,      false, e_List);
  sc->is_vector_symbol =          bool_defun("vector?",	         is_vector,	     0, T_FREE,         mark_vector_1,      false, e_Vector);
  sc->is_float_vector_symbol =    bool_defun("float-vector?",    is_float_vector,    0, T_FLOAT_VECTOR, mark_simple_vector, true,  e_Vector);
  sc->is_complex_vector_symbol =  bool_defun("complex-vector?",  is_complex_vector,  0, T_COMPLEX_VECTOR, mark_simple_vector, true, e_Vector);
  sc->is_int_vector_symbol =      bool_defun("int-vector?",      is_int_vector,	     0, T_INT_VECTOR,   mark_simple_vector, true,  e_Vector);
  sc->is_byte_vector_symbol =     bool_defun("byte-vector?",     is_byte_vector,     0, T_BYTE_VECTOR,  mark_simple_vector, true,  e_Vector);
  sc->is_subvector_symbol =       bool_defun("subvector?",       is_subvector,	     0, T_FREE,         mark_vector_1,      false, e_Vector);
  sc->is_hash_table_symbol =      bool_defun("hash-table?",      is_hash_table,      0, T_HASH_TABLE,   mark_vector_1,      false, e_Hash_Table);
  sc->is_weak_hash_table_symbol = bool_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE,         mark_vector_1,      false, e_Hash_Table);
  sc->is_continuation_symbol =    bool_defun("continuation?",    is_continuation,    0, T_CONTINUATION, mark_vector_1,      false, e_Procedure);
  sc->is_procedure_symbol =       bool_defun("procedure?",       is_procedure,	     0, T_FREE,         mark_vector_1,      false, e_Procedure);
  sc->is_dilambda_symbol =        bool_defun("dilambda?",        is_dilambda,	     0, T_FREE,         mark_vector_1,      false, e_Procedure);
  /* set above */                 bool_defun("boolean?",         is_boolean,	     0, T_BOOLEAN,      just_mark_vector,   true,  e_Boolean);
  sc->is_sequence_symbol =        bool_defun("sequence?",        is_sequence,	     0, T_FREE,         mark_vector_1,      false, e_Vector);
  sc->is_null_symbol =            bool_defun("null?",	         is_null,	     0, T_NIL,          just_mark_vector,   true,  e_Any);
  sc->is_undefined_symbol =       bool_defun("undefined?",       is_undefined,       0, T_UNDEFINED,    just_mark_vector,   true,  e_Any);
  sc->is_unspecified_symbol =     bool_defun("unspecified?",     is_unspecified,     0, T_UNSPECIFIED,  just_mark_vector,   true,  e_Any);
  sc->is_c_object_symbol =        bool_defun("c-object?",        is_c_object,	     0, T_C_OBJECT,     mark_vector_1,      false, e_C_Object);
  sc->is_goto_symbol =            bool_defun("goto?",	         is_goto,            0, T_GOTO,         mark_vector_1,      true,  e_Procedure);

  /* these are for signatures */
  sc->not_symbol = defun("not",	not, 1, 0, false);
  sc->is_integer_or_real_at_end_symbol = make_symbol(sc, "integer:real?", 13);
  sc->is_integer_or_number_at_end_symbol = make_symbol(sc, "integer:number?", 15);
  sc->is_integer_or_any_at_end_symbol =  make_symbol(sc, "integer:any?", 12);

  sc->pl_p =   s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol);
  sc->pl_tl =  s7_make_signature(sc, 3,
		  s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */
  sc->pl_bc =  s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol);
  sc->pl_bn =  s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol);
  sc->pl_nn =  s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol);
  sc->pl_sf =  s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol));
  sc->pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T);
  sc->pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
  sc->pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol);
  sc->pcl_i =  s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol);
  sc->pcl_r =  s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol);
  sc->pcl_f =  s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol);
  sc->pcl_n =  s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol);
  sc->pcl_s =  s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol);
  sc->pcl_v =  s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol);
  sc->pcl_c =  s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol);

  sc->values_symbol = make_symbol(sc, "values", 6);

  sc->is_bignum_symbol =             defun("bignum?",           is_bignum,              1, 0, false);
  sc->bignum_symbol =                defun("bignum",            bignum,                 1, 1, false);

  sc->gensym_symbol =                defun("gensym",		gensym,			0, 1, false);
  sc->symbol_table_symbol =          defun("symbol-table",	symbol_table,		0, 0, false);
  sc->symbol_to_string_symbol =      defun("symbol->string",	symbol_to_string,	1, 0, false);
  sc->string_to_symbol_symbol =      defun("string->symbol",	string_to_symbol,	1, 0, false);
  sc->symbol_symbol =                defun("symbol",		symbol,			1, 0, true);
  sc->symbol_to_value_symbol =       defun("symbol->value",	symbol_to_value,	1, 1, false);
  sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false);
  sc->symbol_initial_value_symbol =  defun("symbol-initial-value", symbol_initial_value, 1, 0, false);
  sc->immutable_symbol =             defun("immutable!",        immutable,              1, 1, false); set_func_is_definer(sc->immutable_symbol); /* was semisafe 26-Dec-25 -- why? */
  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, "#<c-object-set-let>", g_c_object_set_let, 2, 0, false, "c-object-let setter"));

  sc->c_pointer_symbol =             defun("c-pointer",	        c_pointer,		1, 4, false);
  sc->c_pointer_info_symbol =        defun("c-pointer-info",    c_pointer_info,		1, 0, false);
  sc->c_pointer_type_symbol =        defun("c-pointer-type",    c_pointer_type,		1, 0, false);
  sc->c_pointer_weak1_symbol =       defun("c-pointer-weak1",   c_pointer_weak1,	1, 0, false);
  sc->c_pointer_weak2_symbol =       defun("c-pointer-weak2",   c_pointer_weak2,	1, 0, false);
  sc->c_pointer_to_list_symbol =     defun("c-pointer->list",   c_pointer_to_list,      1, 0, false);

  sc->port_string_symbol =           defun("port-string",       port_string,		1, 0, false);
  sc->port_file_symbol =             defun("port-file",	        port_file,		1, 0, false);
  sc->port_position_symbol =         defun("port-position",	port_position,		1, 0, false);
  sc->port_line_number_symbol =      defun("port-line-number",  port_line_number,	0, 1, false);
  sc->port_filename_symbol =         defun("port-filename",	port_filename,		0, 1, false);
  sc->pair_line_number_symbol =      defun("pair-line-number",  pair_line_number,	1, 0, false);
  sc->pair_filename_symbol =         defun("pair-filename",     pair_filename,	        1, 0, false);
  sc->is_port_closed_symbol =        defun("port-closed?",	is_port_closed,		1, 0, false);

  sc->current_input_port_symbol =    defun("current-input-port",  current_input_port,   0, 0, false);
  sc->current_output_port_symbol =   defun("current-output-port", current_output_port,  0, 0, false);
  sc->current_error_port_symbol =    defun("current-error-port", current_error_port,    0, 0, false);
  sc->set_current_error_port_symbol = defun("set-current-error-port", set_current_error_port, 1, 0, false);
#if !With_Pure_s7
  sc->let_to_list_symbol =           defun("let->list",	         let_to_list,		1, 0, false);
  sc->set_current_input_port_symbol = defun("set-current-input-port", set_current_input_port, 1, 0, false);
  sc->set_current_output_port_symbol = defun("set-current-output-port", set_current_output_port, 1, 0, false);
  sc->is_char_ready_symbol =         defun("char-ready?",	is_char_ready,		0, 1, false); /* the least-used scheme function */
#endif

  sc->close_input_port_symbol =      defun("close-input-port",   close_input_port,	1, 0, false);
  sc->close_output_port_symbol =     defun("close-output-port",  close_output_port,	1, 0, false);
  sc->flush_output_port_symbol =     defun("flush-output-port",  flush_output_port,	0, 1, false);
  sc->open_input_file_symbol =       defun("open-input-file",    open_input_file,	1, 1, false);
  sc->open_output_file_symbol =      defun("open-output-file",   open_output_file,	1, 1, false);
  sc->open_input_string_symbol =     defun("open-input-string",  open_input_string,	1, 0, false);
  sc->open_output_string_symbol =    defun("open-output-string", open_output_string,	0, 0, false);
  sc->get_output_string_symbol =     defun("get-output-string",  get_output_string,	1, 1, false);
  sc->get_output_string_uncopied =   s7_make_safe_function(sc, "get-output-string", g_get_output_string_uncopied, 1, 1, false, NULL);
  sc->open_input_function_symbol =   defun("open-input-function", open_input_function,	1, 0, false);
  sc->open_output_function_symbol =  defun("open-output-function", open_output_function,1, 0, false);

  sc->closed_input_function = s7_make_safe_function(sc, "#<closed-input-function>", g_closed_input_function_port, 2, 0, false, "input-function error");
  sc->closed_output_function = s7_make_safe_function(sc, "#<closed-output-function>", g_closed_output_function_port, 1, 0, false, "output-function error");

  sc->newline_symbol =               defun("newline",		newline,		0, 1, false);
  sc->write_symbol =                 defun("write",		write,			1, 1, false); set_is_translucent(sc->write_symbol);
  sc->display_symbol =               defun("display",		display,		1, 1, false); set_is_translucent(sc->display_symbol);
  sc->read_char_symbol =             defun("read-char",	        read_char,		0, 1, false);
  sc->peek_char_symbol =             defun("peek-char",	        peek_char,		0, 1, false);
  sc->write_char_symbol =            defun("write-char",	write_char,		1, 1, false);
  sc->write_string_symbol =          defun("write-string",	write_string,		1, 3, false);
  sc->read_byte_symbol =             defun("read-byte",	        read_byte,		0, 1, false);
  sc->read_bytes_symbol =            defun("read-bytes",        read_bytes,		2, 1, false);
  sc->write_byte_symbol =            defun("write-byte",	write_byte,		1, 1, false);
  sc->write_bytes_symbol =           defun("write-bytes",	write_bytes,		2, 1, false);
  sc->read_line_symbol =             defun("read-line",	        read_line,		0, 2, false);
  sc->read_string_symbol =           defun("read-string",	read_string,		1, 1, false);
  sc->read_symbol =                  semisafe_defun("read",	read,			0, 1, false);
  /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence
   *   (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns
   *   expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg).
   *   a safe procedure leaves its argument list alone, does not push anything on the stack (except gc protects),
   *   and leaves sc->code|args unscathed (fx_call assumes that is the case).  The stack part can
   *   be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens)
   *   then is called with args that use fx*, and the lambda func does the same, the two calls
   *   can step on each other.
   */
  copy_initial_value(sc, sc->read_symbol);

  sc->call_with_input_string_symbol =  semisafe_defun("call-with-input-string",  call_with_input_string,  2, 0, false); /* body unsafe if func=read */
  sc->call_with_input_file_symbol =    semisafe_defun("call-with-input-file",    call_with_input_file,    2, 0, false);
  sc->with_input_from_string_symbol =  semisafe_defun("with-input-from-string",  with_input_from_string,  2, 0, false);
  sc->with_input_from_file_symbol =    semisafe_defun("with-input-from-file",    with_input_from_file,    2, 0, false);

  sc->call_with_output_string_symbol = semisafe_defun("call-with-output-string", call_with_output_string, 1, 0, false);
  sc->call_with_output_file_symbol =   semisafe_defun("call-with-output-file",   call_with_output_file,   2, 0, false);
  sc->with_output_to_string_symbol =   semisafe_defun("with-output-to-string",   with_output_to_string,   1, 0, false);
  sc->with_output_to_file_symbol =     semisafe_defun("with-output-to-file",     with_output_to_file,     2, 0, false);

#if With_System_Extras
  sc->is_directory_symbol =          defun("directory?",	is_directory,		1, 0, false);
  sc->file_exists_symbol =           defun("file-exists?",	file_exists,		1, 0, false);
  sc->delete_file_symbol =           defun("delete-file",	delete_file,		1, 0, false);
  sc->system_symbol =                defun("system",		system,			1, 1, false);
#if !MS_Windows
  sc->directory_to_list_symbol =     defun("directory->list",   directory_to_list,	1, 0, false);
  sc->file_mtime_symbol =            defun("file-mtime",	file_mtime,		1, 0, false);
#endif
#else
  sc->delete_file_symbol =           make_symbol(sc, "delete-file", 11);
  sc->system_symbol =                make_symbol(sc, "system", 6);
  sc->file_exists_symbol =           make_symbol(sc, "file-exists?", 12);
  sc->is_directory_symbol =          make_symbol(sc, "directory?", 10);
  sc->directory_to_list_symbol =     make_symbol(sc, "directory->list", 15);
  sc->file_mtime_symbol =            make_symbol(sc, "file-mtime", 10);
#endif
#if With_r7rs || With_System_Extras
  sc->getenv_symbol =                defun("getenv",		getenv,			1, 0, false);
#else
  sc->getenv_symbol =                make_symbol(sc, "getenv", 6);
#endif
  sc->real_part_symbol =             defun("real-part",	        real_part,		1, 0, false);
  sc->imag_part_symbol =             defun("imag-part",	        imag_part,		1, 0, false);
  sc->numerator_symbol =             defun("numerator",	        numerator,		1, 0, false);
  sc->denominator_symbol =           defun("denominator",	denominator,		1, 0, false);
  sc->is_even_symbol =               defun("even?",		is_even,		1, 0, false);
  sc->is_odd_symbol =                defun("odd?",		is_odd,			1, 0, false);
  sc->is_zero_symbol =               defun("zero?",		is_zero,		1, 0, false);
  sc->is_positive_symbol =           defun("positive?",	        is_positive,		1, 0, false);
  sc->is_negative_symbol =           defun("negative?",	        is_negative,		1, 0, false);
  sc->is_infinite_symbol =           defun("infinite?",	        is_infinite,		1, 0, false);
  sc->is_nan_symbol =                defun("nan?",		is_nan,			1, 0, false);
  sc->complex_symbol =               defun("complex",	        complex,	        2, 0, false);

  sc->add_symbol =                   defun("+",		        add,			0, 0, true); set_all_integer_and_float(sc->add_symbol);
  sc->subtract_symbol =              defun("-",		        subtract,		1, 0, true); set_all_integer_and_float(sc->subtract_symbol);
  sc->multiply_symbol =              defun("*",		        multiply,		0, 0, true); set_all_integer_and_float(sc->multiply_symbol);
  sc->divide_symbol =                defun("/",		        divide,			1, 0, true); set_all_float(sc->divide_symbol);
  sc->min_symbol =                   defun("min",		min,			1, 0, true); set_all_integer_and_float(sc->min_symbol);
  sc->max_symbol =                   defun("max",		max,			1, 0, true); set_all_integer_and_float(sc->max_symbol);

  sc->quotient_symbol =              defun("quotient",		quotient,		2, 0, false); set_all_integer(sc->quotient_symbol);
  sc->remainder_symbol =             defun("remainder",	        remainder,		2, 0, false); set_all_integer(sc->remainder_symbol);
  sc->modulo_symbol =                defun("modulo",		modulo,			2, 0, false); set_all_integer(sc->modulo_symbol);
  sc->num_eq_symbol =                defun("=",		        num_eq,			2, 0, true);
  sc->lt_symbol =                    defun("<",		        less,			2, 0, true);
  sc->gt_symbol =                    defun(">",		        greater,		2, 0, true);
  sc->leq_symbol =                   defun("<=",		less_or_equal,		2, 0, true);
  sc->geq_symbol =                   defun(">=",		greater_or_equal,	2, 0, true);
  sc->gcd_symbol =                   defun("gcd",		gcd,			0, 0, true);
  sc->lcm_symbol =                   defun("lcm",		lcm,			0, 0, true);
  sc->rationalize_symbol =           defun("rationalize",	rationalize,		1, 1, false);
  sc->random_symbol =                defun("random",		random,			1, 1, false); set_all_integer_and_float(sc->random_symbol);
  sc->random_state_symbol =          defun("random-state",      random_state,	        0, (With_Gmp) ? 1 : 2, false);
  sc->expt_symbol =                  defun("expt",		expt,			2, 0, false);
  sc->log_symbol =                   defun("log",		log,			1, 1, false);
  sc->ash_symbol =                   defun("ash",		ash,			2, 0, false);
  sc->exp_symbol =                   defun("exp",		exp,			1, 0, false); set_all_float(sc->exp_symbol);
  sc->abs_symbol =                   defun("abs",		abs,			1, 0, false); set_all_integer_and_float(sc->abs_symbol);
  set_is_translucent(sc->abs_symbol);
  sc->magnitude_symbol =             defun("magnitude",	        magnitude,		1, 0, false); set_all_integer_and_float(sc->magnitude_symbol);
  sc->angle_symbol =                 defun("angle",		angle,			1, 0, false);
  sc->sin_symbol =                   defun("sin",		sin,			1, 0, false); set_all_float(sc->sin_symbol);
  sc->cos_symbol =                   defun("cos",		cos,			1, 0, false); set_all_float(sc->cos_symbol);
  sc->tan_symbol =                   defun("tan",		tan,			1, 0, false); set_all_float(sc->tan_symbol);
  sc->sinh_symbol =                  defun("sinh",		sinh,			1, 0, false); set_all_float(sc->sinh_symbol);
  sc->cosh_symbol =                  defun("cosh",		cosh,			1, 0, false); set_all_float(sc->cosh_symbol);
  sc->tanh_symbol =                  defun("tanh",		tanh,			1, 0, false); set_all_float(sc->tanh_symbol);
  sc->asin_symbol =                  defun("asin",		asin,			1, 0, false);
  sc->acos_symbol =                  defun("acos",		acos,			1, 0, false);
  sc->atan_symbol =                  defun("atan",		atan,			1, 1, false);
  sc->asinh_symbol =                 defun("asinh",		asinh,			1, 0, false);
  sc->acosh_symbol =                 defun("acosh",		acosh,			1, 0, false);
  sc->atanh_symbol =                 defun("atanh",		atanh,			1, 0, false);
  sc->sqrt_symbol =                  defun("sqrt",		sqrt,			1, 0, false);
  sc->floor_symbol =                 defun("floor",		floor,			1, 0, false); set_is_translucent(sc->floor_symbol);
  sc->ceiling_symbol =               defun("ceiling",		ceiling,		1, 0, false); set_is_translucent(sc->ceiling_symbol);
  sc->truncate_symbol =              defun("truncate",		truncate,		1, 0, false); set_is_translucent(sc->truncate_symbol);
  sc->round_symbol =                 defun("round",		round,			1, 0, false); set_is_translucent(sc->round_symbol);
  sc->logand_symbol =                defun("logand",		logand,			0, 0, true);
  sc->logior_symbol =                defun("logior",		logior,			0, 0, true);
  sc->logxor_symbol =                defun("logxor",		logxor,			0, 0, true);
  sc->lognot_symbol =                defun("lognot",		lognot,			1, 0, false);
  sc->logbit_symbol =                defun("logbit?",		logbit,			2, 0, false);
  sc->integer_decode_float_symbol =  defun("integer-decode-float", integer_decode_float, 1, 0, false);
  sc->nan_symbol =                   defun("nan",               nan,                    0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */
  sc->nan_payload_symbol =           defun("nan-payload",       nan_payload,            1, 0, false);

#if !With_Pure_s7
  sc->integer_length_symbol =        defun("integer-length",	integer_length,		1, 0, false);
  sc->inexact_to_exact_symbol =      defun("inexact->exact",	inexact_to_exact,	1, 0, false);
  sc->exact_to_inexact_symbol =      defun("exact->inexact",	exact_to_inexact,	1, 0, false);
  sc->is_exact_symbol =              defun("exact?",		is_exact,		1, 0, false);
  sc->is_inexact_symbol =            defun("inexact?",		is_inexact,		1, 0, false);
  sc->make_polar_symbol =            defun("make-polar",        make_polar,	        2, 0, false);
#endif
  sc->random_state_to_list_symbol =  defun("random-state->list", random_state_to_list,  0, 1, false);
  sc->number_to_string_symbol =      defun("number->string",	number_to_string,	1, 1, false);
  sc->string_to_number_symbol =      defun("string->number",	string_to_number,	1, 1, false);

  sc->char_upcase_symbol =           defun("char-upcase",	char_upcase,		1, 0, false);
  sc->char_downcase_symbol =         defun("char-downcase",	char_downcase,		1, 0, false);
  sc->char_to_integer_symbol =       defun("char->integer",	char_to_integer,	1, 0, false);
  sc->integer_to_char_symbol =       defun("integer->char",	integer_to_char,	1, 0, false);

  sc->is_char_upper_case_symbol =    defun("char-upper-case?",  is_char_upper_case,	1, 0, false);
  sc->is_char_lower_case_symbol =    defun("char-lower-case?",  is_char_lower_case,	1, 0, false);
  sc->is_char_alphabetic_symbol =    defun("char-alphabetic?",  is_char_alphabetic,	1, 0, false);
  sc->is_char_numeric_symbol =       defun("char-numeric?",	is_char_numeric,	1, 0, false);
  sc->is_char_whitespace_symbol =    defun("char-whitespace?",  is_char_whitespace,	1, 0, false);

  sc->char_eq_symbol =               defun("char=?",		chars_are_equal,	2, 0, true);
  sc->char_lt_symbol =               defun("char<?",		chars_are_less,		2, 0, true);
  sc->char_gt_symbol =               defun("char>?",		chars_are_greater,	2, 0, true);
  sc->char_leq_symbol =              defun("char<=?",		chars_are_leq,		2, 0, true);
  sc->char_geq_symbol =              defun("char>=?",		chars_are_geq,		2, 0, true);
  sc->char_position_symbol =         defun("char-position",	char_position,		2, 1, false);
  sc->string_position_symbol =       defun("string-position",	string_position,	2, 1, false);

  sc->make_string_symbol =           defun("make-string",	make_string,		1, 1, false);
  sc->string_ref_symbol =            defun("string-ref",	string_ref,		2, 0, false);
  sc->string_set_symbol =            defun("string-set!",	string_set,		3, 0, false);

  sc->string_eq_symbol =             defun("string=?",		strings_are_equal,	2, 0, true);
  sc->string_lt_symbol =             defun("string<?",		strings_are_less,	2, 0, true);
  sc->string_gt_symbol =             defun("string>?",		strings_are_greater,	2, 0, true);
  sc->string_leq_symbol =            defun("string<=?",	        strings_are_leq,	2, 0, true);
  sc->string_geq_symbol =            defun("string>=?",	        strings_are_geq,	2, 0, true);

#if !With_Pure_s7
  sc->char_ci_eq_symbol =            defun("char-ci=?",	        chars_are_ci_equal,	2, 0, true);
  sc->char_ci_lt_symbol =            defun("char-ci<?",	        chars_are_ci_less,	2, 0, true);
  sc->char_ci_gt_symbol =            defun("char-ci>?",	        chars_are_ci_greater,	2, 0, true);
  sc->char_ci_leq_symbol =           defun("char-ci<=?",	chars_are_ci_leq,	2, 0, true);
  sc->char_ci_geq_symbol =           defun("char-ci>=?",	chars_are_ci_geq,	2, 0, true);
  sc->string_ci_eq_symbol =          defun("string-ci=?",	strings_are_ci_equal,	2, 0, true);
  sc->string_ci_lt_symbol =          defun("string-ci<?",	strings_are_ci_less,	2, 0, true);
  sc->string_ci_gt_symbol =          defun("string-ci>?",	strings_are_ci_greater, 2, 0, true);
  sc->string_ci_leq_symbol =         defun("string-ci<=?",	strings_are_ci_leq,	2, 0, true);
  sc->string_ci_geq_symbol =         defun("string-ci>=?",	strings_are_ci_geq,	2, 0, true);
  sc->string_fill_symbol =           defun("string-fill!",	string_fill,		2, 2, false);
  sc->list_to_string_symbol =        defun("list->string",	list_to_string,		1, 0, false);
  sc->string_length_symbol =         defun("string-length",	string_length,		1, 0, false);
  sc->string_to_list_symbol =        defun("string->list",	string_to_list,		1, 2, false);
#endif
  sc->string_copy_symbol =           defun("string-copy",	string_copy,		1, 3, false);

  sc->string_downcase_symbol =       defun("string-downcase",	string_downcase,	1, 0, false);
  sc->string_upcase_symbol =         defun("string-upcase",	string_upcase,		1, 0, false);
  sc->string_append_symbol =         defun("string-append",	string_append,		0, 0, true);
  sc->substring_symbol =             defun("substring",	        substring,		1, 2, false);
  sc->substring_uncopied_symbol =    defun("substring-uncopied",substring_uncopied,	1, 2, false);
  sc->string_symbol =                defun("string",		string,			0, 0, true);
  sc->object_to_string_symbol =      defun("object->string",	object_to_string,	1, 2, false);
  sc->format_symbol =                defun("format",		format,			2, 0, true);
  sc->object_to_let_symbol =         defun("object->let",	object_to_let,	        1, 0, false);

  sc->cons_symbol =                  defun("cons",		cons,			2, 0, false); set_is_saver(sc->cons_symbol);
  sc->car_symbol =                   defun("car",		car,			1, 0, false);
  sc->cdr_symbol =                   defun("cdr",		cdr,			1, 0, false);
  sc->set_car_symbol =               defun("set-car!",		set_car,		2, 0, false);
  sc->set_cdr_symbol =               defun("set-cdr!",	        set_cdr,		2, 0, false);
  sc->caar_symbol =                  defun("caar",		caar,			1, 0, false);
  sc->cadr_symbol =                  defun("cadr",		cadr,			1, 0, false);
  sc->cdar_symbol =                  defun("cdar",		cdar,			1, 0, false);
  sc->cddr_symbol =                  defun("cddr",		cddr,			1, 0, false);
  sc->caaar_symbol =                 defun("caaar",		caaar,			1, 0, false);
  sc->caadr_symbol =                 defun("caadr",		caadr,			1, 0, false);
  sc->cadar_symbol =                 defun("cadar",		cadar,			1, 0, false);
  sc->cdaar_symbol =                 defun("cdaar",		cdaar,			1, 0, false);
  sc->caddr_symbol =                 defun("caddr",		caddr,			1, 0, false);
  sc->cdddr_symbol =                 defun("cdddr",		cdddr,			1, 0, false);
  sc->cdadr_symbol =                 defun("cdadr",		cdadr,			1, 0, false);
  sc->cddar_symbol =                 defun("cddar",		cddar,			1, 0, false);
  sc->caaaar_symbol =                defun("caaaar",		caaaar,			1, 0, false);
  sc->caaadr_symbol =                defun("caaadr",		caaadr,			1, 0, false);
  sc->caadar_symbol =                defun("caadar",		caadar,			1, 0, false);
  sc->cadaar_symbol =                defun("cadaar",		cadaar,			1, 0, false);
  sc->caaddr_symbol =                defun("caaddr",		caaddr,			1, 0, false);
  sc->cadddr_symbol =                defun("cadddr",		cadddr,			1, 0, false);
  sc->cadadr_symbol =                defun("cadadr",		cadadr,			1, 0, false);
  sc->caddar_symbol =                defun("caddar",		caddar,			1, 0, false);
  sc->cdaaar_symbol =                defun("cdaaar",		cdaaar,			1, 0, false);
  sc->cdaadr_symbol =                defun("cdaadr",		cdaadr,			1, 0, false);
  sc->cdadar_symbol =                defun("cdadar",		cdadar,			1, 0, false);
  sc->cddaar_symbol =                defun("cddaar",		cddaar,			1, 0, false);
  sc->cdaddr_symbol =                defun("cdaddr",		cdaddr,			1, 0, false);
  sc->cddddr_symbol =                defun("cddddr",		cddddr,			1, 0, false);
  sc->cddadr_symbol =                defun("cddadr",		cddadr,			1, 0, false);
  sc->cdddar_symbol =                defun("cdddar",		cdddar,			1, 0, false);

  sc->assq_symbol =                  defun("assq",		assq,			2, 0, false);
  sc->assv_symbol =                  defun("assv",		assv,			2, 0, false);
  sc->assoc_symbol =                 semisafe_defun("assoc",	assoc,			2, 1, false);
  sc->memq_symbol =                  defun("memq",		memq,			2, 0, false);
  sc->memv_symbol =                  defun("memv",		memv,			2, 0, false);
  sc->member_symbol =                semisafe_defun("member",	member,			2, 1, false);

  sc->list_symbol =                  defun("list",		list,			0, 0, true); set_is_saver(sc->list_symbol);
  sc->list_ref_symbol =              defun("list-ref",		list_ref,		2, 0, true);
  sc->list_set_symbol =              defun("list-set!",	        list_set,		3, 0, true);
  sc->list_tail_symbol =             defun("list-tail",	        list_tail,		2, 0, false);
  sc->make_list_symbol =             defun("make-list",  	make_list,		1, 1, false); set_is_saver(sc->make_list_symbol);

  sc->length_symbol =                defun("length",		length,			1, 0, false);
  sc->copy_symbol =                  defun("copy",		copy,			1, 3, false);
  /* set_is_definer(sc->copy_symbol); */ /* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */
  sc->fill_symbol =                  defun("fill!",		fill,			2, 2, false);
  sc->reverse_symbol =               defun("reverse",		reverse,		1, 0, false);
  sc->reverseb_symbol =              defun("reverse!",		reverse_in_place,	1, 0, false);
  sc->sort_symbol =                  unsafe_defun("sort!",      sort, 	                2, 0, false); /* not semisafe! */
  sc->append_symbol =                defun("append",		append,			0, 0, true);

#if !With_Pure_s7
  sc->vector_append_symbol =         defun("vector-append",	vector_append,		0, 0, true);
  sc->list_to_vector_symbol =        defun("list->vector",	list_to_vector,		1, 0, false);
  sc->vector_fill_symbol =           defun("vector-fill!",	vector_fill,		2, 2, false);
  sc->vector_length_symbol =         defun("vector-length",	vector_length,		1, 0, false);
  sc->vector_to_list_symbol =        defun("vector->list",	vector_to_list,		1, 2, false);
#else
  sc->vector_append_symbol = sc->append_symbol;
  sc->vector_fill_symbol = sc->fill_symbol;
  sc->string_fill_symbol = sc->fill_symbol;
#endif
  sc->vector_ref_symbol =            defun("vector-ref",	vector_ref,		2, 0, true);
  sc->vector_set_symbol =            defun("vector-set!",	vector_set,		3, 0, true);
  sc->vector_dimension_symbol =      defun("vector-dimension",  vector_dimension,	2, 0, false);
  sc->vector_dimensions_symbol =     defun("vector-dimensions", vector_dimensions,	1, 0, false);
  sc->vector_rank_symbol =           defun("vector-rank",       vector_rank,	        1, 0, false);
  sc->make_vector_symbol =           defun("make-vector",	make_vector,		1, 2, false); set_is_saver(sc->make_vector_symbol);
  sc->vector_symbol =                defun("vector",		vector,			0, 0, true);  set_is_saver(sc->vector_symbol);
  sc->vector_typer_symbol =          defun("vector-typer",      vector_typer,	        1, 0, false);

  sc->subvector_symbol =             defun("subvector",         subvector,	        1, 3, false); set_is_saver(sc->subvector_symbol);
  sc->subvector_position_symbol =    defun("subvector-position", subvector_position,    1, 0, false);
  sc->subvector_vector_symbol =      defun("subvector-vector",  subvector_vector,       1, 0, false);

  sc->float_vector_symbol =          defun("float-vector",	float_vector,		0, 0, true);
  sc->make_float_vector_symbol =     defun("make-float-vector", make_float_vector,	1, 1, false);
  sc->float_vector_set_symbol =      defun("float-vector-set!", float_vector_set,	3, 0, true);
  sc->float_vector_ref_symbol =      defun("float-vector-ref",  float_vector_ref,	2, 0, true);

  sc->complex_vector_symbol =        defun("complex-vector",	complex_vector,		0, 0, true);
  sc->make_complex_vector_symbol =   defun("make-complex-vector", make_complex_vector,	1, 1, false);
  sc->complex_vector_set_symbol =    defun("complex-vector-set!", complex_vector_set,	3, 0, true);
  sc->complex_vector_ref_symbol =    defun("complex-vector-ref",  complex_vector_ref,	2, 0, true);

  sc->int_vector_symbol =            defun("int-vector",	int_vector,		0, 0, true);
  sc->make_int_vector_symbol =       defun("make-int-vector",	make_int_vector,	1, 1, false);
  sc->int_vector_set_symbol =        defun("int-vector-set!",	int_vector_set,		3, 0, true);
  sc->int_vector_ref_symbol =        defun("int-vector-ref",	int_vector_ref,		2, 0, true);

  sc->byte_vector_symbol =           defun("byte-vector",	byte_vector,		0, 0, true);
  sc->make_byte_vector_symbol =      defun("make-byte-vector",  make_byte_vector,	1, 1, false);
  sc->byte_vector_ref_symbol =       defun("byte-vector-ref",	byte_vector_ref,        2, 0, true);
  sc->byte_vector_set_symbol =       defun("byte-vector-set!",	byte_vector_set,	3, 0, true);
  sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false);
  sc->byte_vector_to_string_symbol = defun("byte-vector->string", byte_vector_to_string, 1, 0, false);

  sc->hash_table_symbol =            defun("hash-table",	hash_table,		0, 0, true);
  set_has_even_args(global_value(sc->hash_table_symbol));
  set_is_saver(sc->hash_table_symbol);
  sc->make_hash_table_symbol =       defun("make-hash-table",	make_hash_table,	0, 3, false);
  sc->make_weak_hash_table_symbol =  defun("make-weak-hash-table", make_weak_hash_table,0, 3, false);
  sc->weak_hash_table_symbol =       defun("weak-hash-table",   weak_hash_table,        0, 0, true);
  set_has_even_args(global_value(sc->weak_hash_table_symbol));
  set_is_saver(sc->weak_hash_table_symbol);
  sc->hash_table_ref_symbol =        defun("hash-table-ref",	hash_table_ref,		2, 0, true);
  sc->hash_table_set_symbol =        defun("hash-table-set!",	hash_table_set,		3, 0, false);
  sc->hash_table_entries_symbol =    defun("hash-table-entries", hash_table_entries,	1, 0, false);
  sc->hash_code_symbol =             defun("hash-code",         hash_code,              1, 1, false);
  sc->dummy_equal_hash_table = make_dummy_hash_table(sc);
  sc->hash_table_key_typer_symbol =  defun("hash-table-key-typer", hash_table_key_typer, 1, 0, false);
  sc->hash_table_value_typer_symbol = defun("hash-table-value-typer", hash_table_value_typer, 1, 0, false);

  sc->cyclic_sequences_symbol =      defun("cyclic-sequences",  cyclic_sequences,	1, 0, false);
  sc->call_cc_symbol =               semisafe_defun("call/cc",	call_cc,		1, 0, false);
  sc->call_with_current_continuation_symbol = semisafe_defun("call-with-current-continuation", call_cc, 1, 0, false);
  sc->call_with_exit_symbol =        semisafe_defun("call-with-exit", call_with_exit,   1, 0, false); /* semisafe: see t101-6.scm, apply on stack */
  sc->goto_is_active_symbol =        defun("goto-active?",      goto_is_active,         1, 0, false);

  sc->load_symbol =                  semisafe_defun("load",	load,			1, 1, false);
  sc->autoload_symbol =              defun("autoload",	        autoload,		2, 0, false);
  sc->eval_symbol =                  semisafe_defun("eval",	eval,			1, 1, false); set_func_is_definer(sc->eval_symbol);
  sc->eval_string_symbol =           semisafe_defun("eval-string", eval_string,		1, 1, false); set_func_is_definer(sc->eval_string_symbol);
  sc->apply_symbol =                 unsafe_defun("apply",      apply,			1, 0, true); /* not semisafe */
  set_func_is_definer(sc->apply_symbol);
  /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply
   *   perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof
   */

  sc->for_each_symbol =              semisafe_defun("for-each",	for_each,		2, 0, true);
  sc->map_symbol =                   semisafe_defun("map",	map,			2, 0, true);
  sc->dynamic_wind_symbol =          semisafe_defun("dynamic-wind", dynamic_wind,       3, 0, false);
  sc->dynamic_unwind_symbol =        semisafe_defun("dynamic-unwind", dynamic_unwind,   2, 1, false);
  sc->catch_symbol =                 semisafe_defun("catch",	catch,			3, 0, false);
  sc->throw_symbol =                 unsafe_defun("throw",	throw,			1, 0, true); /* not semisafe! */
  sc->error_symbol =                 unsafe_defun("error",	error,			1, 0, true); /* not semisafe! */
  /* 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, "<unquote>", 9); set_immutable(sc->unquote_symbol);
#else
  sc->unquote_symbol =               make_symbol(sc, "unquote", 7);
#endif
  sc->qq_append_symbol =             defun("<list*>",           qq_append,		2, 0, false); set_is_saver(sc->qq_append_symbol); /* occurs via quasiquote as #_<list*> */
  sc->apply_values_symbol =          unsafe_defun("apply-values", apply_values,         0, 1, false); set_is_saver(sc->apply_values_symbol);
  sc->list_values_symbol =           defun("list-values",       list_values,            0, 0, true);  set_is_saver(sc->list_values_symbol);
  copy_initial_value(sc, sc->apply_values_symbol);
  copy_initial_value(sc, sc->list_values_symbol);
  /* are these three names necessary? */

  sc->documentation_symbol =         defun("documentation",     documentation,          1, 0, false);
  sc->signature_symbol =             defun("signature",         signature,	        1, 0, false);
  sc->help_symbol =                  defun("help",		help,			1, 0, false);
  sc->procedure_source_symbol =      defun("procedure-source",  procedure_source,	1, 0, false);
  sc->procedure_arglist_symbol =     defun("procedure-arglist", procedure_arglist,      1, 0, false);
  sc->funclet_symbol =               defun("funclet",		funclet,		1, 0, false);
  sc->_function__symbol =            defun("*function*",        function,	        0, 2, false);
  sc->dilambda_symbol =              defun("dilambda",          dilambda,               2, 0, false);
  {
    s7_pointer get_func = s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL);
    set_immutable(c_function_setter(get_func));
  }
  sc->arity_symbol =                 defun("arity",		arity,			1, 0, false);
  sc->is_aritable_symbol =           defun("aritable?",	        is_aritable,		2, 0, false);

  sc->is_eq_symbol =                 defun("eq?",		is_eq,			2, 0, false);
  sc->is_eqv_symbol =                defun("eqv?",		is_eqv,			2, 0, false);
  sc->is_equal_symbol =              defun("equal?",		is_equal,		2, 0, false);
  sc->is_equivalent_symbol =         defun("equivalent?",	is_equivalent,	2, 0, false);
  sc->type_of_symbol =               defun("type-of",		type_of,		1, 0, false);
  sc->type_name_symbol =             defun("type-name",		type_name,		1, 0, false);

  sc->gc_symbol =                    semisafe_defun("gc",	gc,			0, 1, false);
                                     defun("emergency-exit",	emergency_exit,		0, 1, false);
  sc->exit_symbol =                  defun("exit",		exit,			0, 2, false);

#if WITH_GCC
  s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope");
#endif
#if s7_Debugging
  defun("heap-scan", heap_scan, 1, 0, false);
  defun("heap-analyze", heap_analyze, 0, 0, false);
  defun("heap-holder", heap_holder, 1, 0, false);
  defun("heap-holders", heap_holders, 1, 0, false);

  defun("show-stack", show_stack, 0, 1, false);
  defun("show-op-stack", show_op_stack, 0, 0, false);
  defun("op-stack?", is_op_stack, 0, 0, false);
#endif
  s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, "short-term debugging aid");
  sc->c_object_set_function = s7_make_safe_function(sc, "#<c-object-setter>", g_c_object_set, 1, 0, true, "c-object setter");
  /* c_function_set_signature(sc->c_object_set_function, s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T)); */

  set_scope_safe(global_value(sc->call_with_input_string_symbol));
  set_scope_safe(global_value(sc->call_with_input_file_symbol));
  set_scope_safe(global_value(sc->call_with_output_string_symbol));
  set_scope_safe(global_value(sc->call_with_output_file_symbol));
  set_scope_safe(global_value(sc->with_input_from_string_symbol));
  set_scope_safe(global_value(sc->with_input_from_file_symbol));
  set_scope_safe(global_value(sc->with_output_to_string_symbol));
  set_scope_safe(global_value(sc->with_output_to_file_symbol));
  set_maybe_safe(global_value(sc->assoc_symbol));
  set_scope_safe(global_value(sc->assoc_symbol));
  set_maybe_safe(global_value(sc->member_symbol));
  set_scope_safe(global_value(sc->member_symbol));
  set_scope_safe(global_value(sc->sort_symbol));
  set_scope_safe(global_value(sc->call_with_exit_symbol));
  set_scope_safe(global_value(sc->for_each_symbol));
  set_maybe_safe(global_value(sc->for_each_symbol));
  set_scope_safe(global_value(sc->map_symbol));
  set_maybe_safe(global_value(sc->map_symbol));
  set_scope_safe(global_value(sc->dynamic_wind_symbol));
  set_scope_safe(global_value(sc->catch_symbol));
  set_scope_safe(global_value(sc->throw_symbol));
  set_scope_safe(global_value(sc->error_symbol));
  set_scope_safe(global_value(sc->apply_values_symbol));

  sc->tree_leaves_symbol =    defun("tree-leaves",   tree_leaves,    1, 0, false);
  sc->tree_memq_symbol =      defun("tree-memq",     tree_memq,      2, 0, false);
  sc->tree_set_memq_symbol =  defun("tree-set-memq", tree_set_memq,  2, 0, false);
  sc->tree_count_symbol =     defun("tree-count",    tree_count,     2, 1, false);
  sc->tree_is_cyclic_symbol = defun("tree-cyclic?",  tree_is_cyclic, 1, 0, false);

  sc->hook_functions_symbol = defun("hook-functions", hook_functions, 1, 0, false);

  sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); /* is this considered syntax? r7rs says yes; also unquote */
  copy_initial_value(sc, sc->quasiquote_symbol);
  sc->quasiquote_function = initial_value(sc->quasiquote_symbol);

  sc->reader_cond_symbol = s7_define_expansion(sc, "reader-cond", g_reader_cond, 1, 0, true, H_reader_cond);
#if !With_Pure_s7
  sc->cond_expand_symbol = s7_define_expansion(sc, "cond-expand", g_cond_expand, 1, 0, true, H_cond_expand);
#endif

  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->global_string_copy = global_value(sc->string_copy_symbol);
  sc->delay_symbol = make_symbol(sc, "delay", 5); /* might be defined if in Snd */
  sc->global_delay = (is_slot(global_slot(sc->delay_symbol))) ? global_value(sc->delay_symbol) : sc->undefined;
  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->initial_string_copy = initial_value(sc->string_copy_symbol);
  sc->initial_delay = (is_slot(global_slot(sc->delay_symbol))) ? initial_value(sc->delay_symbol) : sc->undefined;

  sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */
  sc->profile_out = NULL;

  /* -------- *features* -------- */
  sc->features_symbol = s7_define_variable_with_documentation(sc, "*features*", sc->nil, "list of currently available features ('complex-numbers, etc)");
  s7_set_setter(sc, sc->features_symbol, sc->features_setter = s7_make_safe_function(sc, "#<set-*features*>", g_features_set, 2, 0, false, "*features* setter"));

  /* -------- *load-path* -------- */
  sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil, /* list_1(sc, make_string_with_length(sc, ".", 1)), */ /* not plist! */
			   "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name");
  s7_set_setter(sc, sc->load_path_symbol, s7_make_safe_function(sc, "#<set-*load-path*>", g_load_path_set, 2, 0, false, "*load-path* setter"));

#ifdef CLOAD_DIR
  sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR));
  s7_add_to_load_path(sc, (const char *)CLOAD_DIR);
#else
  sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", nil_string);
#endif
  s7_set_setter(sc, sc->cload_directory_symbol,
		s7_make_safe_function(sc, "#<set-*cload-directory*>", g_cload_directory_set, 2, 0, false, "*cload-directory* setter"));

  /* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */
  sc->autoloader_symbol = s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader, Q_autoloader);
  c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */

  sc->libraries_symbol = s7_define_variable_with_documentation(sc, "*libraries*", sc->nil, "list of currently loaded libraries (libc.scm, etc)");
  s7_set_setter(sc, sc->libraries_symbol, s7_make_safe_function(sc, "#<set-*libraries*>", g_libraries_set, 2, 0, false, "*libraries* setter"));

  s7_autoload(sc, make_symbol(sc, "cload.scm", 9),        s7_make_semipermanent_string(sc, "cload.scm"));
  s7_autoload(sc, make_symbol(sc, "lint.scm", 8),         s7_make_semipermanent_string(sc, "lint.scm"));
  s7_autoload(sc, make_symbol(sc, "stuff.scm", 9),        s7_make_semipermanent_string(sc, "stuff.scm"));
  s7_autoload(sc, make_symbol(sc, "mockery.scm", 11),     s7_make_semipermanent_string(sc, "mockery.scm"));
  s7_autoload(sc, make_symbol(sc, "write.scm", 9),        s7_make_semipermanent_string(sc, "write.scm"));
  s7_autoload(sc, make_symbol(sc, "reactive.scm", 12),    s7_make_semipermanent_string(sc, "reactive.scm"));
  s7_autoload(sc, make_symbol(sc, "repl.scm", 8),         s7_make_semipermanent_string(sc, "repl.scm"));
  s7_autoload(sc, make_symbol(sc, "r7rs.scm", 8),         s7_make_semipermanent_string(sc, "r7rs.scm"));
  s7_autoload(sc, make_symbol(sc, "profile.scm", 11),     s7_make_semipermanent_string(sc, "profile.scm"));
  s7_autoload(sc, make_symbol(sc, "debug.scm", 9),        s7_make_semipermanent_string(sc, "debug.scm"));
  s7_autoload(sc, make_symbol(sc, "case.scm", 8),         s7_make_semipermanent_string(sc, "case.scm"));

  s7_autoload(sc, make_symbol(sc, "libc.scm", 8),         s7_make_semipermanent_string(sc, "libc.scm"));
  s7_autoload(sc, make_symbol(sc, "libm.scm", 8),         s7_make_semipermanent_string(sc, "libm.scm"));    /* repl.scm adds *libm* */
  s7_autoload(sc, make_symbol(sc, "libdl.scm", 9),        s7_make_semipermanent_string(sc, "libdl.scm"));
  s7_autoload(sc, make_symbol(sc, "libgsl.scm", 10),      s7_make_semipermanent_string(sc, "libgsl.scm"));  /* repl.scm adds *libgsl* -- 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* -------- */
  {
    const s7_pointer sym = s7_define_variable_with_documentation(sc, "*#readers*", sc->nil, "list of current reader macros");
    sc->sharp_readers = global_slot(sym);
    sc->saved_sharp_readers = sc->nil;
    s7_set_setter(sc, sym, s7_make_safe_function(sc, "#<set-*#readers*>", g_sharp_readers_set, 2, 0, false, "*#readers* setter"));
  }
  sc->local_documentation_symbol = make_symbol(sc, "+documentation+", 15);
  sc->local_signature_symbol =     make_symbol(sc, "+signature+", 11);
  sc->local_setter_symbol =        make_symbol(sc, "+setter+", 8);
  sc->local_iterator_symbol =      make_symbol(sc, "+iterator+", 10);

  init_features(sc);
  init_setters(sc);
}

#if !MS_Windows
static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER;
#endif

s7_scheme *s7_init(void)
{
  s7_scheme *sc;
  static bool already_inited = false;

#if !MS_Windows
  setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */
  pthread_mutex_lock(&init_lock);
#endif

  if (!already_inited)
    {
      init_types();
      init_ctables();
      init_mark_functions();
      init_display_functions();
      init_length_functions();
      init_equals();
      init_hash_maps();
      init_pows();
      init_int_limits();
      init_small_ints();
      init_uppers();
      init_chars();
      init_strings();
      init_fx_function();
      init_catchers();
      init_starlet_immutable_field();
      init_leven();
      already_inited = true;
    }

#if s7_Debugging
  init_never_unheaped();
#endif
#if !MS_Windows
  pthread_mutex_unlock(&init_lock);
#endif
  sc = (s7_scheme *)Calloc(1, sizeof(s7_scheme)); /* not malloc! */
#if s7_Debugging || ((Disable_File_Output || Pointer_32) && (!WITH_GCC))
  if (!cur_sc) original_cur_sc = sc;
  cur_sc = sc;
#endif
  sc->overall_start_time = my_clock();
  sc->gc_off = true;                              /* sc->args and so on are not set yet, so a gc during init -> segfault */
  sc->gc_in_progress = false;
  sc->gc_stats = 0;

  sc->saved_pointers = (void **)Malloc(Initial_Saved_Pointers_Size * sizeof(void *));
  sc->saved_pointers_loc = 0;
  sc->saved_pointers_size = Initial_Saved_Pointers_Size;

  init_gc_caches(sc);
  sc->semipermanent_cells = 0;
  sc->alloc_pointer_k = Alloc_Pointer_Size;
  sc->alloc_pointer_cells = NULL;
  sc->alloc_big_pointer_k = Alloc_Big_Pointer_Size;
  sc->alloc_big_pointer_cells = NULL;
  sc->alloc_function_k = Alloc_Function_Size;
  sc->alloc_function_cells = NULL;
  sc->alloc_symbol_k = Alloc_Symbol_Size;
  sc->alloc_symbol_cells = NULL;
  sc->num_to_str_size = -1;
  sc->num_to_str = NULL;
  init_block_lists(sc);
  sc->alloc_string_k = Alloc_String_Size;
  sc->alloc_string_cells = NULL;
  sc->alloc_opt_func_cells = NULL;
  sc->alloc_opt_func_k = Alloc_Function_Size;
  sc->longjmp_ok = false;
  sc->setjmp_loc = No_Set_Jump;
  sc->max_vector_length = (1LL << 32);
  sc->max_string_length = 1073741824; /* 1 << 30 */
  sc->max_list_length = 1073741824;
  sc->max_vector_dimensions = 512;
  sc->strbuf_size = Initial_Strbuf_Size;
  sc->strbuf = (char *)Calloc(sc->strbuf_size, 1);
  sc->print_width = sc->max_string_length;
  sc->short_print = false;
  sc->in_with_let = false;
  sc->do_body_p = NULL;
  sc->object_out_locked = false;
  sc->has_openlets = true;
  sc->is_expanding = true;
  sc->accept_all_keyword_arguments = false;
  sc->muffle_warnings = false;
  sc->symbol_quote = false;
  sc->initial_string_port_length = 128;
  sc->format_depth = -1;
  sc->singletons = (s7_pointer *)Calloc(Num_Chars, sizeof(s7_pointer));
  add_saved_pointer(sc, sc->singletons);
  sc->read_line_buf = NULL;
  sc->read_line_buf_size = 0;
  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, "#<unused>",      T_UNUSED);
  sc->T =              make_unique(sc, "#t",             T_BOOLEAN);
  sc->F =              make_unique(sc, "#f",             T_BOOLEAN);
  sc->undefined =      make_unique(sc, "#<undefined>",   T_UNDEFINED);
  sc->unspecified =    make_unique(sc, "#<unspecified>", T_UNSPECIFIED);
  sc->do_unspecified = make_unique(sc, "#<do-unspecified>", T_UNSPECIFIED);
  sc->no_value =       make_unique(sc, (Eval_Print || s7_Debugging) ? "#<no-value>" : "#<unspecified>", T_UNSPECIFIED);

  unique_car(sc->nil) = sc->unspecified; /* see op_if1 */
  unique_cdr(sc->nil) = sc->unspecified;
  unique_cdr(sc->unspecified) = sc->unspecified;

  sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil,  T_PAIR | T_Immutable);
  sc->t2_2 = semipermanent_cons(sc, sc->unused, sc->nil,  T_PAIR | T_Immutable);
  sc->t2_1 = semipermanent_cons(sc, sc->unused, sc->t2_2, T_PAIR | T_Immutable);
  sc->t3_3 = semipermanent_cons(sc, sc->unused, sc->nil,  T_PAIR | T_Immutable);
  sc->t3_2 = semipermanent_cons(sc, sc->unused, sc->t3_3, T_PAIR | T_Immutable);
  sc->t3_1 = semipermanent_cons(sc, sc->unused, sc->t3_2, T_PAIR | T_Immutable);
#if WITH_T4_N
  sc->t4_4 = semipermanent_cons(sc, sc->unused, sc->nil,  T_PAIR | T_Immutable);
  sc->t4_3 = semipermanent_cons(sc, sc->unused, sc->t4_4, T_PAIR | T_Immutable);
  sc->t4_2 = semipermanent_cons(sc, sc->unused, sc->t4_3, T_PAIR | T_Immutable);
  sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t4_2, T_PAIR | T_Immutable);
#else
  sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t3_1, T_PAIR | T_Immutable);
#endif
  sc->u1_1 = semipermanent_cons(sc, sc->unused, sc->nil,  T_PAIR | T_Immutable); /* ulist */

  sc->safe_lists[0] = sc->nil;
  for (int32_t i = 1; i < Num_Safe_Prelists; i++)
    sc->safe_lists[i] = semipermanent_list(sc, i);
  for (int32_t i = Num_Safe_Prelists; i < Num_Safe_Lists; i++)
    sc->safe_lists[i] = sc->nil;
  sc->current_safe_list = 0;
#if s7_Debugging
  local_memset((void *)(sc->safe_list_uses), 0, Num_Safe_Lists);
#endif

  sc->input_port_stack_size = Input_Port_Stack_Initial_Size;
  sc->input_port_stack = (s7_pointer *)Malloc(sc->input_port_stack_size * sizeof(s7_pointer));
  sc->input_port_stack_loc = 0;

  sc->code = sc->nil;
#if With_History
  sc->eval_history1 = semipermanent_list(sc, Default_History_Size);
  sc->eval_history2 = semipermanent_list(sc, Default_History_Size);
  sc->history_pairs = semipermanent_list(sc, Default_History_Size);
  sc->history_sink = semipermanent_list(sc, 1);
  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;
  }
#else
  sc->cur_code = sc->F;
#endif
  sc->args = sc->nil;
  sc->value = sc->nil;
  sc->v = sc->unused;
  sc->w = sc->unused;
  sc->x = sc->unused;
  sc->y = sc->unused;
  sc->z = sc->unused;
  sc->temp1 = sc->unused;
  sc->temp2 = sc->unused;
  sc->temp3 = sc->unused;
  sc->temp4 = sc->unused;
  sc->temp5 = sc->unused;
  sc->temp6 = sc->unused;
  sc->temp7 = sc->unused;
  sc->temp8 = sc->unused;
  sc->temp9 = sc->unused;
  sc->rec_p1 = sc->unused;
  sc->rec_p2 = sc->unused;
  sc->read_dims = Int_Zero;

  sc->begin_hook = NULL;
  sc->autoload_table = sc->nil;
  sc->autoload_names = NULL;
  sc->autoload_names_sizes = NULL;
  sc->autoloaded_already = NULL;
  sc->autoload_names_loc = 0;
#if Disable_Autoload
  sc->is_autoloading = false;
#else
  sc->is_autoloading = true;
#endif
  sc->max_show_stack_frames = 20;

  sc->heap_size = (Initial_Heap_Size >= 32) ? Initial_Heap_Size : 64000;
  if ((sc->heap_size % 32) != 0)
    sc->heap_size = 32 * (s7_int)ceil((double)(sc->heap_size) / 32.0);
  sc->heap = (s7_pointer *)Malloc(sc->heap_size * sizeof(s7_pointer));
  sc->free_heap = (s7_cell **)Malloc(sc->heap_size * sizeof(s7_cell *));
  sc->free_heap_top = (s7_cell **)(sc->free_heap + sc->heap_size);
  sc->free_heap_trigger = (s7_cell **)(sc->free_heap + Gc_Trigger_Size);
  sc->previous_free_heap_top = sc->free_heap_top;
  {
    s7_cell *cells = (s7_cell *)Malloc(sc->heap_size * sizeof(s7_cell)); /* was calloc 14-Apr-22 */
    add_saved_pointer(sc, (void *)cells);
    for (s7_int i = 0; i < sc->heap_size; i++)       /* Loop_4 here is slower! initial heap size can be too big for int32_t 13-Apr-25 */
      {
	sc->heap[i] = &cells[i];
 	sc->free_heap[i] = sc->heap[i];
#if s7_Debugging
	sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; sc->heap[i]->uses = 0;
#endif
	clear_type(sc->heap[i]);              /* type(sc->heap[i]) = T_FREE */
	i++;
	sc->heap[i] = &cells[i];
 	sc->free_heap[i] = sc->heap[i];
#if s7_Debugging
	sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL;  sc->heap[i]->uses = 0;
#endif
	clear_type(sc->heap[i]);
     }
    /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), sizeof(s7_pointer) * sc->heap_size); */
    /*   weird that this memcpy (without the equivalent sets above) is much slower */
    sc->heap_blocks = (heap_block_t *)Malloc(sizeof(heap_block_t));
    sc->heap_blocks->start = (intptr_t)cells;
    sc->heap_blocks->end = (intptr_t)cells + (sc->heap_size * sizeof(s7_cell));
    sc->heap_blocks->offset = 0;
    sc->heap_blocks->next = NULL;
  }
  sc->gc_temps_size = (Gc_Temps_Size > 0) ? Gc_Temps_Size : 256;
  sc->gc_resize_heap_fraction = Gc_Resize_Heap_Fraction;
  sc->gc_resize_heap_by_4_fraction = Gc_Resize_Heap_By_4_Fraction;
  sc->max_heap_size = (1LL << 45);
  sc->gc_calls = 0;
  sc->gc_true_calls = 0;
  sc->gc_total_time = 0;
  sc->gc_true_total_time = 0;
  /* unvectorize free-heap?  t_free obj nxt -> next in list, free_heap_top|length; get free: obj=free_heap_top; top=nxt; len--
   *   push: cur->nxt=top, top=cur len++; trigger when len<trigger; can still do batch alloc/free setting len at end;
   *   how to gc sweep tmps -- seems to require a back pointer (2-way list) but there's no room; no need to realloc when heap grows, but do
   *   need to place new cells on the free list; no malloc needed, but we need to make the initial list; saves 1/8 of heap-related space.
   *   maybe a circular list (vector?) for tmps
   */

  sc->max_string_port_length = (1LL << 45);
  sc->output_file_port_length = Output_File_Port_Length;
  {
    const 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 multivector->gc_protect_2 */
    sc->protected_setters_size = size;
    sc->protected_setters_loc = 0;
    sc->protected_setters = make_vector_1(sc, size, Vector_Filled, T_VECTOR);
    sc->protected_setter_symbols = make_vector_1(sc, size, Vector_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, Vector_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, Vector_Filled, T_VECTOR);
  /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */
  sc->stack_start = vector_elements(sc->stack); /* stack type set below */
  sc->stack_end = sc->stack_start;
  if (Stack_Resize_Trigger <= (Initial_Stack_Size / 2))
    sc->stack_size = Initial_Stack_Size;
  else sc->stack_size = Stack_Resize_Trigger * 2;
  sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (Initial_Stack_Size - Stack_Resize_Trigger));
  set_full_type(sc->stack, T_STACK);
  sc->max_stack_size = (1 << 30);
  stack_clear_flags(sc->stack);
  initialize_op_stack(sc);
  initialize_recur_stack(sc);

  /* keep the symbol table out of the heap */
  sc->symbol_table = (s7_pointer)Malloc(sizeof(s7_cell)); /* was calloc 14-Apr-22 */
  full_type(sc->symbol_table) = T_VECTOR | T_Unheap | T_Symbol_Table;
  set_alloc_info(sc->symbol_table, __func__, __LINE__);
  vector_length(sc->symbol_table) = Symbol_Table_Size;
  vector_elements(sc->symbol_table) = (s7_pointer *)Malloc(Symbol_Table_Size * sizeof(s7_pointer));
  vector_getter(sc->symbol_table) = t_vector_getter;
  vector_setter(sc->symbol_table) = t_vector_setter;
  t_vector_fill(sc->symbol_table, sc->nil);

  { /* sc->opts */
    opt_info *os = (opt_info *)Malloc(Opts_Size * sizeof(opt_info)); /* was calloc, 17-Oct-21 */
    add_saved_pointer(sc, os);
    for (int32_t i = 0; i < Opts_Size; i++)
      {
	opt_info *o = &os[i];
	sc->opts[i] = o;
	o->sc = sc;
      }}

  for (int32_t i = 0; i < Num_Types; i++)
    sc->type_names[i] = s7_make_semipermanent_string(sc, (const char *)type_name_from_type(i, Indefinite_Article));

#if With_Multithread_Checks
  sc->lock_count = 0;
  {
    pthread_mutexattr_t attr;
    pthread_mutexattr_init(&attr);
    pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
    pthread_mutex_init(&sc->lock, &attr);
  }
#endif

  sc->c_object_types = NULL;
  sc->c_object_types_size = 0;
  sc->num_c_object_types = 0;
  sc->typnam = NULL;
  sc->typnam_len = 0;
  sc->default_rationalize_error = 1.0e-12;
  sc->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;
#if s7_Debugging
  sc->big_symbol_set_state = Set_Ignore;
  sc->small_symbol_set_state = Set_Ignore;
  sc->y_line = 0;
  sc->v_line = 0;
  sc->c_functions_allocated = 0;
#endif
  sc->symbol_printer = sc->F;
  sc->class_name_symbol = make_symbol(sc, "class-name", 10);
  sc->name_symbol = make_symbol(sc, "name", 4);
  sc->trace_in_symbol = make_symbol(sc, "trace-in", 8);
  sc->size_symbol = make_symbol(sc, "size", 4);
  sc->is_mutable_symbol = make_symbol(sc, "mutable?", 8);
  sc->file__symbol = make_symbol(sc, "FILE*", 5);
  sc->circle_info = make_shared_info(sc);
  sc->fdats = (format_data_t **)Malloc(8 * sizeof(format_data_t *));
  sc->num_fdats = 8;
  for (int32_t k = 0; k < 8; k++) sc->fdats[k] = make_fdat(sc);
  sc->mlist_1 = semipermanent_list(sc, 1);
  sc->mlist_2 = semipermanent_list(sc, 2);
  sc->plist_1 = semipermanent_list(sc, 1);
  sc->plist_2 = semipermanent_list(sc, 2);
  sc->plist_2_2 = cdr(sc->plist_2);
  sc->plist_3 = semipermanent_list(sc, 3);
  sc->plist_4 = semipermanent_cons(sc, sc->unused, sc->plist_3, T_PAIR | T_Immutable);
  sc->qlist_2 = semipermanent_list(sc, 2);
  sc->qlist_3 = semipermanent_cons(sc, sc->unused, sc->qlist_2, T_PAIR | T_Immutable);
  sc->clist_1 = semipermanent_list(sc, 1);
  sc->clist_2 = semipermanent_list(sc, 2);
  sc->dlist_1 = semipermanent_list(sc, 1);
  sc->elist_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_Immutable | T_Is_Elist);
  sc->elist_2 = semipermanent_list(sc, 2); set_is_elist(sc->elist_2);
  sc->elist_3 = semipermanent_list(sc, 3); set_is_elist(sc->elist_3);
  sc->elist_4 = semipermanent_cons(sc, sc->unused, sc->elist_3, T_PAIR | T_Immutable | T_Is_Elist);
  sc->elist_5 = semipermanent_cons(sc, sc->unused, sc->elist_4, T_PAIR | T_Immutable | T_Is_Elist);
  sc->elist_6 = semipermanent_cons(sc, sc->unused, sc->elist_5, T_PAIR | T_Immutable | T_Is_Elist);
  sc->elist_7 = semipermanent_cons(sc, sc->unused, sc->elist_6, T_PAIR | T_Immutable | T_Is_Elist);
  sc->undefined_identifier_warnings = false;
  sc->undefined_constant_warnings = false;
  sc->wrap_only = make_wrap_only(sc);
  sc->unentry = (hash_entry_t *)Malloc(sizeof(hash_entry_t));
  hash_entry_set_value(sc->unentry, sc->F);
  sc->begin_op = OP_BEGIN_NO_HOOK;
  /* we used to laboriously set various other fields to null, but the calloc takes care of that */
  sc->tree_pointers = NULL;
  sc->tree_pointers_size = 0;
  sc->tree_pointers_top = 0;
  sc->objstr_max_len = s7_Int64_Max;
  sc->temp_error_hook = sc->nil;
  sc->anon_symbol = make_symbol(sc, "anonymous-lambda", 16);

  sc->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);

  {
    s7_pointer rs;
    new_cell(sc, rs, T_RANDOM_STATE);       /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */
    sc->default_random_state = rs;
#if With_Gmp
    mpz_set_ui(sc->mpz_1, (uint64_t)my_clock());
    gmp_randinit_default(random_gmp_state(rs));
    gmp_randseed(random_gmp_state(rs), sc->mpz_1);
#else
    random_seed(rs) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */
    random_carry(rs) = 1675393560;
#endif
  }

  sc->bignum_precision = Default_Bignum_Precision;
#if With_Gmp
  sc->bigints = NULL;
  sc->bigrats = NULL;
  sc->bigflts = NULL;
  sc->bigcmps = NULL;

  mpfr_set_default_prec((mp_prec_t)Default_Bignum_Precision);
  mpc_set_default_precision((mp_prec_t)Default_Bignum_Precision);
  mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
  mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
  mpfr_inits2(Default_Bignum_Precision, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL);
  mpc_init(sc->mpc_1);
  mpc_init(sc->mpc_2);

  sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); /* not actually a constant because it changes with bignum-precision */
  s7_provide(sc, "gmp");
  set_initial_value(sc->pi_symbol, global_value(sc->pi_symbol));
  copy_initial_value(sc, sc->pi_symbol); /* Real_Pi (below) is not in the heap so pi's initial_value is Real_Pi if not gmp (s7_make_slot 9571) */
#else
  sc->pi_symbol = s7_define_constant(sc, "pi", Real_Pi);
#endif

  for (int32_t i = 0; i < 10; i++) sc->singletons[(uint8_t)'0' + i] = small_int(i);
  sc->singletons[(uint8_t)'+'] = sc->add_symbol;
  sc->singletons[(uint8_t)'-'] = sc->subtract_symbol;
  sc->singletons[(uint8_t)'*'] = sc->multiply_symbol;
  sc->singletons[(uint8_t)'/'] = sc->divide_symbol;
  sc->singletons[(uint8_t)'<'] = sc->lt_symbol;
  sc->singletons[(uint8_t)'>'] = sc->gt_symbol;
  sc->singletons[(uint8_t)'='] = sc->num_eq_symbol;

  init_choosers(sc);
  init_typers(sc);
  init_opt_functions(sc);
#if s7_Debugging
  init_tc_rec(sc);
#endif
  s7_set_history_enabled(sc, false); /* see below */
  init_signatures(sc);      /* depends on procedure symbols */
  sc->starlet = make_starlet(sc);
  s7_set_history_enabled(sc, true);

  s7_eval_c_string(sc, "(define make-hook                                                                 \n\
                          (let ((+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes that hook to each function in its function list.\")) \n\
                            (lambda hook-args                                                             \n\
                              (let ((body ()))   ; list of functions                                      \n\
                                (apply lambda* hook-args                                                  \n\
                                  '((let ((result #<unspecified>))                                        \n\
                                      (let ((hook (openlet (sublet (curlet) 'let-ref-fallback #<undefined>)))) \n\
                                        (for-each (lambda (func) (func hook)) body)                       \n\
                                        result))))))))");
  /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #<unspecified>)) ... result)), see stuff.scm for commentary
   * '((when (pair? body) ...) at start might be a good idea -- depends on how often an empty hook is called
   * moving make-hook to C (see tmphook) was a lot of code and did not save anything at start-up (20/1750 in callgrind, ca 1%)
   */

  /* -------- *unbound-variable-hook* -------- */
  sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)");
  s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", sc->unbound_variable_hook,
					"*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable).");

  /* -------- *missing-close-paren-hook* -------- */
  sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)");
  s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", sc->missing_close_paren_hook,
					"*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing");

  /* -------- *error-hook* -------- */
  sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook,
					"*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data).");

  /* -------- *load-hook* -------- */
  sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)");
  s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook,
					"*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)");

  /* -------- *autoload-hook* -------- */
  sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)");
  s7_define_constant_with_documentation(sc, "*autoload-hook*", sc->autoload_hook,
					"*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))");

  /* -------- *read-error-hook* -------- */
  sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook,
					"*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data).");

  /* -------- *rootlet-redefinition-hook* -------- */
  sc->rootlet_redefinition_hook = s7_eval_c_string(sc, "(make-hook 'name 'value)");
  s7_define_constant_with_documentation(sc, "*rootlet-redefinition-hook*", sc->rootlet_redefinition_hook,
					"*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value).");

  sc->temp_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  /* internal; this is holding error-hook functions during an evaluation where error-hook is temporarily nil -- do we actually need a hook for this? */

#if !With_Pure_s7
  {
    s7_pointer rs = s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol));
    set_initial_value(rs, initial_value(sc->complex_symbol)); /* for #_make-rectangular */
  }

  s7_eval_c_string(sc, "(define (call-with-values producer consumer) (apply consumer (list (producer))))");
  /* (consumer (producer)) will work in any "normal" context.  If consumer is syntax and then subsequently not syntax, there is confusion */

  s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) (list (cons 'lambda (cons vars body)) expression))");

  /* call-with-values, make-hook and multiple-value-bind can't set the initial_value to the global_value
   *   so that #_... can be used because the global_value is not semipermanent, but could it be made so? (via remove_from_heap?)
   *   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 != 926)
    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, 112 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");
#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 */
  fprintf(stderr, "sizes: c_proc_t %d, c_object_t %d, vunion: %d, port_t %d, block_t %d, port_functions_t %d, s7_cell %d, s7 %d, opt_info %d\n",
	  (int)sizeof(c_proc_t), (int)sizeof(c_object_t), (int)sizeof(vunion), (int)sizeof(port_t),
	  (int)sizeof(block_t), (int)sizeof(port_functions_t), (int)sizeof(s7_cell), (int)sizeof(s7_scheme), (int)sizeof(opt_info));
#endif
  return(sc);
}


/* -------------------------------- s7_free -------------------------------- */
static void gc_list_free(gc_list_t *g)
{
  free(g->list);
  free(g);
}

static void big_block_free(s7_scheme *unused_sc, block_t *block)
{
  if ((block_index(block) == Top_Block_List) && (block_data(block)))
    {
      free(block_data(block));
      block_data(block) = NULL;
    }
}

void s7_free(s7_scheme *sc)
{
  /* free the memory associated with sc (not globals since we might have multiple s7 interpreters running)
   *   most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly
   * valgrind --leak-check=full --show-reachable=no --suppressions=/home/bil/cl/free.supp repl s7test.scm
   * valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm
   */
  gc_list_t *gp;

  /* g_gc(sc, sc->nil); */ /* probably not needed (my simple tests work fine if the gc call is omitted) */ /* removed 14-Apr-22 */
  /* s7_quit(sc);       */ /* not always needed -- will clean up the C stack if we haven't returned to the top level */

  gp = call_c_object_frees(sc); /* do this first since they might involve gc_unprotect etc */
  gc_list_free(gp);

  gp = sc->vectors;
  for (s7_int i = 0; i < gp->loc; i++)
    if (block_index(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);

#if With_Gmp
  /* free lists */
  {bigint *p, *np; for (p = sc->bigints; p; p = np) {mpz_clear(p->n); np = p->nxt; free(p);}}
  {bigrat *p, *np; for (p = sc->bigrats; p; p = np) {mpq_clear(p->q); np = p->nxt; free(p);}}
  {bigflt *p, *np; for (p = sc->bigflts; p; p = np) {mpfr_clear(p->x); np = p->nxt; free(p);}}
  {bigcmp *p, *np; for (p = sc->bigcmps; p; p = np) {mpc_clear(p->z); np = p->nxt; free(p);}}

  gp = sc->big_integers;
  for (s7_int i = 0; i < gp->loc; i++) {bigint *p; p = big_integer_bgi(gp->list[i]); mpz_clear(p->n); free(p);}
  gc_list_free(gp);

  gp = sc->big_ratios;
  for (s7_int i = 0; i < gp->loc; i++) {bigrat *p; p = big_ratio_bgr(gp->list[i]); mpq_clear(p->q); free(p);}
  gc_list_free(gp);

  gp = sc->big_reals;
  for (s7_int i = 0; i < gp->loc; i++) {bigflt *p; p = big_real_bgf(gp->list[i]); mpfr_clear(p->x); free(p);}
  gc_list_free(gp);

  gp = sc->big_complexes;
  for (s7_int i = 0; i < gp->loc; i++) {bigcmp *p; p = big_complex_bgc(gp->list[i]); mpc_clear(p->z); free(p);}
  gc_list_free(gp);

  gp = sc->big_random_states;
  for (s7_int i = 0; i < gp->loc; i++) gmp_randclear(random_gmp_state(gp->list[i]));
  gc_list_free(gp);

  gmp_randclear(random_gmp_state(sc->default_random_state));

  /* temps */
  if (sc->ratloc) free_rat_locals(sc);
  mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
  mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
  mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL);
  mpc_clear(sc->mpc_1);
  mpc_clear(sc->mpc_2);
  /* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */
#endif

  free(undefined_name(sc->undefined));
  gp = sc->undefineds;
  for (s7_int i = 0; i < gp->loc; i++)
    free(undefined_name(gp->list[i]));
  gc_list_free(gp);

  gc_list_free(sc->gensyms);
  gc_list_free(sc->continuations);  /* stack is simple vector (handled above) */
  gc_list_free(sc->weak_refs);
  gc_list_free(sc->weak_hash_iterators);
  gc_list_free(sc->opt1_funcs);

  free(port_port(sc->standard_output));
  free(port_port(sc->standard_error));
  free(port_port(sc->standard_input));

  if (sc->autoload_names) free(sc->autoload_names);
  if (sc->autoload_names_sizes) free(sc->autoload_names_sizes);
  if (sc->autoloaded_already)
    {
      for (s7_int i = 0; i < sc->autoload_names_loc; i++)
	if (sc->autoloaded_already[i]) free(sc->autoloaded_already[i]);
      free(sc->autoloaded_already);
    }
  for (block_t *top = sc->block_lists[Top_Block_List]; top; top = block_next(top))
    if (block_data(top))
      free(block_data(top));

  big_block_free(sc, stack_block(sc->stack));
  big_block_free(sc, vector_block(sc->protected_objects));
  for (s7_int i = 0; i < sc->saved_pointers_loc; i++)
    free(sc->saved_pointers[i]);
  free(sc->saved_pointers);
  {
    gc_obj_t *gnxt;
    heap_block_t *hpnxt;
    for (gc_obj_t *g = sc->semipermanent_lets; g; g = gnxt)    {gnxt = g->nxt; free(g);}
    for (gc_obj_t *g = sc->semipermanent_objects; g; g = gnxt) {gnxt = g->nxt; free(g);}
    for (heap_block_t *hp = sc->heap_blocks; hp; hp = hpnxt) {hpnxt = hp->next; free(hp);}
  }

  free(sc->heap);
  free(sc->free_heap);
  free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */
  free(sc->symbol_table);
  free(sc->setters);
  free(sc->op_stack);
  if (sc->tree_pointers) free(sc->tree_pointers);
  free(sc->num_to_str);
  free(sc->protected_objects_free_list);
  if (sc->read_line_buf) free(sc->read_line_buf);
  free(sc->strbuf);
  free_shared_info(sc->circle_info);
  if (sc->file_names) free(sc->file_names);
  free(sc->unentry);
  free(sc->input_port_stack);
  if (sc->typnam) free(sc->typnam);

  for (s7_int i = 0; i <= 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;}
	  free(c_type);
	}
      free(sc->c_object_types);
    }
#if s7_Debugging || ((Disable_File_Output || Pointer_32) && (!WITH_GCC))
  if (sc == cur_sc) cur_sc = original_cur_sc;
#endif
  free(sc);
}


/* -------------------------------- repl -------------------------------- */
#ifndef USE_SND
  #define USE_SND 0
#endif
#ifndef WITH_MAIN
  #define WITH_MAIN 0
#endif

#if WITH_MAIN && With_Notcurses
  #include "nrepl.c"
  /* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWith_Notcurses -lnotcurses-core */
#else

static void dumb_repl(s7_scheme *sc)
{
  while (true)
    {
      #define Qst_Bufsize 512
      char buffer[Qst_Bufsize];
      fprintf(stdout, "\n> ");
      if (!fgets(buffer, Qst_Bufsize, stdin)) break;  /* error or ctrl-D */
      if (((buffer[0] != '\n') || (strlen(buffer) > 1)))
	{
	  #define Rsp_Bufsize 1024
	  char response[Rsp_Bufsize];
	  snprintf(response, Rsp_Bufsize, "(write %s)", buffer);
	  s7_eval_c_string(sc, response);
	}}
  fprintf(stdout, "\n");
  if (ferror(stdin))
    fprintf(stderr, "read error on stdin\n");
}

void s7_repl(s7_scheme *sc)
{
#if !With_C_Loader
  dumb_repl(sc);
#else
#if With_Notcurses
  s7_load(sc, "nrepl.scm");
#else
  /* try to get lib_s7.so from the repl's directory, and set *libc*.
   *   otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h
   */
#if With_System_Extras
  bool repl_loaded = false;
#endif
  const s7_pointer 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)
    {
      const s7_pointer libs = global_slot(sc->libraries_symbol);
      const 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 */
#else
  if (!val) /* s7_load was unable to find/load libc_s7.so */
    dumb_repl(sc);
  else
    {
#if s7_Debugging
      s7_autoload(sc, make_symbol(sc, "compare-calls", 13), s7_make_string(sc, "compare-calls.scm"));
      s7_autoload(sc, make_symbol(sc, "get-overheads", 13), s7_make_string(sc, "compare-calls.scm"));
#endif
      s7_provide(sc, "libc.scm");
      if (!repl_loaded) s7_load(sc, "repl.scm");
      s7_eval_c_string(sc, "((*repl* 'run))");
    }
#endif /* s7_Debugging */
#endif /* With_Notcurses */
#endif /* With_C_Loader */
}

#if WITH_MAIN && (!USE_SND)

#if (!MS_Windows) && With_C_Loader
static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */
{
  char *path;
  char *p;
  /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so
   *   directory, it fails (it tries to build the library but that requires s7.h and libc.scm).  So here we are trying to
   *   guess the libc_s7 directory from the command line program name.  This can't work in general, but it works often
   *   enough to be worth the effort.  If S7_LOAD_PATH is set, it is used instead.
   */
  if (!strchr(filename, '/'))
    return(NULL);

  if (!(path = realpath(filename, NULL))) /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */
    {
      fprintf(stderr, "%s: %s\n", strerror(errno), filename);
      exit(2);
    }
  if (!(p = strrchr(path, '/')))
    {
      free(path);
      fprintf(stderr, "please provide the full pathname for %s\n", filename);
      exit(2);
    }
  if (p > path) *p = '\0'; else p[1] = 0;
  return(path);
}
#endif

int main(int argc, char **argv)
{
  s7_scheme *sc = s7_init();
  fprintf(stderr, "s7: %s\n", S7_DATE);

  if (argc == 2)
    {
      fprintf(stderr, "load %s\n", argv[1]);
      if (!s7_load(sc, argv[1]))
	{
	  fprintf(stderr, "can't load %s\n", argv[1]);
	  return(2);
	}}
  else
    {
#if MS_Windows || (!With_C_Loader) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */
      dumb_repl(sc);
#else
  #ifdef S7_LOAD_PATH
      s7_add_to_load_path(sc, S7_LOAD_PATH);
  #else
      char *dir = realdir(argv[0]);
      if (dir)
	{
	  s7_add_to_load_path(sc, dir);
	  free(dir);
	}
  #endif
      s7_repl(sc);
#endif
    }
  return(0);
}

/* in Linux:  gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ; also need libc.scm cload.scm repl.scm to get a decent repl
 * in *BSD:   gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic
 * in OSX:    clang s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm
 * in msys2:  gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
 * for tcc:   tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic
 * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic
 * for repl:  gcc s7.c -o repl repl.c -Wl,-export-dynamic -lm -I. -ldl
 * for iOS, Swift, and clang: https://rodschmidt.com/posts/s7-scheme/
 * with gmp:  gcc s7.c -c -I. -O2 -DWITH_GMP=1, gcc -o repl repl.c s7.o -I. -lgmp -lmpfr -lmpc -lm -ldl -Wl,-export-dynamic
 *
 * (s7.c compile time 49 secs on x86 Linux, 16 secs on M4 OSX)
 * musl works, but there is some (musl-related) 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
 * 28-Jun-26: cloc blank 8723, comment 4217, code 91209, [gmp: ~5600, s7_debugging: ~2900 see search.scm] -> ca 82000 lines of code normally
 */
#endif
#endif

/* ------------------------------------------------------
 *             19.0   21.0   23.0   25.0   26.0   26.6
 * ------------------------------------------------------
 * tpeak        148    114    105    109    109    109
 * tref        1081    687    459    412    405    405
 * tlimit             5371   5371    783    778    776
 * index              1016    967    988    992    989
 * tmock              1145   1042   1031   1032   1030
 * tvect       3408   2464   1669   1457   1483   1480
 * thook       7651   ----   2030   1731   1696   1587
 * tauto                     2048   1760   1792   1793
 * texit                     3094   3093   1830   1836
 * lt          2222   2172   2185   1892   1895   1889
 * s7test             1831   1829   1849   1914   1915
 * dup                3788   2239   2012   1994   2057  2085
 * tread              2421   2408   2241   2255   2249
 * tcopy              5546   2375   2352   2330   2312
 * trclo       8248   2782   2634   2499   2430   2439
 * fbench      2933   2583   2430   2536   2532   2520
 * tmat               3042   2578   2522   2626   2625
 * tload                     2404   2506   2699   2703
 * tsort       3683   3104   2804   2858   2850   2847
 * titer       4910   3639   3252   3111          3062
 * tbit        3836   3305   3261   3181   3184   3095
 * tio                3752   3620   3127   3141   3098
 * tobj               3970   3577   3434   3459   3436
 * teq                4045   3486   3556   3552   3446
 * tmac               4373   4193   4024   3825   3709
 * tgc                4042   3666   3801          3712
 * tcomplex           3869   3844   4215   4194   3807
 * tmap               8774   4541   4380   4375   4285
 * tshoot             5447   5055   4833   4768   4335
 * tcase              4793   4430   4376   4385   4383
 * tlet        11.0   6974   5980   4470   4448   4441
 * tfft               7729   4476   4538   4550   4536
 * tstar              7121   5565   5237   5172   5042
 * concordance 10.0   6095   5165   5345   5433   5108
 * tnum               6013   5396   5402   5336   5156
 * tlist       9219   7546   6240   5770   5770   5700
 * tari        14.3   12.5   6662   6292   6032   5788
 * tleft       12.2   9753   7331   6393   6326   5823
 * trec        19.6   6980   6656   6015   5864   5846
 * tgsl               7802   6282   6208   6218   6222  6238 [p_p_ok p_ii_ok]
 * tset                      6260   6278   6302   6225
 * tmap-hash                        9765          6400
 * tmisc                     7614   7130   7007   6945
 * tclo               8025   8809   7627   7645   7522
 * tlamb                     8003   7920   7925   7587
 * tform                     9992   9626   9030   8998
 * thash              11.7   9479   9283   9191   9010
 * cb          12.9   11.0   9564   9657   9551   9390  9405 [p_ii_ok]
 * tgen               11.4   12.1   12.4   12.7   12.7
 * tall        15.9   15.6   15.6   15.1   15.1   15.1
 * timp               24.4   19.6   15.5   15.3   15.2
 * tmv                21.9   20.7   16.6   17.9   17.8
 * calls              37.5   37.5   37.1   38.2   38.0
 * sg                        55.8   55.3   56.2   56.1
 * tbig              175.8  148.1  145.5  145.2  144.5
 * ------------------------------------------------------
 *
 * get rid of nrepl-bits.h -- insert nrepl.scm into nrepl.c as r7rs.scm above, line 99767, then also remove make-nrepl-bits.scm
 *   [first try failed]
 * maybe add s7_wrap_complex|int?  It would be nice to have a way to piggy-back on choosers like multiply in FFI code (for wrapped values etc)
 *   FFI choosers as hooks? s7_set_chooser->s7_add_chooser+function list? this means every s7.c chooser has to check a hook list (passing its current choice?)
 * why not add|subtract_wrapped for multiply? and cvref_p_pi_wrapped
 * #<do-unspecified> extended? close-*-port load? if/when/unless/cond/case/for-each/values
 * debugging names for all g/fx/opt funcs so s7 can print them (currently gdb is the only recourse)
 * check string_value(file) cases and s7test cases for rest of new expand_filename cases
 *
 * old, maybe someday:
 *   fx_chooser and its allies need to be regularized -- it can be hard to tell if something is passed through fx_chooser and the tree funcs.
 *   apparently in mpfr "p" exponent prefix is a special case for base 16 -- 1p2 is 4.0, but 1@2 is 256.0 and it's only defined for base 16?  Later...
 *   pcg random algorithm [64]
 *   gettext for errors?
 *   gmp ffi
 *   fx_chooser can't depend on is_defined_global because it sees args before possible local bindings, get rid of these if possible
 *   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?
 *   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 s7_cell func (ends with int32_t arity)
 *   immutable! + circular list + readable:
 *     (let ((<L1> (cons 1 (cons 2 (immutable! (cons 3 (cons 4 ()))))))) (set-cdr! (list-tail <L1> 3) <L1>) (display (object->string <L1> :readable)) (newline))
 *     "(let ((<1> (list 1 2 3 4))) (set-cdr! (list-tail <1> 3) <1>) <1>)" ; missing immutable!
 */
