/* s7, a Scheme interpreter
 *
 *    derived from:
 *
 * --------------------------------------------------------------------------------
 * T I N Y S C H E M E    1 . 3 9
 *   Dimitrios Souflis (dsouflis@acm.org)
 *   Based on MiniScheme (original credits follow)
 * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
 * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
 * (MINISCM) This version has been modified by R.C. Secrist.
 * (MINISCM)
 * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
 * (MINISCM)
 * (MINISCM) This is a revised and modified version by Akira KIDA.
 * (MINISCM)	current version is 0.85k4 (15 May 1994)
 *
 *
 * apparently tinyScheme is under the BSD license, so I guess s7 is too. 
 * Here is Snd's verbiage which can apply here:
 *
 *     The authors hereby grant permission to use, copy, modify, distribute,
 *     and license this software and its documentation for any purpose.  No
 *     written agreement, license, or royalty fee is required.  Modifications
 *     to this software may be copyrighted by their authors and need not
 *     follow the licensing terms described here.
 *
 * followed by the usual all-caps shouting about liability.
 * --------------------------------------------------------------------------------
 *
 *
 *
 * s7, Bill Schottstaedt, Aug-08
 *
 *   changes from tinyScheme:
 *        just two files: s7.c and s7.h, source-level embeddable (no library, no run-time init files)
 *        full continuations, call-with-exit for goto or return, dynamic-wind
 *        ratios and complex numbers (and ints are 64-bit by default)
 *          optional multiprecision arithmetic for all numeric types and functions
 *        generalized set!, procedure-setter, applicable objects
 *        defmacro and define-macro
 *        define*, lambda*, named let*
 *        keywords, hash tables, block comments
 *        format
 *        error handling using error and catch
 *        no invidious distinction between built-in and "foreign"
 *          (this makes it easy to extend built-in operators like "+" -- see s7.html for a simple example)
 *        lists, strings, vectors, hash-tables, and environments are (set-)applicable objects
 *        true multiple-values
 *        multidimensional vectors
 *        hooks (conditions)
 *
 *   differences from r5rs:
 *        no syntax-rules or any of its friends
 *        no force or delay
 *        no inexact integer or ratio (so, for example, truncate returns an exact integer), no exact complex or exact real
 *           (exact? has no obvious meaning in regard to complex numbers anyway -- are we referring to the polar or
 *            the rectangular form, and are both real and imaginary parts included? -- why can't they be separate?)
 *           In s7, exact? is a synonym for rational?, inexact->exact is a synonym for rationalize.
 *        '#' does not stand for an unknown digit, and the '@' complex number notation is ignored
 *           I also choose not to include numbers such as +i (= 0+i) -- include the real part!
 *        modulo, remainder, and quotient take integer, ratio, or real args 
 *        lcm and gcd can take integer or ratio args
 *        continuation? function to distinguish a continuation from a procedure
 *        log takes an optional second arg (base)
 *        '.' and an exponent can occur in a number in any base -- they do not mean "base 10"!  
 *           However, the exponent itself is always in base 10 (this follows gmp usage).
 *
 *   other additions: 
 *        random for any numeric type and any numeric argument, including 0 ferchrissake!
 *        sinh, cosh, tanh, asinh, acosh, atanh
 *        read-line, read-byte, write-byte, *stdin*, *stdout*, and *stderr*
 *        logior, logxor, logand, lognot, logbit?, ash, integer-length
 *        integer-decode-float, nan?, infinite?
 *        procedure-source, procedure-arity, procedure-documentation, procedure-name, help
 *          if the initial expression in a function body is a string constant, it is assumed to be a documentation string
 *        symbol-table, symbol->value
 *        global-environment, current-environment, procedure-environment, initial-environment, environment?
 *        provide, provided?, defined?
 *        port-line-number, port-filename
 *        object->string, eval-string
 *        reverse!, list-set!, sort!, make-list
 *        gc, *load-hook*, *error-hook*, (error-environment), *unbound-variable-hook*
 *        *features*, *load-path*, *vector-print-length*, *#readers*
 *        define-constant, pi, most-positive-fixnum, most-negative-fixnum, constant?
 *        length, copy, fill!, reverse, map, for-each are generic
 *        symbol-access modifies symbol value lookup
 *        member and assoc accept an optional third argument, the comparison function
 *        morally-equal?
 *        unicode (utf8)
 *
 *
 * Mike Scholz provided the FreeBSD support (complex trig funcs, etc)
 * Rick Taube and Andrew Burnson provided the MS Visual C++ support
 *
 * Documentation is in s7.h and s7.html.  
 * s7test.scm is a regression test.
 * glistener.c is a 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 currrenly has pretty-print and other half-written stuff.
 * s7.c has more than 115000 e's!
 *
 * 
 *
 * ---------------- compile time switches ---------------- 
 */

#include <mus-config.h>

/* 
 * 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. On a Mac, or in Linux, if you're not using C++,
 *   I use:
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 1
 *
 *   In C++ I use:
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 0
 *
 *   In windows, 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 or undefined, 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 will not signal an error).
 *
 *
 * To get multiprecision arithmetic, set WITH_GMP to 1.
 *   You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later)
 *
 * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included.
 *
 * so the incoming (non-s7-specific) compile-time switches are
 *     HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P
 *
 * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __bfin__, __ANDROID__,
 *     __OpenBSD__
 *
 * 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.
 *
 * The __bfin__ switch refers to the Blackfin processor where int accesses must be 4-byte aligned.
 *   I can't find any built-in compiler switch to detect this case. (gcc has __alignof__(int) I think).
 *   Currently the unaligned access code is turned off, so this switch can be ignored.
 *
 * in openBSD I think you need to include -ftrampolines in CFLAGS.
 *
 * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN (this assumes access to readline)
 *   then load it with -lreadline -ldl -lm, etc.
 */


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

#ifndef INITIAL_HEAP_SIZE
#define INITIAL_HEAP_SIZE 128000
/* the heap grows as needed, this is its initial size. 
 * If the initial heap is small, s7 can run in less than 2 Mbytes of memory. There are cases where a bigger heap is faster.
 * As of 5-May-2011, the heap size must be a multiple of 32.  Each object takes about 60 bytes (48 + 8?) so this represents 6 Mbytes?
 */
#endif

#define SYMBOL_TABLE_SIZE 19259
/* names are hashed into the symbol table (a vector) and collisions are chained as lists. 
 */

#define INITIAL_STACK_SIZE 512
/* the stack grows as needed, each frame takes 4 entries, this is its initial size.
 *   this needs to be big enough to handle the eval_c_string's at startup (ca 100) 
 *   In s7test.scm, the maximum stack size is ca 440.  In snd-test.scm, it's ca 200.
 *   This number matters only because call/cc copies the stack, which requires filling
 *   the unused portion of the new stack, which requires memcpy of #<unspecified>'s.
 */

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

#define GC_TEMPS_SIZE 256
/* 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. 
 */


#define WITH_GCC (defined(__GNUC__) || defined(__clang__))


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

#ifndef WITH_GMP
  #define WITH_GMP 0
  /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc
   * WITH_GMP adds the following functions: bignum, bignum?, bignum-precision
   * using gmp with precision=128 is about 3 times slower than using C doubles and long long ints.
   */
#endif

#if WITH_GMP
  #define DEFAULT_BIGNUM_PRECISION 128
#endif

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

#ifndef WITH_AT_SIGN_AS_EXPONENT
  #define WITH_AT_SIGN_AS_EXPONENT 1
  /* for bases 15 and 16, 'e' is a digit, so to get exponents in those bases (and actually
   *    any greater than 10), we need a different exponent marker.  This makes '@' an exponent marker.
   */
#endif

#ifndef WITH_SYSTEM_EXTRAS
  #define WITH_SYSTEM_EXTRAS (!_MSC_VER)
  /* this adds several functions that access file info, directories, times, etc
   *    this may be replaced by the cload business below
   */
#endif

#ifndef WITH_C_LOADER
  #define WITH_C_LOADER WITH_GCC
  /* (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.
   */
#endif


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

#ifndef WITH_QUASIQUOTE_VECTOR
  #define WITH_QUASIQUOTE_VECTOR 1
  /* this determines whether we include support for quasiquoted vector constants `#(...) */
#endif


/* we could add WITH_PURE_S7 or something like that to get rid of remaining bad ideas:
 *      inexact/exact and #i #e
 *      `#() special cases (on the switch WITH_QUASIQUOTE_VECTOR)
 *      call-with-values etc
 *      char-ready? and eof-object? [s7-slib-init.scm currently says we have char-ready? otherwise only occurs in s7test.scm]
 *      dfls exponents (WITH_EXTRA_EXPONENT_MARKERS currently)
 *      unquote (on the switch WITH_IMMUTABLE_UNQUOTE currently)
 */


#ifndef DEBUGGING
  #define DEBUGGING 0
#endif

#define BOLD_TEXT "\033[1m"
#define UNBOLD_TEXT "\033[22m"
#define RED_TEXT "\033[31m"
#define NORMAL_TEXT "\033[0m"




/* -------------------------------------------------------------------------------- */

/* s7.c is organized as follows:
 *
 *    structs and type flags
 *    constants
 *    GC
 *    stacks
 *    symbols
 *    environments
 *    keywords
 *    continuations
 *    numbers
 *    characters
 *    strings
 *    ports
 *    format
 *    system extras
 *    lists
 *    vectors and hash-tables
 *    c-objects and functions
 *    eq?
 *    generic length, copy, reverse, fill!
 *    error handlers
 *    sundry leftovers
 *    multiple-values, quasiquote
 *    eval
 *    multiprecision arithmetic
 *    initialization
 *    repl
 *
 * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible (FFI), H_* are documentation strings,
 *   *_1 are auxilliary functions, big_* refer to gmp and friends, scheme "?" corresponds to C "_is_", scheme "->" to C "_to_".
 */

#if __cplusplus
  #ifndef HAVE_COMPLEX_NUMBERS
    #define HAVE_COMPLEX_NUMBERS 1
  #endif
  #ifndef HAVE_COMPLEX_TRIG
    #define HAVE_COMPLEX_TRIG 0
  #endif
#endif


#ifndef _MSC_VER
  #include <unistd.h>
  #include <sys/param.h> 
  #include <strings.h>
  #include <errno.h>
#else
  #include <io.h>
  #pragma warning(disable: 4244)
#endif
#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>

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

#if HAVE_COMPLEX_NUMBERS
  #if __cplusplus
    #include <complex>
  #else
    #include <complex.h>
    #if defined(__sun) && defined(__SVR4)
      #undef _Complex_I
      #define _Complex_I 1.0fi
    #endif
  #endif
#endif

#include <setjmp.h>

#include "s7.h"

#ifndef M_PI
  #define M_PI 3.1415926535897932384626433832795029L
#endif

#ifndef INFINITY
  #define INFINITY (-log(0.0))
#endif

#ifndef NAN
  #define NAN (INFINITY / INFINITY)
#endif

#define WRITE_REAL_PRECISION 16


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

#define DISPLAY(Obj) s7_object_to_c_string(sc, Obj)
#define DISPLAY_80(Obj) object_to_truncated_string(sc, Obj, 80)

enum {OP_NO_OP, 
      OP_READ_INTERNAL, OP_EVAL, 
      OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5,
      OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, 
      OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN1, OP_IF, OP_IF1, OP_SET, OP_SET1, OP_SET2,
      OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2,
      OP_LETREC, OP_LETREC1, OP_COND, OP_COND1, OP_COND_SIMPLE, OP_COND1_SIMPLE,
      OP_AND, OP_AND1, OP_OR, OP_OR1, OP_DEFMACRO, OP_DEFMACRO_STAR,
      OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION,
      OP_CASE, OP_CASE1, OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE, 
      OP_READ_QUASIQUOTE, OP_READ_QUASIQUOTE_VECTOR, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES,
      OP_READ_VECTOR, OP_READ_BYTEVECTOR, OP_READ_DONE, 
      OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_STRING, OP_EVAL_DONE,
      OP_CATCH, OP_DYNAMIC_WIND, 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_ENV, OP_WITH_ENV1, OP_WITH_ENV_UNCHECKED, OP_WITH_ENV_S, 
      OP_WITH_BAFFLE, OP_EXPANSION,
      OP_FOR_EACH, OP_FOR_EACH_SIMPLE, OP_FOR_EACH_SIMPLER, OP_FOR_EACH_SIMPLEST,
      OP_MAP, OP_MAP_SIMPLE, OP_BARRIER, OP_DEACTIVATE_GOTO,

      OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, 
      OP_GET_OUTPUT_STRING, OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT4, OP_SORT_TWO, 
      OP_EVAL_STRING_1, OP_EVAL_STRING_2, 
      OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1,
      
      OP_QUOTE_UNCHECKED, OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CASE_UNCHECKED, 
      OP_SET_UNCHECKED, OP_SET_SYMBOL_C, OP_SET_SYMBOL_S, OP_SET_SYMBOL_Q, OP_SET_SYMBOL_P, OP_SET_SYMBOL_Z, OP_SET_SYMBOL_ALL_X,
      OP_SET_SYMBOL_SAFE_S, OP_SET_SYMBOL_SAFE_C, 
      OP_SET_SYMBOL_SAFE_SS, OP_SET_SYMBOL_SAFE_SSS, OP_SET_SYMBOL_SAFE_opSSq_S,
      OP_SET_NORMAL, OP_SET_PAIR, OP_SET_PAIR_Z, OP_SET_PAIR_A, OP_SET_PAIR_P, 
      OP_SET_PAIR_P_1, OP_SET_WITH_ACCESSOR, OP_SET_PWS, OP_SET_ENV_S, OP_SET_ENV_ALL_X,
      OP_SET_PAIR_C, OP_SET_PAIR_C_P, OP_SET_PAIR_C_P_1, OP_SET_SAFE,
      OP_LET_STAR_UNCHECKED, OP_LETREC_UNCHECKED, OP_COND_UNCHECKED,
      OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED,
      OP_DEFINE_WITH_ACCESSOR, OP_DEFMACRO_WITH_ACCESSOR, OP_DEFINE_MACRO_WITH_ACCESSOR,
      OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_STAR,
      OP_CASE_SIMPLE, OP_CASE_SIMPLER, OP_CASE_SIMPLER_1, OP_CASE_SIMPLER_SS,
      OP_CASE_SIMPLEST, OP_CASE_SIMPLEST_SS, OP_CASE_SIMPLEST_ELSE, OP_CASE_SIMPLEST_ELSE_C,
      OP_LET_C, OP_LET_S, OP_LET_Q, OP_LET_ALL_C, OP_LET_ALL_S, OP_LET_ALL_X,
      OP_LET_STAR_ALL_X, OP_LET_opCq, OP_LET_opSSq, OP_LET_C_P, OP_LET_S_P, 
      OP_IF_P_P_P, OP_IF_P_P, OP_IF_P_P_X, OP_IF_P_X_P, OP_IF_P_X_X, 
      OP_IF_B_P, OP_IF_B_P_P, OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ORP_P, OP_IF_ORP_P_P, 
      OP_IF_PPP, OP_IF_PP, OP_IF_PPX, OP_IF_PXP, OP_IF_PXX, 
      OP_IF_S_P_P, OP_IF_S_P, OP_IF_S_P_X, OP_IF_S_X_P, 
      OP_AND_UNCHECKED, OP_AND_P, OP_AND_P1, OP_OR_UNCHECKED, OP_OR_P, OP_OR_P1,
      
      OP_SAFE_IF_Z_Z, 
      OP_CATCH_1, OP_CATCH_ALL, OP_COND_ALL_X,
      OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_P, OP_SAFE_DOTIMES_STEP_O, OP_SAFE_DOTIMES_STEP_A,
      OP_SIMPLE_SAFE_DOTIMES, OP_SAFE_DO, OP_SAFE_DO_STEP, OP_SAFE_DOTIMES_C_C,
      OP_SIMPLE_DO_P, OP_SIMPLE_DO_STEP_P, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_P, OP_SIMPLE_DO_FOREVER,
      OP_DOTIMES_P, OP_DOTIMES_STEP_P, OP_SAFE_DOTIMES_C_A,
      OP_SIMPLE_DO_A, OP_SIMPLE_DO_STEP_A,
      OP_SAFE_IF_Z_Z_1, OP_SAFE_IF_CC_X_P, OP_SAFE_IF_CC_P_P, 
      OP_SAFE_IF_CS_P_P, OP_SAFE_IF_CS_X_P, OP_SAFE_IF_IS_NULL_S_P, OP_SAFE_IF_CC_P, OP_SAFE_IF_CS_P, OP_SAFE_IF_CS_P_X, OP_SAFE_IF_IS_NULL_Q_P,
      OP_SAFE_IF_CSS_X_P, OP_SAFE_IF_CSC_X_P, OP_SAFE_IF_CSC_X_O_A,
      OP_SAFE_IF_CSQ_P, OP_SAFE_IF_CSQ_P_P, OP_SAFE_IF_CSS_P, OP_SAFE_IF_CSS_P_P, OP_SAFE_IF_CSC_P, OP_SAFE_IF_CSC_P_P, 
      OP_SAFE_IF_IS_PAIR_P, OP_SAFE_IF_IS_PAIR_P_X, OP_SAFE_IF_IS_PAIR_P_P, OP_SAFE_IF_C_SS_P,
      OP_SAFE_IF_IS_SYMBOL_P, OP_SAFE_IF_IS_SYMBOL_P_P, 
      OP_IF_Z_P, OP_IF_Z_P_P, OP_IF_A_P, OP_IF_A_P_P, OP_IF_GT_P,
      OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_2, OP_SAFE_C_PP_3, OP_SAFE_C_PP_4, OP_SAFE_C_PP_5, OP_SAFE_C_PP_6, 
      OP_EVAL_ARGS_P_1, OP_EVAL_ARGS_P_1_MV, OP_EVAL_ARGS_P_2, OP_EVAL_ARGS_P_2_MV, 
      OP_EVAL_ARGS_P_3, OP_EVAL_ARGS_P_4, OP_EVAL_ARGS_P_3_MV, OP_EVAL_ARGS_P_4_MV, 
      OP_EVAL_ARGS_SSP_1, OP_EVAL_ARGS_SSP_MV, 
      OP_INCREMENT_1, OP_DECREMENT_1, OP_SET_CDR, OP_SET_CONS, 
      OP_INCREMENT_SS, OP_INCREMENT_SSS, OP_INCREMENT_S_opCq, OP_INCREMENT_SZ, OP_INCREMENT_C_TEMP,
      OP_LET_O, OP_LET_O1, OP_LET_R, OP_LET_ALL_R, OP_LET_C_D, OP_LET_O_P, OP_LET_Z_P, OP_LET_O2, OP_LET_O_O, OP_LET_Z_O, OP_LET_O3, 
      OP_LET_R_P, OP_LET_CAR_P,

      OP_SAFE_C_ZZ_1, OP_SAFE_C_ZZ_2, OP_SAFE_C_SZ_1, OP_SAFE_C_ZS_1, OP_SAFE_C_ZA_1, OP_INCREMENT_SZ_1, OP_SAFE_C_SZ_SZ,
      OP_SAFE_C_ZAA_1, OP_SAFE_C_AZA_1, OP_SAFE_C_AAZ_1, OP_SAFE_C_SSZ_1, 
      OP_SAFE_C_ZZA_1, OP_SAFE_C_ZZA_2, OP_SAFE_C_ZAZ_1, OP_SAFE_C_ZAZ_2, OP_SAFE_C_AZZ_1, OP_SAFE_C_AZZ_2, 
      OP_SAFE_C_ZZZ_1, OP_SAFE_C_ZZZ_2, OP_SAFE_C_ZZZ_3, 
      OP_SAFE_C_ZZZZ_1, OP_SAFE_C_ZZZZ_2, OP_SAFE_C_ZZZZ_3, OP_SAFE_C_ZZZZ_4, 

      OP_SAFE_C_opSq_P_1, OP_SAFE_C_opSq_P_MV, OP_C_P_1, OP_C_P_2, OP_C_SP_1, OP_C_SP_2,

      OP_MAX_DEFINED_1};

#define OP_MAX_DEFINED (OP_MAX_DEFINED_1 + 1)
#define is_internal_syntax_op(op) (op >= OP_QUOTE_UNCHECKED)

#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)))
  #define opcode_t unsigned int
  #define PRINT_NAME_PADDING 8
  #define PRINT_NAME_SIZE (20 - PRINT_NAME_PADDING - 2)
#else
  #define opcode_t unsigned long long int
  #define PRINT_NAME_PADDING 16
  #define PRINT_NAME_SIZE (40 - PRINT_NAME_PADDING - 2)
#endif
/* ideally we'd use (2 * max(sizeof(s7_Int), sizeof(s7_Double))) for the padding,
 *   but I can't think of a way to do this short of a configuration script.
 *   If someone defines s7_Double to be long long double, we're in trouble.
 */


/* these names are intended for error messages (eval_error_with_name) and debugging.  
 */
static const char *op_names[OP_MAX_DEFINED + 1] = 
  {"no-op", 
   "read-internal", "eval", 
   "eval-args", "eval-args1", "eval-args2", "eval-args3", "eval-args4", "eval-args5",
   "apply", "eval-macro", "lambda", "quote", 
   "define", "define", "begin", "begin", "if", "if", "set!", "set!", "set!", 
   "let", "let", "let*", "let*", "let*",
   "letrec", "letrec", "cond", "cond", "cond", "cond",
   "and", "and", "or", "or", "defmacro", "defmacro*",
   "define-macro", "define-macro*", "define-expansion",
   "case", "case", "read-list", "read-list", "read-dot", "read-quote", 
   "read-quasiquote", "read-quasiquote-vector", "read-unquote", "read-apply-values",
   "read-vector", "read-bytevector", "read-done", 
   "load", "load", "eval-string", "eval",
   "catch", "dynamic-wind", "define-constant", "define-constant", 
   "do", "do", "do", "do", "do", "do",
   "define*", "lambda*", "lambda*", "error-quit", "unwind-input", "unwind-output", 
   "error-hook-quit", "with-environment", "with-environment", "with-environment", "with-environment", 
   "with-baffle", "define-expansion",
   "for-each", "for-each", "for-each", "for-each",
   "map", "map", "barrier", "deactivate-goto",
   "define-bacro", "define-bacro*", 
   "get-output-string", "sort!", "sort!", "sort!", "sort!", "sort!", "sort!", 
   "eval-string", "eval-string", 
   "member", "assoc", "member", "assoc",
   
   "quote", "lambda", "let", "case", 
   "set!", "set!", "set!", "set!", "set!", "set!", "set!", "set!",
   "set!", "set!", "set!", "set!", "set!", "set!", "set!", "set!",
   "set!", "set!", "set!", "set!", "set!", "set!", "set!", "set!", "set!", "set!",
   "let*", "letrec", "cond",
   "lambda*", "do", "define", "define*", "define",
   "define", "defmacro", "define-macro",
   "let", "let", "let", "let*",
   "case", "case", "case", "case",
   "case", "case", "case", "case", 
   "let", "let", "let", "let", "let", "let", 
   "let*", "let", "let", "let", "let",

   "if", "if", "if", "if", "if", 
   "if", "if", "if", "if", "if", "if", 
   "if", "if", "if", "if", "if", 
   "if", "if", "if", "if",

   "and", "and", "and", "or", "or", "or", 

   "if", 
   "catch", "catch", "cond",
   "do", "do", "do", "do", "do", 
   "do", "do", "do", "do", "do", "do",
   "do", "do", "do", "do", "do",
   "do", "do", "do",
   "do", "do", "do",
   "if", "if", "if", 
   "if", "if", "if", "if", "if", "if",
   "if", "if", "if",
   "if", "if", "if", "if", "if", "if", "if",
   "if", "if", "if", "if",
   "if", "if", "if", "if", "if", "if", "if",
   "c_p_1", "c_pp_1", "c_pp_2", "c_pp_3", "c_pp_4", "c_pp_5", "c_pp_6", 
   "eval_args_p_1", "eval_args_p_1_mv", "eval_args_p_2", "eval_args_p_2_mv", 
   "eval_args_p_3", "eval_args_p_4", "eval_args_p_3_mv", "eval_args_p_4_mv", 
   "eval_args_ssp_1", "eval_args_ssp_mv", 
   "increment_1", "decrement_1", "set_cdr", "set_cons", 
   "increment_ss", "increment_sss", "increment_s_opcq", "increment_sz", "increment_c_temp",
   "let", "let", "let", "let", "let", "let", "let", "let", "let", "let", "let", 
   "let", "let", 

   "c_zz_1", "c_zz_2", "c_sz_1", "c_zs_1", "c_za_1", "increment_sz_1", "c_sz_sz",
   "c_zaa_1", "c_aza_1", "c_aaz_1", "c_ssz_1", 
   "c_zza_1", "c_zza_2", "c_zaz_1", "c_zaz_2", "c_azz_1", "c_azz_2", 
   "c_zzz_1", "c_zzz_2", "c_zzz_3", "zzzz_1", "zzzz_2", "zzzz_3", "zzzz_4",

   "c_opsq_p_1", "c_opsq_p_mv", "c_p_1", "c_p_2", "c_sp_1", "c_sp_2",
   
   "op-max"
  };


/* these are just for debugging but it's annoying to keep setting the DEBUGGING switch */
static const char *real_op_names[OP_MAX_DEFINED + 1] = {
  "OP_NO_OP", 
  "OP_READ_INTERNAL", "OP_EVAL", 
  "OP_EVAL_ARGS", "OP_EVAL_ARGS1", "OP_EVAL_ARGS2", "OP_EVAL_ARGS3", "OP_EVAL_ARGS4", "OP_EVAL_ARGS5",
  "OP_APPLY", "OP_EVAL_MACRO", "OP_LAMBDA", "OP_QUOTE", 
  "OP_DEFINE", "OP_DEFINE1", "OP_BEGIN", "OP_BEGIN1", "OP_IF", "OP_IF1", "OP_SET", "OP_SET1", "OP_SET2",
  "OP_LET", "OP_LET1", "OP_LET_STAR", "OP_LET_STAR1", "OP_LET_STAR2", 
  "OP_LETREC", "OP_LETREC1", "OP_COND", "OP_COND1", "OP_COND_SIMPLE", "OP_COND1_SIMPLE",
  "OP_AND", "OP_AND1", "OP_OR", "OP_OR1", "OP_DEFMACRO", "OP_DEFMACRO_STAR",
  "OP_DEFINE_MACRO", "OP_DEFINE_MACRO_STAR", "OP_DEFINE_EXPANSION",
  "OP_CASE", "OP_CASE1", "OP_READ_LIST", "OP_READ_NEXT", "OP_READ_DOT", "OP_READ_QUOTE", 
  "OP_READ_QUASIQUOTE", "OP_READ_QUASIQUOTE_VECTOR", "OP_READ_UNQUOTE", "OP_READ_APPLY_VALUES",
  "OP_READ_VECTOR", "OP_READ_BYTEVECTOR", "OP_READ_DONE", 
  "OP_LOAD_RETURN_IF_EOF", "OP_LOAD_CLOSE_AND_POP_IF_EOF", "OP_EVAL_STRING", "OP_EVAL_DONE",
  "OP_CATCH", "OP_DYNAMIC_WIND", "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_ENV", "OP_WITH_ENV1", "OP_WITH_ENV_UNCHECKED", "OP_WITH_ENV_S", 
  "OP_WITH_BAFFLE", "OP_EXPANSION",
  "OP_FOR_EACH", "OP_FOR_EACH_SIMPLE", "OP_FOR_EACH_SIMPLER", "OP_FOR_EACH_SIMPLEST",
  "OP_MAP", "OP_MAP_SIMPLE", "OP_BARRIER", "OP_DEACTIVATE_GOTO",
  
  "OP_DEFINE_BACRO", "OP_DEFINE_BACRO_STAR", 
  "OP_GET_OUTPUT_STRING", "OP_SORT", "OP_SORT1", "OP_SORT2", "OP_SORT3", "OP_SORT4", "OP_SORT_TWO", 
  "OP_EVAL_STRING_1", "OP_EVAL_STRING_2", 
  "OP_MEMBER_IF", "OP_ASSOC_IF", "OP_MEMBER_IF1", "OP_ASSOC_IF1",
  
  "OP_QUOTE_UNCHECKED", "OP_LAMBDA_UNCHECKED", "OP_LET_UNCHECKED", "OP_CASE_UNCHECKED", 
  "OP_SET_UNCHECKED", "OP_SET_SYMBOL_C", "OP_SET_SYMBOL_S", "OP_SET_SYMBOL_Q", "OP_SET_SYMBOL_P", "OP_SET_SYMBOL_Z", "OP_SET_SYMBOL_ALL_X",
  "OP_SET_SYMBOL_SAFE_S", "OP_SET_SYMBOL_SAFE_C", 
  "OP_SET_SYMBOL_SAFE_SS", "OP_SET_SYMBOL_SAFE_SSS", "OP_SET_SYMBOL_SAFE_opSSq_S", 
  "OP_SET_NORMAL", "OP_SET_PAIR", "OP_SET_PAIR_Z", "OP_SET_PAIR_A", "OP_SET_PAIR_P", 
  "OP_SET_PAIR_P_1", "OP_SET_WITH_ACCESSOR", "OP_SET_PWS", "OP_SET_ENV_S", "OP_SET_ENV_ALL_X",
  "OP_SET_PAIR_C", "OP_SET_PAIR_C_P", "OP_SET_PAIR_C_P_1", "OP_SET_SAFE",
  "OP_LET_STAR_UNCHECKED", "OP_LETREC_UNCHECKED", "OP_COND_UNCHECKED",
  "OP_LAMBDA_STAR_UNCHECKED", "OP_DO_UNCHECKED", "OP_DEFINE_UNCHECKED", "OP_DEFINE_STAR_UNCHECKED", "OP_DEFINE_FUNCHECKED",
  "OP_DEFINE_WITH_ACCESSOR", "OP_DEFMACRO_WITH_ACCESSOR", "OP_DEFINE_MACRO_WITH_ACCESSOR",
  "OP_LET_NO_VARS", "OP_NAMED_LET", "OP_NAMED_LET_NO_VARS", "OP_NAMED_LET_STAR",
  "OP_CASE_SIMPLE", "OP_CASE_SIMPLER", "OP_CASE_SIMPLER_1", "OP_CASE_SIMPLER_SS",
  "OP_CASE_SIMPLEST", "OP_CASE_SIMPLEST_SS", "OP_CASE_SIMPLEST_ELSE", "OP_CASE_SIMPLEST_ELSE_C",
  "OP_LET_C", "OP_LET_S", "OP_LET_Q", "OP_LET_ALL_C", "OP_LET_ALL_S", "OP_LET_ALL_X", 
  "OP_LET_STAR_ALL_X", "OP_LET_opCq", "OP_LET_opSSq", "OP_LET_C_P", "OP_LET_S_P", 
  "OP_IF_P_P_P", "OP_IF_P_P", "OP_IF_P_P_X", "OP_IF_P_X_P", "OP_IF_P_X_X", 
  "OP_IF_B_P", "OP_IF_B_P_P", "OP_IF_ANDP_P", "OP_IF_ANDP_P_P", "OP_IF_ORP_P", "OP_IF_ORP_P_P", 
  "OP_IF_PPP", "OP_IF_PP", "OP_IF_PPX", "OP_IF_PXP", "OP_IF_PXX", 
  "OP_IF_S_P_P", "OP_IF_S_P", "OP_IF_S_P_X", "OP_IF_S_X_P", 
  "OP_AND_UNCHECKED", "OP_AND_P", "OP_AND_P1", "OP_OR_UNCHECKED", "OP_OR_P", "OP_OR_P1",
  
  "OP_SAFE_IF_Z_Z", 
  "OP_CATCH_1", "OP_CATCH_ALL", "OP_COND_ALL_X",
  "OP_SIMPLE_DO", "OP_SIMPLE_DO_STEP", "OP_SAFE_DOTIMES", "OP_SAFE_DOTIMES_STEP", "OP_SAFE_DOTIMES_STEP_P", "OP_SAFE_DOTIMES_STEP_O", "OP_SAFE_DOTIMES_STEP_A",
  "OP_SIMPLE_SAFE_DOTIMES", "OP_SAFE_DO", "OP_SAFE_DO_STEP", "OP_SAFE_DOTIMES_C_C",
  "OP_SIMPLE_DO_P", "OP_SIMPLE_DO_STEP_P", "OP_DOX", "OP_DOX_STEP", "OP_DOX_STEP_P", "OP_SIMPLE_DO_FOREVER",
  "OP_DOTIMES_P", "OP_DOTIMES_STEP_P", "OP_SAFE_DOTIMES_C_A",
  "OP_SIMPLE_DO_A", "OP_SIMPLE_DO_STEP_A",
  "OP_SAFE_IF_Z_Z_1", "OP_SAFE_IF_CC_X_P", "OP_SAFE_IF_CC_P_P", 
  "OP_SAFE_IF_CS_P_P", "OP_SAFE_IF_CS_X_P", "OP_SAFE_IF_IS_NULL_S_P", "OP_SAFE_IF_CC_P", "OP_SAFE_IF_CS_P", "OP_SAFE_IF_CS_P_X", "OP_SAFE_IF_IS_NULL_Q_P",
  "OP_SAFE_IF_CSS_X_P", "OP_SAFE_IF_CSC_X_P", "OP_SAFE_IF_CSC_X_O_A",
  "OP_SAFE_IF_CSQ_P", "OP_SAFE_IF_CSQ_P_P", "OP_SAFE_IF_CSS_P", "OP_SAFE_IF_CSS_P_P", "OP_SAFE_IF_CSC_P", "OP_SAFE_IF_CSC_P_P", 
  "OP_SAFE_IF_IS_PAIR_P", "OP_SAFE_IF_IS_PAIR_P_X", "OP_SAFE_IF_IS_PAIR_P_P", "OP_SAFE_IF_C_SS_P", 
  "OP_SAFE_IF_IS_SYMBOL_P", "OP_SAFE_IF_IS_SYMBOL_P_P", 
  "OP_IF_Z_P", "OP_IF_Z_P_P", "OP_IF_A_P", "OP_IF_A_P_P", "OP_IF_GT_P",
  "OP_SAFE_C_P_1", "OP_SAFE_C_PP_1", "OP_SAFE_C_PP_2", "OP_SAFE_C_PP_3", "OP_SAFE_C_PP_4", "OP_SAFE_C_PP_5", "OP_SAFE_C_PP_6", 
  "OP_EVAL_ARGS_P_1", "OP_EVAL_ARGS_P_1_MV", "OP_EVAL_ARGS_P_2", "OP_EVAL_ARGS_P_2_MV", 
  "OP_EVAL_ARGS_P_3", "OP_EVAL_ARGS_P_4", "OP_EVAL_ARGS_P_3_MV", "OP_EVAL_ARGS_P_4_MV", 
  "OP_EVAL_ARGS_SSP_1", "OP_EVAL_ARGS_SSP_MV", 
  "OP_INCREMENT_1", "OP_DECREMENT_1", "OP_SET_CDR", "OP_SET_CONS", 
  "OP_INCREMENT_SS", "OP_INCREMENT_SSS", "OP_INCREMENT_S_opCq", "OP_INCREMENT_SZ", "OP_INCREMENT_C_TEMP",
  "OP_LET_O", "OP_LET_O1", "OP_LET_R", "OP_LET_ALL_R", "OP_LET_C_D", "OP_LET_O_P", "OP_LET_Z_P", "OP_LET_O2", "OP_LET_O_O", "OP_LET_Z_O", "OP_LET_O3", 
  "OP_LET_R_P", "OP_LET_CAR_P",

  "OP_SAFE_C_ZZ_1", "OP_SAFE_C_ZZ_2", "OP_SAFE_C_SZ_1", "OP_SAFE_C_ZS_1", "OP_SAFE_C_ZA_1", "OP_INCREMENT_SZ_1", "OP_SAFE_C_SZ_SZ",
  "OP_SAFE_C_ZAA_1", "OP_SAFE_C_AZA_1", "OP_SAFE_C_AAZ_1", "OP_SAFE_C_SSZ_1", 
  "OP_SAFE_C_ZZA_1", "OP_SAFE_C_ZZA_2", "OP_SAFE_C_ZAZ_1", "OP_SAFE_C_ZAZ_2", "OP_SAFE_C_AZZ_1", "OP_SAFE_C_AZZ_2", 
  "OP_SAFE_C_ZZZ_1", "OP_SAFE_C_ZZZ_2", "OP_SAFE_C_ZZZ_3", 
  "OP_SAFE_C_ZZZZ_1", "OP_SAFE_C_ZZZZ_2", "OP_SAFE_C_ZZZZ_3", "OP_SAFE_C_ZZZZ_4", 

  "OP_SAFE_C_opSq_P_1", "OP_SAFE_C_opSq_P_MV", "OP_C_P_1", "OP_C_P_2", "OP_C_SP_1", "OP_C_SP_2",

  "OP_MAX_DEFINED_1"};


typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t;

enum {OP_NOT_AN_OP, HOP_NOT_AN_OP,
      OP_SAFE_C_C, HOP_SAFE_C_C, OP_SAFE_C_S, HOP_SAFE_C_S, OP_SAFE_CONS_SS, HOP_SAFE_CONS_SS,
      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_Q, HOP_SAFE_C_Q, OP_SAFE_C_SQ, HOP_SAFE_C_SQ, OP_SAFE_C_QS, HOP_SAFE_C_QS, OP_SAFE_C_QQ, HOP_SAFE_C_QQ, 
      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_ALL_S, HOP_SAFE_C_ALL_S, OP_SAFE_C_ALL_X, HOP_SAFE_C_ALL_X, OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_CSA, HOP_SAFE_C_CSA,
      OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_AAAA, HOP_SAFE_C_AAAA, 
      OP_SAFE_C_AZ, HOP_SAFE_C_AZ, OP_SAFE_C_ZA, HOP_SAFE_C_ZA, OP_SAFE_C_SQS, HOP_SAFE_C_SQS, 

      OP_SAFE_C_opCq, HOP_SAFE_C_opCq, OP_SAFE_C_opQq, HOP_SAFE_C_opQq, 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_opSQq, HOP_SAFE_C_opSQq, 
      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_C_opCSq, HOP_SAFE_C_C_opCSq, OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, 
      OP_SAFE_C_S_opCq, HOP_SAFE_C_S_opCq, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, 
      OP_SAFE_C_C_opCq, HOP_SAFE_C_C_opCq, OP_SAFE_C_opCq_S, HOP_SAFE_C_opCq_S, 
      OP_SAFE_C_opCq_opCq, HOP_SAFE_C_opCq_opCq, OP_SAFE_C_opCq_C, HOP_SAFE_C_opCq_C, 
      OP_SAFE_C_opSCq_opSCq, HOP_SAFE_C_opSCq_opSCq, OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, 
      OP_SAFE_C_opSSq_opCq, HOP_SAFE_C_opSSq_opCq, 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_opSCq_S, HOP_SAFE_C_opSCq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S,
      OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, OP_SAFE_C_opCq_opSSq, HOP_SAFE_C_opCq_opSSq, 
      OP_SAFE_C_S_op_opSSq_Sq, HOP_SAFE_C_S_op_opSSq_Sq, OP_SAFE_C_S_op_S_opSSqq, HOP_SAFE_C_S_op_S_opSSqq, 
      OP_SAFE_C_op_opSSq_q_C, HOP_SAFE_C_op_opSSq_q_C,
      
      OP_THUNK, HOP_THUNK, 
      OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_Sp, HOP_CLOSURE_Sp, OP_CLOSURE_C, HOP_CLOSURE_C, OP_CLOSURE_Q, HOP_CLOSURE_Q, 
      OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SSb, HOP_CLOSURE_SSb, OP_CLOSURE_SSp, HOP_CLOSURE_SSp, 
      OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_CS, HOP_CLOSURE_CS, 
      OP_CLOSURE_opSq, HOP_CLOSURE_opSq, OP_CLOSURE_opCq, HOP_CLOSURE_opCq, 
      OP_CLOSURE_opSq_S, HOP_CLOSURE_opSq_S, OP_CLOSURE_opSq_opSq, HOP_CLOSURE_opSq_opSq, 
      OP_CLOSURE_S_opSq, HOP_CLOSURE_S_opSq, OP_CLOSURE_S_opSSq, HOP_CLOSURE_S_opSSq, OP_CLOSURE_opSSq_S, HOP_CLOSURE_opSSq_S, 
      OP_CLOSURE_SSS, HOP_CLOSURE_SSS,
      OP_CLOSURE_ALL_C, HOP_CLOSURE_ALL_C, OP_CLOSURE_ALL_X, HOP_CLOSURE_ALL_X, 
      OP_CLOSURE_CDR_S, HOP_CLOSURE_CDR_S, OP_CLOSURE_ALL_S, HOP_CLOSURE_ALL_S, 

      OP_CLOSURE_STAR_S, HOP_CLOSURE_STAR_S, OP_CLOSURE_STAR_SX, HOP_CLOSURE_STAR_SX,
      OP_CLOSURE_STAR, HOP_CLOSURE_STAR, OP_CLOSURE_STAR_ALL_X, HOP_CLOSURE_STAR_ALL_X, 

      OP_SAFE_THUNK, HOP_SAFE_THUNK,
      OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_C, HOP_SAFE_CLOSURE_C, OP_SAFE_CLOSURE_Q, HOP_SAFE_CLOSURE_Q, 
      OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_CS, HOP_SAFE_CLOSURE_CS, 
      OP_SAFE_CLOSURE_opCq, HOP_SAFE_CLOSURE_opCq, OP_SAFE_CLOSURE_SA, HOP_SAFE_CLOSURE_SA, 
      OP_SAFE_CLOSURE_opSq, HOP_SAFE_CLOSURE_opSq, OP_SAFE_CLOSURE_opSq_S, HOP_SAFE_CLOSURE_opSq_S, OP_SAFE_CLOSURE_opSq_opSq, HOP_SAFE_CLOSURE_opSq_opSq, 
      OP_SAFE_CLOSURE_S_opSq, HOP_SAFE_CLOSURE_S_opSq, OP_SAFE_CLOSURE_S_opSSq, HOP_SAFE_CLOSURE_S_opSSq, OP_SAFE_CLOSURE_opSSq_S, HOP_SAFE_CLOSURE_opSSq_S, 
      OP_SAFE_CLOSURE_SSS, HOP_SAFE_CLOSURE_SSS, OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_S_CDR_CDR, HOP_SAFE_CLOSURE_S_CDR_CDR,
      OP_SAFE_CLOSURE_CAR_CAR, HOP_SAFE_CLOSURE_CAR_CAR, OP_SAFE_CLOSURE_CDR_CDR, HOP_SAFE_CLOSURE_CDR_CDR, 
      OP_SAFE_CLOSURE_ALL_C, HOP_SAFE_CLOSURE_ALL_C, OP_SAFE_CLOSURE_ALL_X, HOP_SAFE_CLOSURE_ALL_X, 
      OP_SAFE_CLOSURE_S_Z, HOP_SAFE_CLOSURE_S_Z, OP_SAFE_CLOSURE_S_P, HOP_SAFE_CLOSURE_S_P,

      OP_SAFE_CLOSURE_STAR_S, HOP_SAFE_CLOSURE_STAR_S, OP_SAFE_CLOSURE_STAR_SS, HOP_SAFE_CLOSURE_STAR_SS, 
      OP_SAFE_CLOSURE_STAR_SC, HOP_SAFE_CLOSURE_STAR_SC, OP_SAFE_CLOSURE_STAR_SA, HOP_SAFE_CLOSURE_STAR_SA, OP_SAFE_CLOSURE_STAR_S0, HOP_SAFE_CLOSURE_STAR_S0,
      OP_SAFE_CLOSURE_STAR, HOP_SAFE_CLOSURE_STAR, OP_SAFE_CLOSURE_STAR_ALL_X, HOP_SAFE_CLOSURE_STAR_ALL_X, 
      
      /* these can't be embedded, and have to be the last thing called */
      OP_APPLY_SS, HOP_APPLY_SS,
      OP_C_ALL_X, HOP_C_ALL_X, OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_C_CATCH, HOP_C_CATCH, OP_C_CATCH_ALL, HOP_C_CATCH_ALL,
      OP_C_S_opSq, HOP_C_S_opSq, OP_C_S_opCq, HOP_C_S_opCq, OP_C_QQ_1, HOP_C_QQ_1,
      OP_C_FOR_EACH_LS, HOP_C_FOR_EACH_LS, OP_C_FOR_EACH_LS_2, HOP_C_FOR_EACH_LS_2, OP_C_FOR_EACH_L_opSq, HOP_C_FOR_EACH_L_opSq, 
      OP_C_S, HOP_C_S, OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_SP, HOP_C_SP, OP_C_A, HOP_C_A,

      OP_GOTO, HOP_GOTO, OP_GOTO_C, HOP_GOTO_C, OP_GOTO_S, HOP_GOTO_S, 
      
      OP_VECTOR_C, HOP_VECTOR_C, OP_VECTOR_S, HOP_VECTOR_S, OP_VECTOR_opCq, HOP_VECTOR_opCq, 
      OP_STRING_C, HOP_STRING_C, OP_STRING_S, HOP_STRING_S, OP_STRING_opCq, HOP_STRING_opCq, 
      OP_C_OBJECT, HOP_C_OBJECT, OP_C_OBJECT_C, HOP_C_OBJECT_C, OP_C_OBJECT_S, HOP_C_OBJECT_S, 
        OP_C_OBJECT_opCq, HOP_C_OBJECT_opCq, OP_C_OBJECT_SS, HOP_C_OBJECT_SS, 
      OP_PAIR_C, HOP_PAIR_C, OP_PAIR_S, HOP_PAIR_S, OP_PAIR_opCq, HOP_PAIR_opCq, 
      OP_HASH_TABLE_C, HOP_HASH_TABLE_C, OP_HASH_TABLE_S, HOP_HASH_TABLE_S, 
      OP_ENVIRONMENT_S, HOP_ENVIRONMENT_S, OP_ENVIRONMENT_Q, HOP_ENVIRONMENT_Q, 
      
      OP_UNKNOWN, HOP_UNKNOWN, OP_UNKNOWN_C, HOP_UNKNOWN_C, OP_UNKNOWN_S, HOP_UNKNOWN_S, OP_UNKNOWN_Q, HOP_UNKNOWN_Q,
      OP_UNKNOWN_SS, HOP_UNKNOWN_SS, OP_UNKNOWN_SSS, HOP_UNKNOWN_SSS, OP_UNKNOWN_ALL_S, HOP_UNKNOWN_ALL_S, OP_UNKNOWN_ALL_X, HOP_UNKNOWN_ALL_X,
      OP_UNKNOWN_SC, HOP_UNKNOWN_SC, OP_UNKNOWN_CS, HOP_UNKNOWN_CS, OP_UNKNOWN_CC, HOP_UNKNOWN_CC, 
      OP_UNKNOWN_opSq, HOP_UNKNOWN_opSq, OP_UNKNOWN_opSq_S, HOP_UNKNOWN_opSq_S, OP_UNKNOWN_opSq_opSq, HOP_UNKNOWN_opSq_opSq,      
      OP_UNKNOWN_S_opSq, HOP_UNKNOWN_S_opSq, OP_UNKNOWN_S_opSSq, HOP_UNKNOWN_S_opSSq, OP_UNKNOWN_opSSq_S, HOP_UNKNOWN_opSSq_S, 
      OP_UNKNOWN_opCq, HOP_UNKNOWN_opCq, 

      OP_SAFE_C_P, HOP_SAFE_C_P, OP_SAFE_C_PP, HOP_SAFE_C_PP,
      OP_SAFE_C_opSq_P, HOP_SAFE_C_opSq_P, 
      OP_SAFE_C_SP, HOP_SAFE_C_SP, OP_SAFE_C_CP, HOP_SAFE_C_CP, OP_SAFE_C_QP, HOP_SAFE_C_QP, 
      OP_SAFE_C_PS, HOP_SAFE_C_PS, OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_PQ, HOP_SAFE_C_PQ,
      
      OP_SAFE_C_Z, HOP_SAFE_C_Z, OP_SAFE_C_ZZ, HOP_SAFE_C_ZZ, OP_SAFE_C_SZ, HOP_SAFE_C_SZ, OP_SAFE_C_ZS, HOP_SAFE_C_ZS, 
      OP_SAFE_C_CZ, HOP_SAFE_C_CZ, OP_SAFE_C_ZC, HOP_SAFE_C_ZC, OP_SAFE_C_QZ, HOP_SAFE_C_QZ, OP_SAFE_C_ZQ, HOP_SAFE_C_ZQ, 
      OP_SAFE_C_opCq_Z, HOP_SAFE_C_opCq_Z, OP_SAFE_C_S_opSZq, HOP_SAFE_C_S_opSZq, 
      OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, OP_SAFE_C_S_opAAAq, HOP_SAFE_C_S_opAAAq, 
      
      OP_SAFE_C_ZAA, HOP_SAFE_C_ZAA, OP_SAFE_C_AZA, HOP_SAFE_C_AZA, OP_SAFE_C_AAZ, HOP_SAFE_C_AAZ, OP_SAFE_C_SSZ, HOP_SAFE_C_SSZ,
      OP_SAFE_C_ZZA, HOP_SAFE_C_ZZA, OP_SAFE_C_ZAZ, HOP_SAFE_C_ZAZ, OP_SAFE_C_AZZ, HOP_SAFE_C_AZZ, 
      OP_SAFE_C_ZZZ, HOP_SAFE_C_ZZZ, OP_SAFE_C_ZZZZ, HOP_SAFE_C_ZZZZ,
      OP_SAFE_C_SSP, HOP_SAFE_C_SSP,
      
      OPT_MAX_DEFINED
};


#define is_safe_c_op(op) ((op < OP_THUNK) && (op >= OP_SAFE_C_C))
#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op < OP_SAFE_C_P))


/* also for debugging */
static const char *opt_names[OPT_MAX_DEFINED + 1] =
  {  
      "not_an_op", "h_not_an_op",
      "safe_c_c", "h_safe_c_c", "safe_c_s", "h_safe_c_s", "safe_cons_ss", "h_safe_cons_ss",
      "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", 
      "safe_c_q", "h_safe_c_q", "safe_c_sq", "h_safe_c_sq", "safe_c_qs", "h_safe_c_qs", "safe_c_qq", "h_safe_c_qq", 
      "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_all_s", "h_safe_c_all_s", "safe_c_all_x", "h_safe_c_all_x", "safe_c_ssa", "h_safe_c_ssa", "safe_c_csa", "h_safe_c_csa",
      "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_aaa", "h_safe_c_aaa", "safe_c_aaaa", "h_safe_c_aaaa", 
      "safe_c_az", "h_safe_c_az", "safe_c_za", "h_safe_c_za", "safe_c_sqs", "h_safe_c_sqs",
      
      "safe_c_opcq", "h_safe_c_opcq", "safe_c_opqq", "h_safe_c_opqq", "safe_c_opsq", "h_safe_c_opsq", 
      "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq", "safe_c_opsqq", "h_safe_c_opsqq", 
      "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_c_opcsq", "h_safe_c_c_opcsq", "safe_c_opcsq_c", "h_safe_c_opcsq_c", 
      "safe_c_s_opcq", "h_safe_c_s_opcq", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", 
      "safe_c_c_opcq", "h_safe_c_c_opcq", "safe_c_opcq_s", "h_safe_c_opcq_s", 
      "safe_c_opcq_opcq", "h_safe_c_opcq_opcq", "safe_c_opcq_c", "h_safe_c_opcq_c", 
      "safe_c_opscq_opscq", "h_safe_c_opscq_opscq", "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", 
      "safe_c_opssq_opcq", "h_safe_c_opssq_opcq", "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_opscq_s", "h_safe_c_opscq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s",
      "safe_c_opscq_c", "h_safe_c_opscq_c", "safe_c_opcq_opssq", "h_safe_c_opcq_opssq",
      "safe_c_s_op_opssq_sq", "h_safe_c_s_op_opssq_sq", "safe_c_s_op_s_opssqq", "h_safe_c_s_op_s_opssqq", 
      "safe_c_op_opssq_q_c", "h_safe_c_op_opssq_q_c",
      
      "thunk", "h_thunk", 
      "closure_s", "h_closure_s", "closure_sp", "h_closure_sp", "closure_c", "h_closure_c", "closure_q", "h_closure_q", 
      "closure_ss", "h_closure_ss", "closure_ssb", "h_closure_ssb", "closure_ssp", "h_closure_ssp", 
      "closure_sc", "h_closure_sc", "closure_cs", "h_closure_cs", 
      "closure_opsq", "h_closure_opsq", "closure_opcq", "h_closure_opcq", 
      "closure_opsq_s", "h_closure_opsq_s", "closure_opsq_opsq", "h_closure_opsq_opsq", 
      "closure_s_opsq", "h_closure_s_opsq", "closure_s_opssq", "h_closure_s_opssq", "closure_opssq_s", "h_closure_opssq_s", 
      "closure_sss", "h_closure_sss",
      "closure_all_c", "h_closure_all_c", "closure_all_x", "h_closure_all_x", 
      "closure_cdr_s", "h_closure_cdr_s", "closure_all_s", "h_closure_all_s", 

      "closure_star_s", "h_closure_star_s", "closure_star_sx", "h_closure_star_sx", 
      "closure_star", "h_closure_star", "closure_star_all_x", "h_closure_star_all_x", 

      "safe_thunk", "h_safe_thunk",
      "safe_closure_s", "h_safe_closure_s", "safe_closure_c", "h_safe_closure_c", "safe_closure_q", "h_safe_closure_q", 
      "safe_closure_ss", "h_safe_closure_ss", "safe_closure_sc", "h_safe_closure_sc", "safe_closure_cs", "h_safe_closure_cs", 
      "safe_closure_opcq", "h_safe_closure_opcq", "safe_closure_sa", "h_safe_closure_sa", 
      "safe_closure_opsq", "h_safe_closure_opsq", "safe_closure_opsq_s", "h_safe_closure_opsq_s", "safe_closure_opsq_opsq", "h_safe_closure_opsq_opsq", 
      "safe_closure_s_opsq", "h_safe_closure_s_opsq", "safe_closure_s_opssq", "h_safe_closure_s_opssq", "safe_closure_opssq_s", "h_safe_closure_opssq_s", 
      "safe_closure_sss", "h_safe_closure_sss", "safe_closure_saa", "h_safe_closure_saa", "safe_closure_s_cdr_cdr", "h_safe_closure_s_cdr_cdr",
      "safe_closure_car_car", "h_safe_closure_car_car", "safe_closure_cdr_cdr", "h_safe_closure_cdr_cdr", 
      "safe_closure_all_c", "h_safe_closure_all_c", "safe_closure_all_x", "h_safe_closure_all_x", 
      "safe_closure_s_z", "h_safe_closure_s_z", "safe_closure_s_p", "h_safe_closure_s_p",

      "safe_closure_star_s", "h_safe_closure_star_s", "safe_closure_star_ss", "h_safe_closure_star_ss", 
      "safe_closure_star_sc", "h_safe_closure_star_sc", "safe_closure_star_sa", "h_safe_closure_star_sa", "safe_closure_star_s0", "h_safe_closure_star_s0",
      "safe_closure_star", "h_safe_closure_star", "safe_closure_star_all_x", "h_safe_closure_star_all_x", 
      
      "apply_ss", "h_apply_ss",
      "c_all_x", "h_c_all_x", "call_with_exit", "h_call_with_exit", "c_catch", "h_c_catch", "c_catch_all", "h_c_catch_all",
      "c_s_opsq", "h_c_s_opsq", "c_s_opcq", "h_c_s_opcq", "c_qq_1", "h_c_qq_1",
      "c_for_each_ls", "h_c_for_each_ls", "c_for_each_ls_2", "h_c_for_each_ls_2", "c_for_each_l_opsq", "h_c_for_each_l_opsq", 
      "c_s", "h_c_s", "read_s", "h_read_s", "c_p", "h_c_p", "c_sp", "h_c_sp", "c_a", "h_c_a",

      "goto", "h_goto", "goto_c", "h_goto_c", "goto_s", "h_goto_s", 
      
      "vector_c", "h_vector_c", "vector_s", "h_vector_s", "vector_opcq", "h_vector_opcq", 
      "string_c", "h_string_c", "string_s", "h_string_s", "string_opcq", "h_string_opcq", 
      "c_object", "h_c_object", "c_object_c", "h_c_object_c", "c_object_s", "h_c_object_s", 
      "c_object_opcq", "h_c_object_opcq", "c_object_ss", "h_c_object_ss", 
      "pair_c", "h_pair_c", "pair_s", "h_pair_s", "pair_opcq", "h_pair_opcq", 
      "hash_table_c", "h_hash_table_c", "hash_table_s", "h_hash_table_s", 
      "environment_s", "h_environment_s", "environment_q", "h_environment_q", 
      
      "unknown", "h_unknown", "unknown_c", "h_unknown_c", "unknown_s", "h_unknown_s", "unknown_q", "h_unknown_q",
      "unknown_ss", "h_unknown_ss", "unknown_sss", "h_unknown_sss", "unknown_all_s", "h_unknown_all_s", "unknown_all_x", "h_unknown_all_x",
      "unknown_sc", "h_unknown_sc", "unknown_cs", "h_unknown_cs", "unknown_cc", "h_unknown_cc", 
      "unknown_opsq", "h_unknown_opsq", "unknown_opsq_s", "h_unknown_opsq_s", "unknown_opsq_opsq", "h_unknown_opsq_opsq",      
      "unknown_s_opsq", "h_unknown_s_opsq", "unknown_s_opssq", "h_unknown_s_opssq", "unknown_opssq_s", "h_unknown_opssq_s", 
      "unknown_opcq", "h_unknown_opcq", 

      "safe_c_p", "h_safe_c_p", "safe_c_pp", "h_safe_c_pp",
      "safe_c_opsq_p", "h_safe_c_opsq_p", 
      "safe_c_sp", "h_safe_c_sp", "safe_c_cp", "h_safe_c_cp", "safe_c_qp", "h_safe_c_qp", 
      "safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", "safe_c_pq", "h_safe_c_pq",
      
      "safe_c_z", "h_safe_c_z", "safe_c_zz", "h_safe_c_zz", "safe_c_sz", "h_safe_c_sz", "safe_c_zs", "h_safe_c_zs", 
      "safe_c_cz", "h_safe_c_cz", "safe_c_zc", "h_safe_c_zc", "safe_c_qz", "h_safe_c_qz", "safe_c_zq", "h_safe_c_zq", 
      "safe_c_opcq_z", "h_safe_c_opcq_z", "safe_c_s_opszq", "h_safe_c_s_opszq", 
      "safe_c_s_opaaq", "h_safe_c_s_opaaq", "safe_c_s_opaaaq", "h_safe_c_s_opaaaq", 
      
      "safe_c_zaa", "h_safe_c_zaa", "safe_c_aza", "h_safe_c_aza", "safe_c_aaz", "h_safe_c_aaz", "safe_c_ssz", "h_safe_c_ssz",
      "safe_c_zza", "h_safe_c_zza", "safe_c_zaz", "h_safe_c_zaz", "safe_c_azz", "h_safe_c_azz", 
      "safe_c_zzz", "h_safe_c_zzz", "safe_c_zzzz", "h_safe_c_zzzz",
      "safe_c_ssp", "h_safe_c_ssp",
      
      "opt_max_defined"
  };

#define opt_name(E) ((is_optimized(E)) ? opt_names[optimize_data(E)] : "unopt")


#define NUM_CHARS 256


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_BYTEVECTOR} token_t;

#if 0
#define NUM_TOKENS 13
static const char *token_names[NUM_TOKENS] = {
  "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_bytevector"};
#endif


typedef enum {FILE_PORT, STRING_PORT, FUNCTION_PORT} port_type_t;

typedef struct s7_port_t {
  bool is_closed;
  port_type_t type;
  bool needs_free;
  FILE *file;
  char *filename;
  int filename_length;
  s7_pointer (*input_function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port);
  void (*output_function)(s7_scheme *sc, unsigned char c, s7_pointer port);
  /* 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.
   */
  s7_pointer orig_str;                                                   /* GC protection for string port string */
  int (*read_character)(s7_scheme *sc, s7_pointer port);                 /* function to read a character */
  void (*write_character)(s7_scheme *sc, int c, s7_pointer port);        /* function to write a character */
  void (*write_string)(s7_scheme *sc, const char *str, 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 */
  int (*read_white_space)(s7_scheme *sc, s7_pointer port);               /* internal skip white space reader */
  s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt, bool atom_case); /* internal get-next-name reader */
  s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case);  /* function to display or write a string up to \n */
  void (*display)(s7_scheme *sc, const char *s, s7_pointer pt);
} s7_port_t;


typedef struct c_proc_t {
  const char *name;
  int name_length;
  unsigned int id;
  char *doc;
  s7_pointer generic_ff, looped_ff, let_looped_ff;
  s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr);
  s7_ex *(*exf)(s7_scheme *sc, s7_pointer expr);
  void *chooser_data;
} c_proc_t;


typedef struct {               /* call/cc */
  unsigned int stack_size, op_stack_loc, op_stack_size;
  int local_key;
} s7_continuation_t;


typedef struct s7_vdims_t {
  unsigned int ndims;
  bool elements_allocated, dimensions_allocated;
  s7_Int *dims, *offsets;
  s7_pointer original;
} s7_vdims_t;


typedef struct c_object_t {
  int type;
  const char *name;
  char *(*print)(s7_scheme *sc, void *value);
  void (*free)(void *value);
  bool (*equal)(void *val1, void *val2);
  void (*gc_mark)(void *val);
  s7_pointer (*ref)(s7_scheme *sc, s7_pointer obj, s7_pointer args);
  s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_pointer args);
  s7_pointer (*length)(s7_scheme *sc, s7_pointer obj);
  s7_pointer (*copy)(s7_scheme *sc, s7_pointer obj);
  s7_pointer (*reverse)(s7_scheme *sc, s7_pointer obj);
  s7_pointer (*fill)(s7_scheme *sc, s7_pointer obj, s7_pointer args);
  s7_pointer (*ref_2)(s7_scheme *sc, void *val, s7_pointer index);
  s7_pointer (*set_3)(s7_scheme *sc, void *val, s7_pointer index, s7_pointer value);
  char *(*print_readably)(s7_scheme *sc, void *value);
  unsigned int min_args, max_args;
  size_t length_loc, data_loc;
  bool has_array;
} c_object_t;


/* cell structure */
typedef struct s7_cell {
  union {
    unsigned int flag;
    unsigned char type_field;
    unsigned short sflag;
  } tf;
  int hloc;
  union {
    
    union {
      s7_Int integer_value;
      s7_Double real_value;

      struct {
	char padding[PRINT_NAME_PADDING];
	char name[PRINT_NAME_SIZE + 2];	
      } pval;

      struct {
	s7_Int numerator;
	s7_Int denominator;
      } fraction_value;

      struct {
	s7_Double rl;
	s7_Double im;
      } complex_value;

      unsigned long ul_value;           /* these two are not used by s7 in any way */
      unsigned long long ull_value;

#if WITH_GMP
      mpz_t big_integer;
      mpq_t big_ratio;
      mpfr_t big_real;
      mpc_t big_complex;
#endif
    } number;

    struct {
      s7_port_t *port;
      char *value;
      unsigned char *data;
      unsigned int size, point;        /* these limit the in-core portion of a string-port to 2^31 bytes */
      unsigned int line_number, file_number;
    } prt;
    
    struct{
      unsigned char c;
      unsigned char up_c, down_c;
      bool alpha_p, digit_p, space_p, upper_p, lower_p;
      const char *c_name;              /* actually we have room here for the name */
      int length;
    } chr;

    void *c_pointer;

    int baffle_key;

    struct {
      s7_Int length;
      union {
	s7_pointer *objects;
	s7_Int *ints;
	s7_Double *floats;
      } elements;
      s7_vdims_t *dim_info;
      s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_Int loc);
      s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_Int loc, s7_pointer val);
    } vector;
    
    struct {
      s7_Int length;
      s7_pointer *elements;
      unsigned int entries;          
      s7_pointer (*hash_func)(s7_scheme *sc, s7_pointer table, s7_pointer key); 
      s7_pointer eq_func;
    } hasher;
    
    struct {
      c_proc_t *c_proc;                /* C functions, macros */
      s7_function ff;
      s7_pointer setter;
      unsigned int required_args, optional_args, all_args;
      bool rest_arg;
    } fnc;
      
    struct {                           /* pairs */ 
      s7_pointer car, cdr, ecdr, fcdr;
      unsigned int line;
      union {
	struct {
	  unsigned short data;
	  unsigned short data_index;
	} d;
	unsigned int op;
      } dat;
    } cons;

    struct {
      s7_pointer car, cdr, ecdr, fcdr, gcdr;
    } ext_cons;

    struct {
      s7_pointer args, body, env, setter;
      int arity;
    } func;

    struct { 
      unsigned int length;
      unsigned int hash;  
      char *svalue;
      bool needs_free;

      /* extra data for symbols which always have a string name field (hash field is also used specially by symbols) */
      s7_pointer initial_slot;
    } string;
    
    struct {                      /* symbols */
      s7_pointer name, global_slot, local_slot;
      long long int id;
      union {
	int accessor;
	s7_pointer ksym;
      } ext;
    } sym;

    struct {                       /* slots (bindings) */
      s7_pointer sym, val, nxt, pending_value, expr;
    } slt;

    struct {                       /* environments (frames) */
      s7_pointer slots, nxt;
      long long int id;            /* id of global_env is -1 */
      union {
	struct {
	  s7_pointer function;     /* __func__ (code) if this is a closure environment */
	  unsigned int line, file; /* __func__ location if it is known */
	} efnc;
	struct {
	  s7_pointer dox1, dox2;   /* do loop variables */
	} dox;
	struct {
	  s7_pointer result;
	  unsigned int op_stack_loc, goto_loc;
	} ctall;
      } edat;
    } envr;

    struct {
      /* these 3 are just place-holders */
      s7_pointer unused_slots, unused_nxt;
      long long int unused_id;
      /* these two fields are for some special case objects like #<unspecified> */
      const char *name;
      int len;
    } unq;

    struct {               /* counter (internal) */
      s7_pointer result, list, env;
      long long int val, len;
    } ctr;

    struct {               /* additional object types (C) */
      int type;
      void *value;         /*  the value the caller associates with the object */
      s7_pointer e;        /*   the method list, if any (open environment) */
      s7_Int array_length;
      s7_Double *array;
    } c_obj;
    
    struct {
      s7_continuation_t *continuation;
      s7_pointer stack;
      s7_pointer *stack_start, *stack_end, *op_stack;
    } cwcc;

    struct {               /* call-with-exit */
      unsigned int goto_loc, op_stack_loc;
      bool active;
    } rexit;
    
    struct {               /* catch */
      unsigned int goto_loc, op_stack_loc;
      s7_pointer tag;
      s7_pointer handler;
    } rcatch; /* C++ reserves "catch" I guess */
    
    struct {               /* dynamic-wind */
      s7_pointer in, out, body;
      unsigned int state;
    } winder;
  } object;

#if DEBUGGING
  int current_alloc_line, previous_alloc_line, current_alloc_type, previous_alloc_type, debugger_bits;
  const char *current_alloc_func, *previous_alloc_func;
#endif

} s7_cell;


typedef struct {
  s7_pointer *objs;
  int size, top, ref;
  int *refs;
  bool has_hits;
} shared_info;


typedef struct {
  int loc, col, gc_loc, curly_len;
  char *curly_str;
  s7_pointer args;
} format_data;


typedef struct {
  unsigned long long int ran_seed, ran_carry;
} s7_rng_t;


static s7_pointer *small_ints, *chars;
static s7_pointer real_zero, real_NaN, real_pi, real_one; 


struct s7_scheme {  
  opcode_t op;                        /* making this global is much slower! */
  s7_pointer value;
  s7_pointer args;                    /* arguments of current function */
  s7_pointer code, cur_code;          /* current code */
  s7_pointer envir;                   /* current environment */
  token_t tok;

  s7_pointer stack;                   /* stack is a vector */
  unsigned int stack_size;
  s7_pointer *stack_start, *stack_end, *stack_resize_trigger;
  
  s7_pointer *op_stack, *op_stack_now, *op_stack_end;
  unsigned int op_stack_size;

  s7_pointer stacktrace_env;

  s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top;
  unsigned int heap_size;

  /* "int" or "unsigned int" seems safe here:
   *      sizeof(s7_cell) = 48 bytes
   *      so to get more than 2^32 actual objects would require ca 206 GBytes RAM
   *      vectors might be full of the same object (sc->NIL for example), so there
   *      we need ca 38 GBytes RAM (8 bytes per pointer).  
   */
  
  s7_pointer protected_objects;       /* a vector of gc-protected objects */
  unsigned int protected_objects_size, protected_objects_loc;

  s7_pointer NIL;                     /* empty list */
  s7_pointer T;                       /* #t */
  s7_pointer F;                       /* #f */
  s7_pointer EOF_OBJECT;              /* #<eof> */
  s7_pointer UNDEFINED;               /* #<undefined> */
  s7_pointer UNSPECIFIED;             /* #<unspecified> */
  s7_pointer NO_VALUE;                /* the (values) value */
  s7_pointer ELSE;                    /* else */  
  s7_pointer GC_NIL;
  
  s7_pointer symbol_table;            /* symbol table */
  s7_pointer global_env;              /* global environment */
  s7_Int global_env_entries;
  s7_pointer initial_env;             /* original bindings of predefined functions */
  
  s7_pointer input_port;              /* current-input-port */
  s7_pointer input_port_stack;        /*   input port stack (load and read internally) */
  s7_pointer output_port;             /* current-output-port */
  s7_pointer error_port;              /* current-error-port */
  s7_pointer error_env;               /* the environment returned by (error-environment) */
  s7_pointer error_type, error_data, error_code, error_line, error_file; /* error_env slots */
  s7_pointer standard_input, standard_output, standard_error;

  s7_pointer sharp_readers;           /* the binding pair for the global *#readers* list */
  s7_pointer vector_print_length;     /* same for *vector-print-length* */
  s7_pointer load_hook;               /* *load-hook* hook object */
  s7_pointer unbound_variable_hook;   /* *unbound-variable-hook* hook object */
  s7_pointer error_hook;              /* *error-hook* hook object */
  s7_pointer direct_str;

  bool gc_off, gc_stats;              /* gc_off: if true, the GC won't run, gc_stats: if true, print stats during GC */
  unsigned int gensym_counter, cycle_counter;
  long long int capture_env_counter;
  bool symbol_table_is_locked;  

  #define INITIAL_STRBUF_SIZE 1024
  unsigned int strbuf_size;
  char *strbuf;
  int print_width;
  
  char *read_line_buf;
  unsigned int read_line_buf_size;

  s7_pointer v, w, x, y, z;         /* evaluator local vars */
  s7_pointer temp1, temp2, temp3, temp4;
  s7_pointer temp_cell, temp_cell_1, temp_cell_2, temp_cell_3, temp_cell_4;
  s7_pointer T1_1, T2_1, T2_2, T3_1, T3_2, T3_3;
  s7_pointer A1_1, A2_1, A2_2, A3_1, A3_2, A3_3, A4_1, A4_2, A4_3, A4_4;

  jmp_buf goto_start;
  bool longjmp_ok;
  void (*begin_hook)(s7_scheme *sc, bool *val);
  
  int no_values, current_line, s7_call_line, safety, class_name_location;
  const char *current_file, *s7_call_file, *s7_call_name;

  shared_info *circle_info;
  format_data **fdats;
  int num_fdats;

  s7_pointer *strings, *vectors, *input_ports, *output_ports, *continuations, *c_objects, *hash_tables, *gensyms;
  int strings_size, vectors_size, input_ports_size, output_ports_size, continuations_size, c_objects_size, hash_tables_size, gensyms_size;
  int strings_loc, vectors_loc, input_ports_loc, output_ports_loc, continuations_loc, c_objects_loc, hash_tables_loc, gensyms_loc;

  s7_rng_t *default_rng;
#if WITH_GMP
  void *default_big_rng;

  s7_pointer *bigints, *bigratios, *bigreals, *bignumbers;
  int bigints_size, bigratios_size, bigreals_size, bignumbers_size;
  int bigints_loc, bigratios_loc, bigreals_loc, bignumbers_loc;
#endif

  /* these are symbols, primarily for the generic function search.  
   */
  s7_pointer MINUS, MULTIPLY, ADD, DIVIDE, LT, LEQ, EQ, GT, GEQ, ABS, ACOS, ACOSH;
  s7_pointer ANGLE, APPEND, APPLY, ARITABLEP, ARITY, ASH, ASIN, ASINH, ASSOC, ASSQ, ASSV, ATAN, ATANH;
  s7_pointer AUGMENT_ENVIRONMENT, AUGMENT_ENVIRONMENTB, AUTOLOAD, AUTOLOADER, BOOLEANP, BYTEVECTOR, CAAAAR, CAAADR, CAAAR, CAADAR, CAADDR;
  s7_pointer CAADR, CAAR, CADAAR, CADADR, CADAR, CADDAR, CADDDR, CADDR, CADR, CALL_CC, CALL_WITH_EXIT;
  s7_pointer CALL_WITH_INPUT_FILE, CALL_WITH_INPUT_STRING, CALL_WITH_OUTPUT_FILE, CALL_WITH_OUTPUT_STRING, CAR, CATCH, CDAAAR;
  s7_pointer CDAADR, CDAAR, CDADAR, CDADDR, CDADR, CDAR, CDDAAR, CDDADR, CDDAR, CDDDAR, CDDDDR, CDDDR, CDDR, CDR, CEILING;
  s7_pointer CHAR_LEQ, CHAR_LT, CHAR_EQ, CHAR_GEQ, CHAR_GT, CHARP, CHAR_POSITION, CHAR_TO_INTEGER, CHAR_ALPHABETICP, CHAR_CI_LEQ, CHAR_CI_LT, CHAR_CI_EQ;
  s7_pointer CHAR_CI_GEQ, CHAR_CI_GT, CHAR_DOWNCASE, CHAR_LOWER_CASEP, CHAR_NUMERICP, CHAR_READYP, CHAR_UPCASE, CHAR_UPPER_CASEP;
  s7_pointer CHAR_WHITESPACEP, CLOSE_INPUT_PORT, CLOSE_OUTPUT_PORT, COMPLEXP, CONS, CONSTANTP, CONTINUATIONP, COPY, COS, COSH, C_POINTER, C_POINTERP;
  s7_pointer DEFINEDP, DENOMINATOR, DISPLAY, DYNAMIC_WIND, ENVIRONMENTP, ENVIRONMENT, ENVIRONMENT_REF, ENVIRONMENT_SET, ENVIRONMENT_TO_LIST;
  s7_pointer EOF_OBJECTP, EQP, EQUALP, EQVP, ERROR, EVAL, EVAL_STRING, EVENP, EXACTP;
  s7_pointer EXACT_TO_INEXACT, EXP, EXPT, FILL, FLOOR, FLUSH_OUTPUT_PORT, FORMAT, FOR_EACH, GC, GCD, GENSYM, GET_OUTPUT_STRING, HASH_TABLE;
  s7_pointer HASH_TABLEP, HASH_TABLE_ITERATORP, HASH_TABLE_REF, HASH_TABLE_SET, HASH_TABLE_SIZE, HELP, IMAG_PART, INEXACTP, INEXACT_TO_EXACT;
  s7_pointer INFINITEP, INPUT_PORTP, INTEGERP, INTEGER_TO_CHAR, INTEGER_DECODE_FLOAT, INTEGER_LENGTH, KEYWORDP, KEYWORD_TO_SYMBOL, LCM, LENGTH;
  s7_pointer LIST, LISTP, LIST_TO_STRING, LIST_TO_VECTOR, LIST_REF, LIST_SET, LIST_TAIL, LOAD, LOG, LOGAND, LOGBITP, LOGIOR, LOGNOT, LOGXOR;
  s7_pointer MACROP, MAGNITUDE, MAKE_BYTEVECTOR, MAKE_HASH_TABLE, MAKE_HASH_TABLE_ITERATOR, MAKE_KEYWORD, MAKE_LIST, MAKE_POLAR, MAKE_RANDOM_STATE;
  s7_pointer MAKE_RECTANGULAR, MAKE_STRING, MAKE_SHARED_VECTOR, MAKE_VECTOR, MAP, MAX, MEMBER, MEMQ, MEMV, MIN, MODULO, MORALLY_EQUALP, NANP, NEGATIVEP, NEWLINE;
  s7_pointer NOT, NULLP, NUMBERP, NUMBER_TO_STRING, NUMERATOR, OBJECT_ENVIRONMENT, OBJECT_TO_STRING, ODDP, OPEN_ENVIRONMENT, OPEN_ENVIRONMENTP, OPEN_INPUT_FILE;
  s7_pointer OPEN_INPUT_STRING, OPEN_OUTPUT_FILE, OUTER_ENVIRONMENT, OUTPUT_PORTP, PAIRP, PAIR_LINE_NUMBER, PEEK_CHAR, PORT_CLOSEDP, PORT_FILENAME, PORT_LINE_NUMBER;
  s7_pointer POSITIVEP, PROCEDUREP, PROCEDURE_ARITY, PROCEDURE_DOCUMENTATION, PROCEDURE_ENVIRONMENT, PROCEDURE_NAME, PROCEDURE_SOURCE, PROVIDE;
  s7_pointer PROVIDEDP, QUOTIENT, RANDOM, RANDOM_STATEP, RANDOM_STATE_TO_LIST, RATIONALIZE, RATIONALP, READ, READ_BYTE, READ_CHAR, READ_LINE, REALP;
  s7_pointer READ_STRING, REAL_PART, REMAINDER, REVERSE, REVERSEB, ROUND, SET_CARB, SET_CDRB, SIN, SINH, SORT, SQRT, STACKTRACE, STRING, STRING_LEQ, STRING_LT, STRING_EQ;
  s7_pointer STRING_GEQ, STRING_GT, STRINGP, STRING_POSITION, STRING_TO_LIST, STRING_TO_NUMBER, STRING_TO_SYMBOL, STRING_APPEND, STRING_CI_LEQ, STRING_CI_LT;
  s7_pointer STRING_CI_EQ, STRING_CI_GEQ, STRING_CI_GT, STRING_COPY, STRING_FILL, STRING_LENGTH, STRING_REF, STRING_SET, SUBSTRING, SYMBOL;
  s7_pointer SYMBOL_ACCESS, SYMBOLP, SYMBOL_TO_KEYWORD, SYMBOL_TO_STRING, SYMBOL_TO_DYNAMIC_VALUE, SYMBOL_TO_VALUE;
  s7_pointer TAN, TANH, THROW, TO_BYTEVECTOR, TRUNCATE, UNOPTIMIZE, VALUES, VECTOR, VECTOR_APPEND;
  s7_pointer VECTORP, VECTOR_TO_LIST, VECTOR_DIMENSIONS, VECTOR_FILL, VECTOR_LENGTH, VECTOR_REF, VECTOR_SET, WITH_INPUT_FROM_FILE;
  s7_pointer WITH_INPUT_FROM_STRING, WITH_OUTPUT_TO_FILE, WITH_OUTPUT_TO_STRING, WRITE, WRITE_BYTE, WRITE_CHAR, WRITE_STRING, ZEROP;
  s7_pointer S7_FEATURES, GC_STATS, LOAD_PATH, PI;

#if WITH_GMP
  s7_pointer BIGNUM, BIGNUM_PRECISION;
#endif
#if WITH_SYSTEM_EXTRAS
  s7_pointer DIRECTORYP, FILE_EXISTSP, DELETE_FILE, GETENV, SYSTEM, DIRECTORY_TO_LIST, FILE_MTIME;
#endif

  /* these are the associated functions, not symbols */
  s7_pointer Vector_Set, String_Set, List_Set, Hash_Table_Set, Environment_Set, Cons; 

  s7_pointer LAMBDA, LAMBDA_STAR, QUOTE, UNQUOTE, MACROEXPAND, BAFFLE;
  s7_pointer SET, QQ_List, QQ_Apply_Values, QQ_Append, Multivector;
  s7_pointer Apply, Vector;
  s7_pointer WRONG_TYPE_ARG, WRONG_TYPE_ARG_INFO, OUT_OF_RANGE, OUT_OF_RANGE_INFO, WTA1, WTA2, WTA3, WTA4, WTA5;
  s7_pointer SIMPLE_WRONG_TYPE_ARG_INFO, SIMPLE_OUT_OF_RANGE_INFO, DIVISION_BY_ZERO, DIVISION_BY_ZERO_ERROR;
  s7_pointer FORMAT_ERROR, WRONG_NUMBER_OF_ARGS, READ_ERROR, SYNTAX_ERROR, TOO_MANY_ARGUMENTS, NOT_ENOUGH_ARGUMENTS;
  s7_pointer KEY_KEY, KEY_OPTIONAL, KEY_REST, KEY_ALLOW_OTHER_KEYS, KEY_READABLE;
  s7_pointer __FUNC__;
  s7_pointer Object_Set, Object_Set_3; /* applicable object set method */
  s7_pointer FEED_TO;                  /* => */
  s7_pointer BODY;
  s7_pointer QUOTE_UNCHECKED, CASE_UNCHECKED, SET_UNCHECKED, LAMBDA_UNCHECKED, LET_UNCHECKED, WITH_ENV_UNCHECKED, WITH_ENV_S;
  s7_pointer LET_STAR_UNCHECKED, LETREC_UNCHECKED, COND_UNCHECKED, COND_SIMPLE;
  s7_pointer SET_SYMBOL_C, SET_SYMBOL_S, SET_SYMBOL_Q, SET_SYMBOL_P, SET_SYMBOL_Z, SET_SYMBOL_ALL_X;
  s7_pointer SET_SYMBOL_SAFE_S, SET_SYMBOL_SAFE_SS, SET_SYMBOL_SAFE_SSS, SET_SYMBOL_SAFE_opSSq_S;
  s7_pointer SET_SYMBOL_SAFE_C;
  s7_pointer SET_NORMAL, SET_PAIR, SET_PAIR_Z, SET_PAIR_A, SET_PAIR_P, SET_PWS, SET_ENV_S, SET_ENV_ALL_X, SET_PAIR_C, SET_PAIR_C_P;
  s7_pointer LAMBDA_STAR_UNCHECKED, DO_UNCHECKED, DEFINE_UNCHECKED, DEFINE_FUNCHECKED, DEFINE_STAR_UNCHECKED;
  s7_pointer CASE_SIMPLE, CASE_SIMPLER, CASE_SIMPLER_1, CASE_SIMPLER_SS;
  s7_pointer CASE_SIMPLEST, CASE_SIMPLEST_SS, CASE_SIMPLEST_ELSE, CASE_SIMPLEST_ELSE_C;
  s7_pointer LET_C, LET_S, LET_Q, LET_ALL_C, LET_ALL_S, LET_ALL_X;
  s7_pointer LET_STAR_ALL_X, LET_opCq, LET_opSSq, LET_C_P, LET_S_P;
  s7_pointer LET_NO_VARS, NAMED_LET, NAMED_LET_NO_VARS, NAMED_LET_STAR, LET_STAR2, AND_UNCHECKED, AND_P, OR_UNCHECKED, OR_P;
  s7_pointer IF_P_P_P, IF_P_P, IF_B_P, IF_B_P_P, IF_P_P_X, IF_P_X_P, IF_P_X_X, IF_S_P_P, IF_S_P, IF_S_P_X, IF_S_X_P;
  s7_pointer IF_Z_P, IF_Z_P_P, IF_A_P, IF_A_P_P, IF_GT_P, IF_ANDP_P, IF_ANDP_P_P, IF_ORP_P, IF_ORP_P_P;

  s7_pointer COND_ALL_X;
  s7_pointer SAFE_IF_Z_Z, SAFE_IF_CC_X_P, SAFE_IF_CC_P_P;
  s7_pointer SAFE_IF_CS_P_P, SAFE_IF_CS_X_P, SAFE_IF_IS_NULL_S_P, SAFE_IF_CC_P, SAFE_IF_CS_P, SAFE_IF_CS_P_X, SAFE_IF_IS_NULL_Q_P;
  s7_pointer SAFE_IF_CSS_X_P, SAFE_IF_CSC_X_P, SAFE_IF_CSC_X_O_A;
  s7_pointer SAFE_IF_CSQ_P, SAFE_IF_CSQ_P_P, SAFE_IF_CSS_P, SAFE_IF_CSS_P_P, SAFE_IF_CSC_P, SAFE_IF_CSC_P_P;
  s7_pointer SAFE_IF_IS_PAIR_P, SAFE_IF_IS_PAIR_P_X, SAFE_IF_IS_PAIR_P_P, SAFE_IF_C_SS_P;
  s7_pointer SAFE_IF_IS_SYMBOL_P, SAFE_IF_IS_SYMBOL_P_P;
  s7_pointer INCREMENT_1, DECREMENT_1, SET_CDR, SET_CONS, INCREMENT_SS, INCREMENT_SSS, INCREMENT_S_opCq, INCREMENT_SZ, INCREMENT_C_TEMP;
  s7_pointer LET_R, LET_O, LET_ALL_R, LET_C_D, LET_O_P, LET_Z_P, LET_O_O, LET_Z_O, LET_R_P, LET_CAR_P;
  s7_pointer SIMPLE_DO, SAFE_DOTIMES, SIMPLE_SAFE_DOTIMES, SAFE_DOTIMES_C_C, SAFE_DOTIMES_C_A, SAFE_DO;
  s7_pointer SIMPLE_DO_P, DOTIMES_P, SIMPLE_DO_FOREVER, SIMPLE_DO_A;
  s7_pointer DOX;

  s7_pointer *safe_lists; /* prebuilt evaluator arg lists */

  s7_pointer autoload_table, libraries;
  const char ***autoload_names;
  int *autoload_names_sizes;
  int autoload_names_loc, autoload_names_top;

  unsigned int port_heap_size, port_heap_loc;
  s7_port_t **port_heap;

  int format_depth;
  int slash_str_size;
  char *slash_str;
};

typedef enum {USE_DISPLAY, USE_WRITE, USE_READABLE_WRITE, USE_WRITE_WRONG} use_write_t;

#define NUM_SAFE_LISTS 16
#define INITIAL_AUTOLOAD_NAMES_SIZE 4

/* is_c_function can be array lookup
 *  the array lookup has exactly the same computational cost as the bit check
 */

#define T_FREE                 0
#define T_NIL                  1
#define T_UNIQUE               2
#define T_BOOLEAN              3
#define T_CHARACTER            4
#define T_SYMBOL               5
#define T_SYNTAX               6

#define T_INTEGER              7
#define T_RATIO                8
#define T_REAL                 9
#define T_COMPLEX             10

#define T_BIG_INTEGER         11
#define T_BIG_RATIO           12
#define T_BIG_REAL            13
#define T_BIG_COMPLEX         14

/* only used in WITH_GMP case -- order matters.
 *
 * We could manipulate these types so that (type(x) | (type(y) << 1)) is unique and retains x&y type info:
 *   (1 2 9 10 (from 2 to 30) -> (2 3 5 6 10 11 13 14 18 19 21 22 26 27 29 30))
 *   (1 2 8 11 (from 2 to 31) -> (2 3 5 6 10 11 12 15 17 18 22 23 24 27 30 31))
 * and move the other types out beyond 30 so that wrong type args are easy to catch.
 * Then procedures that, for example, add 2 things need only one switch statement.
 * But timing tests indicate it's actually just as fast to trap the most common cases
 * by hand, leaving these type numbers alone.
 *
 * other cases: ((1 4 5) ((top 15) (3 6 7 9 11 12 13 14 15)))
 *              ((1 2 8 11) (top 31) (2 3 5 6 10 11 12 15 17 18 22 23 24 27 30 31))
 *              ((1 4 5 16 17) ((top 51) (3 6 7 9 11 12 13 14 15 18 19 24 25 26 27 33 35 36 37 38 39 48 49 50 51)))
 *              ((1 4 5 16 17 20) (top 60) 3 9 11 33 35 41 6 12 14 36 38 44 7 13 15 37 39 45 18 24 26 48 50 56 19 25 27 49 51 57 22 28 30 52 54 60)
 *              ((1 4 5 16 17 20 21) (top 63) 3 9 11 33 35 41 43 6 12 14 36 38 44 46 7 13 15 37 39 45 
 *                                            47 18 24 26 48 50 56 58 19 25 27 49 51 57 59 22 28 30 52 54 60 62 23 29 31 53 55 61 63)
 *              ((1 4 8 13 36 37 40 41) (top 123) 3 9 17 27 73 75 81 83 6 12 20 30 76 78 84 86 10 8 24 
 *                                            26 72 74 88 90 15 13 29 31 77 79 93 95 38 44 52 62 108 110 116 118 39 45 53 63 109 111 
 *                                            117 119 42 40 56 58 104 106 120 122 43 41 57 59 105 107 121 123
 *              the 1 2 8 11 32 35 41 42 case tops out at 126
 * 
 * so we actually could do the same thing with 8 types in the bignum case, 
 * even though we have only a byte for all the types! (top=n|n<<1 where n=top choice, normally close to n*3)
 */

#define T_STRING              15
#define T_PAIR                16
#define T_C_OBJECT            17
#define T_CLOSURE             18
#define T_CLOSURE_STAR        19
#define T_CONTINUATION        20
#define T_VECTOR              21
#define T_INT_VECTOR          22
#define T_FLOAT_VECTOR        23
#define T_MACRO               24
#define T_BACRO               25
#define T_GOTO                26
#define T_CATCH               27
#define T_DYNAMIC_WIND        28
#define T_HASH_TABLE          29
#define T_ENVIRONMENT         30
#define T_STACK               31
#define T_COUNTER             32
#define T_SLOT                33
#define T_C_POINTER           34
#define T_C_MACRO             35
#define T_OUTPUT_PORT         36
#define T_INPUT_PORT          37
#define T_BAFFLE              38

#define T_C_FUNCTION          39
#define T_C_ANY_ARGS_FUNCTION 40
#define T_C_OPT_ARGS_FUNCTION 41
#define T_C_RST_ARGS_FUNCTION 42
#define T_C_LST_ARGS_FUNCTION 43

#define NUM_TYPES        44

static s7_pointer prepackaged_type_names[NUM_TYPES];

static bool t_number_p[NUM_TYPES], t_real_p[NUM_TYPES], t_rational_p[NUM_TYPES];
static bool t_simple_p[NUM_TYPES];
static bool t_big_number_p[NUM_TYPES];
static bool t_structure_p[NUM_TYPES];
static bool t_any_macro_p[NUM_TYPES];
static bool t_sequence_p[NUM_TYPES];
static bool t_vector_p[NUM_TYPES];
static bool t_applicable_p[NUM_TYPES];
static bool t_catchable_p[OP_MAX_DEFINED];

static void init_types(void)
{
  int i;
  for (i = 0; i < NUM_TYPES; i++) 
    {
      t_number_p[i] = false;
      t_real_p[i] = false;
      t_rational_p[i] = false;
      t_simple_p[i] = false;
      t_structure_p[i] = false;
      t_any_macro_p[i] = false;
      t_sequence_p[i] = false;
      t_vector_p[i] = false;
      t_applicable_p[i] = false;
    }
  t_number_p[T_INTEGER] = true;
  t_number_p[T_RATIO] = true;
  t_number_p[T_REAL] = true;
  t_number_p[T_COMPLEX] = true;

  t_rational_p[T_INTEGER] = true;
  t_rational_p[T_RATIO] = true;
  
  t_real_p[T_INTEGER] = true;
  t_real_p[T_RATIO] = true;
  t_real_p[T_REAL] = true;

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

  t_structure_p[T_PAIR] = true;
  t_structure_p[T_VECTOR] = true;
  t_structure_p[T_HASH_TABLE] = true;
  t_structure_p[T_SLOT] = true;
  t_structure_p[T_ENVIRONMENT] = true;

  t_sequence_p[T_NIL] = true;
  t_sequence_p[T_PAIR] = true;
  t_sequence_p[T_STRING] = true;
  t_sequence_p[T_VECTOR] = true;
  t_sequence_p[T_INT_VECTOR] = true;
  t_sequence_p[T_FLOAT_VECTOR] = true;
  t_sequence_p[T_HASH_TABLE] = true;
  t_sequence_p[T_ENVIRONMENT] = true;
  t_sequence_p[T_C_OBJECT] = true;

  t_vector_p[T_VECTOR] = true;
  t_vector_p[T_INT_VECTOR] = true;
  t_vector_p[T_FLOAT_VECTOR] = true;

  t_applicable_p[T_PAIR] = true;
  t_applicable_p[T_STRING] = true;
  t_applicable_p[T_VECTOR] = true;
  t_applicable_p[T_INT_VECTOR] = true;
  t_applicable_p[T_FLOAT_VECTOR] = true;
  t_applicable_p[T_HASH_TABLE] = true;
  t_applicable_p[T_ENVIRONMENT] = true;
  t_applicable_p[T_C_OBJECT] = true;
  t_applicable_p[T_C_MACRO] = true;
  t_applicable_p[T_MACRO] = true;
  t_applicable_p[T_BACRO] = true;
  t_applicable_p[T_SYNTAX] = true;
  t_applicable_p[T_C_FUNCTION] = true;
  t_applicable_p[T_C_ANY_ARGS_FUNCTION] = true;
  t_applicable_p[T_C_OPT_ARGS_FUNCTION] = true;
  t_applicable_p[T_C_RST_ARGS_FUNCTION] = true;
  t_applicable_p[T_C_LST_ARGS_FUNCTION] = true;
  t_applicable_p[T_CLOSURE] = true;
  t_applicable_p[T_CLOSURE_STAR] = true;
  t_applicable_p[T_GOTO] = true;
  t_applicable_p[T_CONTINUATION] = true;

  t_any_macro_p[T_C_MACRO] = true;
  t_any_macro_p[T_MACRO] = true;
  t_any_macro_p[T_BACRO] = true;

  t_simple_p[T_NIL] = true;
  t_simple_p[T_UNIQUE] = true;
  t_simple_p[T_BOOLEAN] = true;
  t_simple_p[T_CHARACTER] = true;
  t_simple_p[T_SYMBOL] = true;
  t_simple_p[T_SYNTAX] = true;
  t_simple_p[T_C_MACRO] = true;
  t_simple_p[T_C_FUNCTION] = true;
  t_simple_p[T_C_ANY_ARGS_FUNCTION] = true;
  t_simple_p[T_C_OPT_ARGS_FUNCTION] = true;
  t_simple_p[T_C_RST_ARGS_FUNCTION] = true;
  t_simple_p[T_C_LST_ARGS_FUNCTION] = true;
  /* not completely sure about the next ones */
  t_simple_p[T_ENVIRONMENT] = true;
  t_simple_p[T_INPUT_PORT] = true;
  t_simple_p[T_OUTPUT_PORT] = true;

  for (i = 0; i < OP_MAX_DEFINED; i++) t_catchable_p[i] = false;
  t_catchable_p[OP_CATCH_ALL] = true;
  t_catchable_p[OP_CATCH_1] = true;
  t_catchable_p[OP_CATCH] = true;
  t_catchable_p[OP_DYNAMIC_WIND] = true;
  t_catchable_p[OP_UNWIND_OUTPUT] = true;
  t_catchable_p[OP_UNWIND_INPUT] = true;
  t_catchable_p[OP_READ_DONE] = true;
  t_catchable_p[OP_EVAL_STRING_1] = true;
  t_catchable_p[OP_EVAL_STRING_2] = true;
  t_catchable_p[OP_BARRIER] = true;
  t_catchable_p[OP_DEACTIVATE_GOTO] = true;
  t_catchable_p[OP_ERROR_HOOK_QUIT] = true;
}

/* T_STACK, T_SLOT, T_BAFFLE, and T_COUNTER are internal (stacks, bindings, call/cc barriers, map circular list checks)
 */

#define typeflag(p)                   ((p)->tf.flag)
#define typesflag(p)                  ((p)->tf.sflag)
#define type(p)                       ((p)->tf.type_field)

#define is_number(P)                  t_number_p[type(P)]
#define is_integer(P)                 (type(P) == T_INTEGER)
#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_simple_real(p)             typeflag(p) == T_REAL

#define is_simple(P)                  t_simple_p[type(P)]
#define has_structure(P)              t_structure_p[type(P)]

#define is_any_macro(P)               t_any_macro_p[type(P)]
#define is_procedure_or_macro(P)      ((t_any_macro_p[type(P)]) || ((typeflag(P) & T_PROCEDURE) != 0))

#define is_sequence(P)                ((t_sequence_p[type(P)]) || (has_methods(P)))
#define is_applicable(P)              (t_applicable_p[type(P)])


/* the layout of these bits does matter in several cases -- in particular, don't use the 2nd byte for anything
 *   that might shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR.  Also, none of these bits can easily be turned into
 *   array lookups.
 */
#define NOT_IN_HEAP -1
#define TYPE_BITS                     8

#define T_IMMUTABLE                   (1 << (TYPE_BITS + 0))
#define is_immutable(p)               ((typeflag(p) & T_IMMUTABLE) != 0)
#define set_immutable(p)              typeflag(p) |= T_IMMUTABLE
/* immutable means the value can't be changed via set! or bind -- this is separate from the symbol access stuff
 */
#define dont_copy(p)                  ((!is_pair(p)) || (is_immutable(p)) || (heap_location(p) == NOT_IN_HEAP))
/* dont_copy means the object is not copied when saved in a continuation */

#define T_SYNTACTIC                   (1 << (TYPE_BITS + 1))
#define is_syntactic(p)               ((typeflag(p) & T_SYNTACTIC) != 0)
#define SYNTACTIC_TYPE                (T_SYMBOL | T_DONT_EVAL_ARGS | T_SYNTACTIC)
#define SYNTACTIC_PAIR                (unsigned short)(T_PAIR | T_SYNTACTIC)
/* this marks symbols that represent syntax objects, it should be in the 2nd byte
 */

#define T_PROCEDURE                   (1 << (TYPE_BITS + 2))
#define is_procedure(p)               ((typeflag(p) & T_PROCEDURE) != 0)
/* closure, c_function, applicable object, goto or continuation, should be in 2nd byte
 *   perhaps this should be T_APPLICABLE?
 */

#define T_OPTIMIZED                   (1 << (TYPE_BITS + 3))
#define set_optimized(p)              typeflag(p) |= T_OPTIMIZED
static int t_optimized = T_OPTIMIZED;
/* #define is_optimized(p)               ((typeflag(p) & t_optimized) != 0) */
#define clear_optimized(p)            typeflag(p) &= (~T_OPTIMIZED)
#define OPTIMIZED_PAIR                (unsigned short)(T_PAIR | T_OPTIMIZED)
#define is_optimized(p)               (typesflag(p) == OPTIMIZED_PAIR)
/*   this is faster than the bit extraction above */
/* optimizer flag for an expression that has optimization info, it should be in the 2nd byte
 */

#define T_SAFE_CLOSURE                (1 << (TYPE_BITS + 4))
#define is_safe_closure(p)            ((typeflag(p) & T_SAFE_CLOSURE) != 0)
#define set_safe_closure(p)           typeflag(p) |= T_SAFE_CLOSURE
#define clear_safe_closure(p)         typeflag(p) &= (~T_SAFE_CLOSURE)
/* optimizer flag for a closure body that is completely simple (every expression is safe)
 *   set_safe_closure happens only in optimize_lambda, clear only in procedure_source, bits only here
 *   this has to be separate from T_SAFE_PROCEDURE, and should be in the 2nd byte
 */

#define T_DONT_EVAL_ARGS              (1 << (TYPE_BITS + 5))
#define dont_eval_args(p)             ((typeflag(p) & T_DONT_EVAL_ARGS) != 0)
/* this marks things that don't evaluate their arguments
 */

#define T_EXPANSION                   (1 << (TYPE_BITS + 6))
#define EXPANSION_TYPE                (T_EXPANSION | T_SYMBOL)
#define is_expansion(p)               (typeflag(p) == EXPANSION_TYPE)
/* this marks the symbol associated with a run-time macro and distinguishes the value from an ordinary macro
 */

#define T_MULTIPLE_VALUE              (1 << (TYPE_BITS + 7))
#define is_multiple_value(p)          ((typeflag(p) & T_MULTIPLE_VALUE) != 0)
#define set_multiple_value(p)         typeflag(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.  It is normally
 *    on only for a very short time.
 */

#define T_MATCHED                     (1 << (TYPE_BITS + 7))
#define is_matched(p)                 ((typeflag(p) & T_MATCHED) != 0)
#define set_matched(p)                typeflag(p) |= T_MATCHED
#define clear_matched(p)              typeflag(p) &= (~T_MATCHED)
/* similar transient bit for tree walker */

#define T_GLOBAL                      (1 << (TYPE_BITS + 8))
#define is_global(p)                  ((typeflag(p) & T_GLOBAL) != 0)
/* this marks something defined (bound) at the top-level, and never defined locally */
#define set_global(p)                 typeflag(p) |= T_GLOBAL
#define set_local(p)                  typeflag(p) = (typeflag(p) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC))

#define T_RETURNS_TEMP                (1 << (TYPE_BITS + 9))
#define returns_temp(p)               ((typeflag(p) & T_RETURNS_TEMP) != 0)
#define set_returns_temp(p)           typeflag(p) |= T_RETURNS_TEMP
/* this marks functions that guarantee their returned value is either a newly minted temporary cell
 *   (not one of the function args and not stored anywhere outside-accessible), or an immutable 
 *   constant like real_zero.
 */

#define T_COLLECTED                   T_RETURNS_TEMP
#define is_collected(p)               ((typeflag(p) & T_COLLECTED) != 0)
#define set_collected(p)              typeflag(p) |= T_COLLECTED
#define clear_collected(p)            typeflag(p) &= (~T_COLLECTED)
/* this is a transient flag used by the printer to catch cycles.  It affects only objects
 *   that have structure, whereas T_RETURNS_TEMP only affects functions.  We can't use a
 *   low bit (bit 7 for example), because collect_shared_info inspects the object's type.
 */

#define T_LINE_NUMBER                 (1 << (TYPE_BITS + 10))
#define has_line_number(p)            ((typeflag(p) & T_LINE_NUMBER) != 0)
#define set_has_line_number(p)        typeflag(p) |= T_LINE_NUMBER
/* pair in question has line/file info added during read, or the environment has function placement info
 */

#define T_OVERLAY                     (1 << (TYPE_BITS + 12))
#define set_overlay(p)                typeflag(p) |= T_OVERLAY
#define is_overlaid(p)                ((typeflag(p) & T_OVERLAY) != 0)
/* optimizer flag that marks a cell whose ecdr points to the previous cell in a list
 */

#define T_SAFE_PROCEDURE              (1 << (TYPE_BITS + 13))
#define is_safe_procedure(p)          ((typeflag(p) & T_SAFE_PROCEDURE) != 0)
/* c_functions that do not return or modify the arg list directly (no :rest arg in particular),
 *    and that can't call apply themselves either directly or via s7_call.
 *    I think the latter would be safe if they gc_protect the called function.  
 * This also includes applicable objects that are known safe (lists, vectors, etc -- equivalent to vector-ref).
 */

#define T_CHECKED                     (1 << (TYPE_BITS + 14))
#define set_checked(p)                typeflag(p) |= T_CHECKED
#define is_checked(p)                 ((typeflag(p) & T_CHECKED) != 0)
#define is_not_checked(p)             ((typeflag(p) & T_CHECKED) == 0)

#define T_CHECKED_1                   (1 << (TYPE_BITS + 11))
#define set_checked_1(p)              typeflag(p) |= T_CHECKED_1
#define is_checked_1(p)               ((typeflag(p) & T_CHECKED_1) != 0)
/* optimizer flags that an expression has been checked for possible optimization 
 *    (trying to avoid circular lists during the optimization scan)
 */

#define T_UNSAFE                      (1 << (TYPE_BITS + 15))
#define set_unsafe(p)                 typeflag(p) |= T_UNSAFE
#define set_unsafely_optimized(p)     typeflag(p) |= (T_UNSAFE | T_OPTIMIZED)
#define is_unsafe(p)                  ((typeflag(p) & T_UNSAFE) != 0)
#define clear_unsafe(p)               typeflag(p) &= (~T_UNSAFE)
#define is_safely_optimized(p)        ((typeflag(p) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED)
/* optimizer flag saying "this expression is not completely self-contained.  It might involve the stack, etc"
 */

#define T_STEP_SAFE                   T_UNSAFE
#define is_step_safe(p)               ((typeflag(p) & T_STEP_SAFE) != 0)
#define set_step_safe(p)              typeflag(p) |= T_STEP_SAFE
/* an experiment */

#define T_KEYWORD                     (1 << (TYPE_BITS + 16))
#define is_keyword(p)                 ((typeflag(p) & T_KEYWORD) != 0)
/* this bit distinguishes a symbol from a symbol that is also a keyword
 */

#define T_SETTER                      (1 << (TYPE_BITS + 17))
#define set_setter(p)                 typeflag(p) |= T_SETTER
#define is_setter(p)                  ((typeflag(p) & T_SETTER) != 0)
/* optimizer flag for a procedure that sets some variable (set-car! for example).
 */

#define T_ANNOTATED                   T_SETTER
#define set_annotated(p)              typeflag(p) |= T_ANNOTATED
#define is_annotated(p)               ((typeflag(p) & T_ANNOTATED) != 0)
/* optimizer flag for a pair that has all_x_* info
 */


#define T_ONE_LINER                   (1 << (TYPE_BITS + 18))
#define is_one_liner(p)               ((typeflag(p) & T_ONE_LINER) != 0)
#define set_one_liner(p)              typeflag(p) |= T_ONE_LINER
/* this comes and goes...
 */

#define T_MUTABLE                     T_ONE_LINER
#define is_mutable(p)                 ((typeflag(p) & T_MUTABLE) != 0)
#define set_mutable(p)                typeflag(p) |= T_MUTABLE
#define clear_mutable(p)              typeflag(p) &= (~T_MUTABLE)

#define T_BYTEVECTOR                  T_ONE_LINER
#define is_bytevector(p)              ((typeflag(p) & T_BYTEVECTOR) != 0)
#define set_bytevector(p)             typeflag(p) |= T_BYTEVECTOR
/* marks a string that the caller considers a bytevector 
*/

#define T_PRINT_NAME                  (1 << (TYPE_BITS + 19))
#define has_print_name(p)             ((typeflag(p) & T_PRINT_NAME) != 0)
#define set_has_print_name(p)         typeflag(p) |= T_PRINT_NAME

#define T_IMMEDIATE                   T_PRINT_NAME
#define is_immediate(p)               ((typeflag(p) & T_IMMEDIATE) != 0)
#define set_immediate(p)              typeflag(p) |= T_IMMEDIATE
/* this marks a one-line safe_c_c callable closure body
 */

#define T_COPY_ARGS                   (1 << (TYPE_BITS + 20))
#define set_copy_args(p)              typeflag(p) |= T_COPY_ARGS
#define needs_copied_args(p)          ((typeflag(p) & T_COPY_ARGS) != 0)
/* this marks something that might mess with its argument list, it should not be in the 2nd byte
 */


#define T_GENSYM                      (1 << (TYPE_BITS + 21))
#define is_gensym(p)                  ((typeflag(p) & T_GENSYM) != 0)
#define clear_gensym(p)               typeflag(p) &= (~T_GENSYM)
/* symbol is from gensym (GC-able etc)
 *   since this is only relevant to symbols, this bit is used below in several other non-intersecting ways
 */

#define T_SIMPLE_ARGS                 T_GENSYM
#define has_simple_args(p)            ((typeflag(p) & T_SIMPLE_ARGS) != 0)
#define set_simple_args(p)            typeflag(p) |= T_SIMPLE_ARGS
/* are all lambda* default values simple? */

#define T_LIST_IN_USE                 T_GENSYM
#define list_is_in_use(p)             ((typeflag(p) & T_LIST_IN_USE) != 0)
#define set_list_in_use(p)            typeflag(p) |= T_LIST_IN_USE
#define clear_list_in_use(p)          typeflag(p) &= (~T_LIST_IN_USE)
/* these could all be one permanent list, indexed from inside, and this bit is never actually protecting anything across a call
 */

#define T_NO_VALUE                    T_GENSYM
#define has_no_value(p)               (typeflag(p) == (unsigned int)(T_UNIQUE | T_IMMUTABLE | T_GC_MARK | T_NO_VALUE))
/* to catch (eq? #<unspecified> #<unspecified>) where one of the two is the internal "no value" value 
 */

#define T_FUNCTION_ENV                T_GENSYM
#define is_function_env(p)            ((typeflag(p) & T_FUNCTION_ENV) != 0)
#define set_function_env(p)           typeflag(p) |= T_FUNCTION_ENV
/* this marks a closure environment */


#define T_HAS_METHODS                 (1 << (TYPE_BITS + 22))
#define has_methods(p)                ((typeflag(p) & T_HAS_METHODS) != 0)
#define set_has_methods(p)            typeflag(p) |= T_HAS_METHODS
/* this marks an environment or closure that is "opened" up to generic functions etc */

#define T_GC_MARK                     (1 << (TYPE_BITS + 23))
#define is_marked(p)                  ((typeflag(p) &  T_GC_MARK) != 0)
#define set_mark(p)                   typeflag(p) |= T_GC_MARK
#define clear_mark(p)                 typeflag(p) &= (~T_GC_MARK)
/* using bit 23 for this makes a big difference in the GC
 */

#define UNUSED_BITS  0

#if 0
/* to find who is stomping on our symbols:
 */
static char *object_to_truncated_string(s7_scheme *sc, s7_pointer p, int len);

static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int line) 
{
  if (is_global(symbol)) 
    fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, BOLD_TEXT, DISPLAY(symbol), UNBOLD_TEXT, DISPLAY_80(sc->cur_code));
  typeflag(symbol) = (typeflag(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
}
#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
#endif


#if DEBUGGING
#define set_type(p, f) \
  do { \
      p->previous_alloc_line = p->current_alloc_line; \
      p->previous_alloc_func = p->current_alloc_func; \
      p->previous_alloc_type = p->current_alloc_type; \
      p->current_alloc_line = __LINE__; \
      p->current_alloc_func = __func__; \
      p->current_alloc_type = f; \
      typeflag(p) = f; \
    } while (0)
#else
  #define set_type(p, f)              typeflag(p) = f
#endif

#define heap_location(p)              (p)->hloc

#define is_true(Sc, p)                ((p) != Sc->F)
#define is_false(Sc, p)               ((p) == Sc->F)
#ifdef _MSC_VER
  #define MS_WINDOWS 1
  #if 1
  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) & 0xff) ? sc->T : sc->F)
  #endif
#else
  #define make_boolean(sc, Val)       ((Val) ? sc->T : sc->F)
#endif

#define is_unspecified(p)             (p == sc->UNSPECIFIED)

#define is_pair(p)                    (type(p) == T_PAIR)
#define is_null(p)                    (p == sc->NIL)
#define is_not_null(p)                (p != sc->NIL)

#define car(p)                        ((p)->object.cons.car)
#define cdr(p)                        ((p)->object.cons.cdr)

#if (!DEBUGGING)
#define ecdr(p)                       ((p)->object.cons.ecdr)
#define set_ecdr(p, x)                (p)->object.cons.ecdr = x
#define fcdr(p)                       ((p)->object.cons.fcdr)
#define set_fcdr(p, x)                (p)->object.cons.fcdr = x
#define gcdr(p)                       ((p)->object.ext_cons.gcdr)
#define set_gcdr(p, x)                do {(p)->object.ext_cons.gcdr = x; typeflag(p) &= ~(T_OPTIMIZED | T_LINE_NUMBER);} while (0)
#else

    /* ---------------- debugging versions of e|f|gcdr ---------------- */
#define T_ECDR_SET                    1                                        /* T_HAS_METHODS */
#define ecdr_is_set(p)                (((p)->debugger_bits & T_ECDR_SET) != 0) /* ((typeflag(p) & T_ECDR_SET) != 0) */
#define set_ecdr_is_set(p)            (p)->debugger_bits |= T_ECDR_SET         /*  typeflag(p) |= T_ECDR_SET */

#define ecdr(p) ecdr_1(sc, p, __func__, __LINE__)
#define set_ecdr(p, x) set_ecdr_1(sc, p, x, __func__, __LINE__)

static s7_pointer ecdr_1(s7_scheme *sc, s7_pointer p, const char *func, int line) 
{
  if (!ecdr_is_set(p))
    fprintf(stderr, "ecdr %s[%d]: %p->%p\n", func, line, p, p->object.cons.ecdr); 
  return(p->object.cons.ecdr);
}

static s7_pointer set_ecdr_1(s7_scheme *sc, s7_pointer p, s7_pointer x, const char *func, int line) 
{
  p->object.cons.ecdr = x;
  set_ecdr_is_set(p);
  return(x);
}

#define T_FCDR_SET                    2                                        /* T_GLOBAL */
#define fcdr_is_set(p)                (((p)->debugger_bits & T_FCDR_SET) != 0) /* ((typeflag(p) & T_FCDR_SET) != 0) */
#define set_fcdr_is_set(p)            (p)->debugger_bits |= T_FCDR_SET         /* typeflag(p) |= T_FCDR_SET */

#define fcdr(p) fcdr_1(sc, p, __func__, __LINE__)
#define set_fcdr(p, x) set_fcdr_1(sc, p, x, __func__, __LINE__)

static s7_pointer fcdr_1(s7_scheme *sc, s7_pointer p, const char *func, int line) 
{
  if (!fcdr_is_set(p))
    fprintf(stderr, "fcdr %s[%d]: %p->%p\n", func, line, p, p->object.cons.fcdr); 
  return(p->object.cons.fcdr);
}

static void set_fcdr_1(s7_scheme *sc, s7_pointer p, s7_pointer x, const char *func, int line) 
{
  /* fprintf(stderr, "%d: set %p to %p\n", line, p, x); */ 
  p->object.cons.fcdr = x;
  set_fcdr_is_set(p);
}

/* gcdr collides with optimization and line number stuff (T_LINE_NUMBER, T_OPTIMIZED)
 */
#define T_GCDR_SET                    4                                        /* T_COPY_ARGS */
#define gcdr_is_set(p)                (((p)->debugger_bits & T_GCDR_SET) != 0) /* ((typeflag(p) & T_GCDR_SET) != 0) */
#define set_gcdr_is_set(p)            (p)->debugger_bits |= T_GCDR_SET         /* typeflag(p) |= T_GCDR_SET */

#define gcdr(p) gcdr_1(sc, p, __func__, __LINE__)
#define set_gcdr(p, x) set_gcdr_1(sc, p, x, __func__, __LINE__)

static s7_pointer gcdr_1(s7_scheme *sc, s7_pointer p, const char *func, int line) 
{
  if (!gcdr_is_set(p))
    fprintf(stderr, "%s[%d]: gcdr %p->%p\n", func, line, p, p->object.ext_cons.gcdr); 
  return(p->object.ext_cons.gcdr);
}

static void set_gcdr_1(s7_scheme *sc, s7_pointer p, s7_pointer x, const char *func, int line) 
{
  if ((typeflag(p) & (T_OPTIMIZED | T_LINE_NUMBER)) != 0)
    {
      fprintf(stderr, "gcdr %s[%d]: set %p to %p but %s\n", func, line, p, x, (has_line_number(p)) ? "line number set" : "is optimized");
      typeflag(p) &= ~(T_OPTIMIZED | T_LINE_NUMBER);
    }
  p->object.ext_cons.gcdr = x;
  set_gcdr_is_set(p);
}

#endif

#define caar(p)                       car(car(p))
#define cadr(p)                       car(cdr(p))
#define cdar(p)                       cdr(car(p))
#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 caadr(p)                      car(car(cdr(p)))
#define cdaar(p)                      cdr(car(car(p)))
#define cdddr(p)                      cdr(cdr(cdr(p)))
#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 caddddr(p)                    car(cdr(cdr(cdr(cdr(p)))))


#if WITH_GCC
  /* slightly tricky because cons can be called recursively */
  #define cons(Sc, A, B)             ({s7_pointer _X_; NEW_CELL(sc, _X_); car(_X_) = A; cdr(_X_) = B; set_type(_X_, T_PAIR | T_SAFE_PROCEDURE); _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_2(Sc, A, B)              cons_unchecked(Sc, A, cons(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 pair_line_number(p)           (p)->object.cons.line

#define is_string(p)                  (type(p) == T_STRING)
#define string_value(p)               (p)->object.string.svalue
#define string_length(p)              (p)->object.string.length
#define string_hash(p)                (p)->object.string.hash
#define string_needs_free(p)          (p)->object.string.needs_free

#define character(p)                  (p)->object.chr.c
#define upper_character(p)            (p)->object.chr.up_c
#define lower_character(p)            (p)->object.chr.down_c
#define alphabetic_p(p)               (p)->object.chr.alpha_p
#define numeric_p(p)                  (p)->object.chr.digit_p
#define whitespace_p(p)               (p)->object.chr.space_p
#define upper_p(p)                    (p)->object.chr.upper_p
#define lower_p(p)                    (p)->object.chr.lower_p
#define character_name(p)             (p)->object.chr.c_name
#define character_name_length(p)      (p)->object.chr.length

#define optimize_data(p)              (p)->object.cons.dat.d.data
/* static unsigned short optimize_data(s7_pointer p) {if (!is_optimized(p)) abort(); return(p->object.cons.dat.d.data);}  */
/* #define set_optimize_data(P, X)    do {(P)->object.cons.dat.d.data = (X); (P)->object.cons.dat.d.data_index = (X);} while (0) */
#define optimize_data_match(P, Q)     ((is_optimized(P)) && ((optimize_data(P) & 0xfffe) == Q))
#define optimize_data_index(p)        (p)->object.cons.dat.d.data_index
#define is_hopping(P)                 ((optimize_data(P) & 0x1) == 1)
#define op_no_hop(P)                  (optimize_data(P) & 0xfffe)
static void set_optimize_data(s7_pointer p, unsigned short op) {p->object.cons.dat.d.data = op; optimize_data_index(p) = op;} 
static void set_optimize_op(s7_pointer p, unsigned short op) {optimize_data_index(p) = op;}
#define clear_optimize_data(P)        set_optimize_data(P, 0)
static void set_hopping(s7_pointer p) {p->object.cons.dat.d.data |= 1; optimize_data_index(p) |= 1;}
#define optimize_op(p)                optimize_data_index(p)

#define is_symbol(p)                  (type(p) == T_SYMBOL)
#define symbol_name_cell(p)           (p)->object.sym.name
#define symbol_name(p)                string_value(symbol_name_cell(p))
#define symbol_name_length(p)         string_length(symbol_name_cell(p))
#define symbol_hash(p)                (symbol_name_cell(p))->object.string.hash
#define symbol_accessor(p)            (p)->object.sym.ext.accessor 
#define symbol_has_accessor(p)        (symbol_accessor(p) != -1)
#define symbol_id(p)                  (p)->object.sym.id
/* we need 64-bits here, since we don't want this thing to wrap around, and frames are created at a great rate 
 *    callgrind says this is faster than an unsigned int!
 */
#define global_slot(p)                (p)->object.sym.global_slot
#define initial_slot(p)               (symbol_name_cell(p))->object.string.initial_slot
#define local_slot(p)                 (p)->object.sym.local_slot
#define keyword_symbol(p)             (p)->object.sym.ext.ksym

#define symbol_set_local(Symbol, Id, Slot) do {local_slot(Symbol) = Slot; symbol_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) */

/* I think symbol_id is set only here 
   symbol_accessor can be moved to the name(string) cell (negligible cost, say 10 at most)
   this leaves s7_pointer e alongside ksym.
   If set in parallel in symbol_set_local (say 40 as probable cost in calls, maybe 80),
   it could be checked first in find_symbol_or_bust, so we just check pointers not fields thereof
   could this speed up the lookup? (if direct is twice as fast, this saves about 500)
   this could be done step by step...
 */

#define is_slot(p)                    (type(p) == T_SLOT)
#define slot_value(p)                 (p)->object.slt.val
#define slot_set_value(p, Val)        (p)->object.slt.val = Val
#define slot_symbol(p)                (p)->object.slt.sym
#define next_slot(p)                  (p)->object.slt.nxt
#define slot_pending_value(p)         (p)->object.slt.pending_value
#define slot_expression(p)            (p)->object.slt.expr

#define is_syntax(p)                  (type(p) == T_SYNTAX)
#define syntax_opcode(p)              ((p)->hloc)

#define lifted_op(P)                  (P)->object.cons.dat.op
#define syntax_op(P)                  car(ecdr(P))
#if (!DEBUGGING)
static void set_syntax_op(s7_pointer p, s7_pointer op) {syntax_op(p) = op; lifted_op(ecdr(p)) = syntax_opcode(op);}
#else
#define set_syntax_op(P, Op) set_syntax_op_1(sc, P, Op)
static void set_syntax_op_1(s7_scheme *sc, s7_pointer p, s7_pointer op) {syntax_op(p) = op; lifted_op(ecdr(p)) = syntax_opcode(op);}
#endif

#define environment_id(p)             (p)->object.envr.id
#define is_environment(p)             (type(p) == T_ENVIRONMENT)
#define environment_slots(p)          (p)->object.envr.slots
#define next_environment(p)           (p)->object.envr.nxt
#define environment_function(p)       (p)->object.envr.edat.efnc.function
#define environment_line(p)           (p)->object.envr.edat.efnc.line
#define environment_file(p)           (p)->object.envr.edat.efnc.file
#define environment_dox1(p)           (p)->object.envr.edat.dox.dox1
#define environment_dox2(p)           (p)->object.envr.edat.dox.dox2

#define unique_name(p)                (p)->object.unq.name
#define unique_name_length(p)         (p)->object.unq.len

#define vector_length(p)              ((p)->object.vector.length)
#define vector_element(p, i)          ((p)->object.vector.elements.objects[i])
#define vector_elements(p)            (p)->object.vector.elements.objects
#define vector_getter(p)              (p)->object.vector.vget
#define vector_setter(p)              (p)->object.vector.vset
#define int_vector_element(p, i)      ((p)->object.vector.elements.ints[i])
#define int_vector_elements(p)        (p)->object.vector.elements.ints
#define float_vector_element(p, i)    ((p)->object.vector.elements.floats[i])
#define float_vector_elements(p)      (p)->object.vector.elements.floats
#define is_int_vector(p)              (type(p) == T_INT_VECTOR)
#define is_float_vector(p)            (type(p) == T_FLOAT_VECTOR)

#define vector_ndims(p)               ((p)->object.vector.dim_info->ndims)
#define vector_dimension(p, i)        ((p)->object.vector.dim_info->dims[i])
#define vector_dimensions(p)          ((p)->object.vector.dim_info->dims)
#define vector_offset(p, i)           ((p)->object.vector.dim_info->offsets[i])
#define vector_offsets(p)             ((p)->object.vector.dim_info->offsets)
#define vector_is_multidimensional(p) ((p)->object.vector.dim_info)
#define vector_dimension_info(p)      ((p)->object.vector.dim_info)
#define shared_vector(p)              ((p)->object.vector.dim_info->original)
#define vector_rank(p)                ((vector_dimension_info(p)) ? vector_ndims(p) : 1)
#define vector_elements_allocated(p)  ((p)->object.vector.dim_info->elements_allocated)
#define vector_dimensions_allocated(p) ((p)->object.vector.dim_info->dimensions_allocated)

#define is_hash_table(p)              (type(p) == T_HASH_TABLE)
#define hash_table_length(p)          (p)->object.hasher.length
#define hash_table_element(p, i)      ((p)->object.hasher.elements[i])
#define hash_table_elements(p)        (p)->object.hasher.elements
#define hash_table_entries(p)         (p)->object.hasher.entries
#define hash_table_function(p)        (p)->object.hasher.hash_func
#define hash_table_eq_function(p)     (p)->object.hasher.eq_func

#define is_input_port(p)              (type(p) == T_INPUT_PORT) 
#define is_output_port(p)             (type(p) == T_OUTPUT_PORT)
#define port_port(p)                  (p)->object.prt.port
#define port_type(p)                  port_port(p)->type
#define is_string_port(p)             (port_type(p) == STRING_PORT)
#define is_file_port(p)               (port_type(p) == FILE_PORT)
#define is_function_port(p)           (port_type(p) == FUNCTION_PORT)
#define port_line_number(p)           (p)->object.prt.line_number
#define port_file_number(p)           (p)->object.prt.file_number
#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_is_closed(p)             port_port(p)->is_closed
#define port_string(p)                (p)->object.prt.value
#define port_string_length(p)         (p)->object.prt.size
#define port_string_point(p)          (p)->object.prt.point
#define port_needs_free(p)            port_port(p)->needs_free
#define port_output_function(p)       port_port(p)->output_function
#define port_input_function(p)        port_port(p)->input_function
#define port_data(p)                  (p)->object.prt.data
#define port_position(p)              (p)->object.prt.point
#define port_original_input_string(p) port_port(p)->orig_str
#define port_read_character(p)        port_port(p)->read_character
#define port_read_line(p)             port_port(p)->read_line
#define port_display(p)               port_port(p)->display
#define port_write_character(p)       port_port(p)->write_character
#define port_write_string(p)          port_port(p)->write_string
#define port_read_semicolon(p)        port_port(p)->read_semicolon
#define port_read_white_space(p)      port_port(p)->read_white_space
#define port_read_name(p)             port_port(p)->read_name

#define is_c_function(f)              (type(f) >= T_C_FUNCTION)
#define c_function_data(f)            (f)->object.fnc.c_proc
#define c_function_call(f)            (f)->object.fnc.ff
#define c_function_name(f)            c_function_data(f)->name
#define c_function_name_length(f)     c_function_data(f)->name_length
#define c_function_documentation(f)   c_function_data(f)->doc
#define c_function_required_args(f)   (f)->object.fnc.required_args
#define c_function_optional_args(f)   (f)->object.fnc.optional_args
#define c_function_has_rest_arg(f)    (f)->object.fnc.rest_arg
#define c_function_all_args(f)        (f)->object.fnc.all_args
#define c_function_setter(f)          (f)->object.fnc.setter
#define c_function_class(f)           c_function_data(f)->id
#define c_function_chooser(f)         c_function_data(f)->chooser
#define c_function_chooser_data(f)    c_function_data(f)->chooser_data
#define c_function_base(f)            c_function_data(f)->generic_ff
#define c_function_looped(f)          c_function_data(f)->looped_ff
#define c_function_let_looped(f)      c_function_data(f)->let_looped_ff
#define c_function_ex_parser(f)       c_function_data(f)->exf

void s7_function_set_returns_temp(s7_pointer f) {set_returns_temp(f);}
bool s7_function_returns_temp(s7_scheme *sc, s7_pointer f) {return((is_pair(f)) && (is_optimized(f)) && (ecdr(f)) && (returns_temp(ecdr(f))));}

#define c_call(f)                     ((s7_function)(fcdr(f)))
#define set_c_function(f, X)          do {set_ecdr(f, X); set_fcdr(f, (s7_pointer)(c_function_call(ecdr(f))));} while (0)

#define is_c_macro(p)                 (type(p) == T_C_MACRO)
#define c_macro_data(f)               (f)->object.fnc.c_proc
#define c_macro_call(f)               (f)->object.fnc.ff
#define c_macro_name(f)               c_macro_data(f)->name
#define c_macro_name_length(f)        c_macro_data(f)->name_length
#define c_macro_required_args(f)      (f)->object.fnc.required_args
#define c_macro_all_args(f)           (f)->object.fnc.all_args
#define c_macro_setter(f)             (f)->object.fnc.setter

#define continuation_data(p)          (p)->object.cwcc.continuation
#define continuation_stack(p)         (p)->object.cwcc.stack
#define continuation_stack_end(p)     (p)->object.cwcc.stack_end
#define continuation_stack_start(p)   (p)->object.cwcc.stack_start
#define continuation_stack_size(p)    (p)->object.cwcc.continuation->stack_size
#define continuation_stack_top(p)     (continuation_stack_end(p) - continuation_stack_start(p))
#define continuation_op_stack(p)      (p)->object.cwcc.op_stack
#define continuation_op_loc(p)        (p)->object.cwcc.continuation->op_stack_loc
#define continuation_op_size(p)       (p)->object.cwcc.continuation->op_stack_size
#define continuation_key(p)           (p)->object.cwcc.continuation->local_key

#define call_exit_goto_loc(p)         (p)->object.rexit.goto_loc
#define call_exit_op_loc(p)           (p)->object.rexit.op_stack_loc
#define call_exit_active(p)           (p)->object.rexit.active

#define s7_stack_top(Sc)              ((Sc)->stack_end - (Sc)->stack_start)

#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_bacro(p)                   (type(p) == T_BACRO)

#define is_closure(p)                 (type(p) == T_CLOSURE)
#define is_closure_star(p)            (type(p) == T_CLOSURE_STAR)
#define closure_args(p)               ((p)->object.func.args)
#define closure_body(p)               ((p)->object.func.body)
#define closure_environment(p)        ((p)->object.func.env)
#define closure_setter(p)             ((p)->object.func.setter)
#define closure_arity(p)              ((p)->object.func.arity)
#define CLOSURE_ARITY_NOT_SET         0x40000000
#define MAX_ARITY                     0x20000000

#define catch_tag(p)                  (p)->object.rcatch.tag
#define catch_goto_loc(p)             (p)->object.rcatch.goto_loc
#define catch_op_loc(p)               (p)->object.rcatch.op_stack_loc
#define catch_handler(p)              (p)->object.rcatch.handler

#define catch_all_goto_loc(p)         (p)->object.envr.edat.ctall.goto_loc
#define catch_all_op_loc(p)           (p)->object.envr.edat.ctall.op_stack_loc
#define catch_all_result(p)           (p)->object.envr.edat.ctall.result

enum {DWIND_INIT, DWIND_BODY, DWIND_FINISH};
#define dynamic_wind_state(p)         (p)->object.winder.state
#define dynamic_wind_in(p)            (p)->object.winder.in
#define dynamic_wind_out(p)           (p)->object.winder.out
#define dynamic_wind_body(p)          (p)->object.winder.body

#define is_c_object(p)                (type(p) == T_C_OBJECT)
#define c_object_value(p)             (p)->object.c_obj.value
#define c_object_type(p)              (p)->object.c_obj.type
#define c_object_environment(p)       (p)->object.c_obj.e
#define c_object_array(p)             (p)->object.c_obj.array
#define c_object_array_length(p)      (p)->object.c_obj.array_length

static c_object_t **object_types = NULL;
static int object_types_size = 0;
static int num_types = 0;
/* ideally these would be specific to the current s7, but I did not pass the s7_scheme pointer
 *   to s7_new_type and friends.
 */

#define c_object_info(p)              object_types[c_object_type(p)]
#define c_object_ref(p)               c_object_info(p)->ref
#define c_object_set(p)               c_object_info(p)->set
#define c_object_ref_2(p)             c_object_info(p)->ref_2
#define c_object_set_3(p)             c_object_info(p)->set_3
#define c_object_data_length(p)       (s7_Int)(*((s7_Int *)(((unsigned char *)(c_object_value(p))) + c_object_info(p)->length_loc)))
#define c_object_data(p)              ((s7_Double *)(*((s7_Double **)(((unsigned char *)(c_object_value(p))) + c_object_info(p)->data_loc))))
/* the pointless unsigned char* cast is needed in g++ and clang */
#define c_object_has_array(p)         ((typeflag(p) & T_GENSYM) != 0)
#define c_object_print(p)             c_object_info(p)->print
#define c_object_print_readably(p)    c_object_info(p)->print_readably
#define c_object_length(p)            c_object_info(p)->length
#define c_object_equal(p)             c_object_info(p)->equal
#define c_object_fill(p)              c_object_info(p)->fill
#define c_object_copy(p)              c_object_info(p)->copy
#define c_object_free(p)              c_object_info(p)->free
#define c_object_mark(p)              c_object_info(p)->gc_mark
#define c_object_reverse(p)           c_object_info(p)->reverse
#define c_object_min_args(p)          c_object_info(p)->min_args
#define c_object_max_args(p)          c_object_info(p)->max_args

#define raw_pointer(p)                (p)->object.c_pointer

#define is_counter(p)                 (type(p) == T_COUNTER)
#define counter_result(p)             (p)->object.ctr.result
#define counter_list(p)               (p)->object.ctr.list
#define counter_count(p)              (p)->object.ctr.val
#define counter_length(p)             (p)->object.ctr.len
#define counter_environment(p)        (p)->object.ctr.env

#define baffle_key(p)                 (p)->object.baffle_key

#if __cplusplus && HAVE_COMPLEX_NUMBERS
  using namespace std;
  typedef complex<s7_Double> s7_Complex;
  static s7_Double Real(complex<s7_Double> x) {return(real(x));} /* protect the C++ name */
  static s7_Double Imag(complex<s7_Double> x) {return(imag(x));}
#endif

#define integer(p)                    p->object.number.integer_value
#define real(p)                       p->object.number.real_value
#define numerator(p)                  p->object.number.fraction_value.numerator
#define denominator(p)                p->object.number.fraction_value.denominator
#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)                  p->object.number.complex_value.rl
#define imag_part(p)                  p->object.number.complex_value.im
#if HAVE_COMPLEX_NUMBERS
  #define as_c_complex(p)             (real_part(p) + (imag_part(p) * _Complex_I))
#endif

#define NUM_SMALL_INTS 2048
#define small_int(Val)                small_ints[Val]
#define is_small(n)                   ((n & ~(NUM_SMALL_INTS - 1)) == 0)

#define print_name(p)                 (char *)(p->object.number.pval.name + 1)
#define print_name_length(p)          p->object.number.pval.name[0]

static void set_print_name(s7_pointer p, const char *name, int len)
{
  if ((len < PRINT_NAME_SIZE) &&
      (!is_mutable(p)))
    {
      set_has_print_name(p);
      print_name_length(p) = (unsigned char)(len & 0xff);
      strcpy(print_name(p), name);
    }
}


#if WITH_GCC

#define make_integer(Sc, N) \
  ({ s7_Int _N_; _N_ = N; (is_small(_N_) ? small_int(_N_) : ({ s7_pointer _X_; NEW_CELL(Sc, _X_); set_type(_X_, T_INTEGER); integer(_X_) = _N_; _X_;}) ); })

#define make_real(Sc, X) \
  ({ s7_Double _N_ = X; ((_N_ == 0.0) ? real_zero : ({ s7_pointer _X_; NEW_CELL(Sc, _X_); set_type(_X_, T_REAL); real(_X_) = _N_; _X_;}) ); })
                     /* the x == 0.0 check saves more than it costs */
#else
#define make_integer(Sc, N)           s7_make_integer(Sc, N)
#define make_real(Sc, X)              s7_make_real(Sc, X)
#endif

#if WITH_GMP
  #define big_integer(p)             (p->object.number.big_integer)
  #define big_ratio(p)               (p->object.number.big_ratio)
  #define big_real(p)                (p->object.number.big_real)
  #define big_complex(p)             (p->object.number.big_complex)
#endif

#define S7_LLONG_MAX 9223372036854775807LL
#define S7_LLONG_MIN (-S7_LLONG_MAX - 1LL)

#define S7_LONG_MAX 2147483647LL
#define S7_LONG_MIN (-S7_LONG_MAX - 1LL)

#define S7_SHORT_MAX 32767
#define S7_SHORT_MIN -32768

static s7_Int s7_Int_max = 0, s7_Int_min = 0;

/* 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, so should
 *   we just give an error for any floor (or whatever) of an arg>1e16?  (sin has a similar problem)?
 *   I think in the non-gmp case I'll throw an error in these cases because the results are
 *   bogus:
 *   :(floor (+ (expt 2.0 62) 512))
 *   4611686018427387904
 *   :(floor (+ (expt 2.0 62) 513))
 *   4611686018427388928
 *
 * another case at the edge: (round 9007199254740992.51) -> 9007199254740992
 *
 * This spells trouble for normal arithmetic in this range.  If no gmp,
 *    (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0)
 *    but we don't currently give an error in this case -- not sure what the right thing is.
 */


static int safe_strlen(const char *str)
{
  /* this is safer than strlen, and slightly faster */
  char *tmp = (char *)str;
  if ((!tmp) || (!(*tmp))) return(0);
  while (*tmp++) {};
  return(tmp - str - 1);
}


static int safe_strlen5(const char *str)
{
  /* safe_strlen but we quit counting if len>5 */
  char *tmp = (char *)str;
  char *end;
  if ((!tmp) || (!(*tmp))) return(0);
  end = (char *)(tmp + 6);
  while ((*tmp++) && (tmp < end)) {};
  return(tmp - str - 1);
}


#define strcopy(Dest, Src, Len) snprintf(Dest, Len, "%s", Src)
/* rather than futz around with str*cpy */


static char *copy_string_with_len(const char *str, int len)
{
  char *newstr;
  newstr = (char *)malloc((len + 1) * sizeof(char));
  if (len != 0)
    memcpy((void *)newstr, (void *)str, len + 1);
  else newstr[0] = 0;
  return(newstr);
}


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


#define strings_are_equal(Str1, Str2) (strcmp(Str1, Str2) == 0)
/* newlib code here was slower -- this should only be used for internal strings -- scheme
 *   strings can have embedded nulls.
 */

static int safe_strcmp(const char *s1, const char *s2)
{
  int val;
  if (s1 == NULL)
    {
      if (s2 == NULL)
	return(0);
      return(-1);
    }
  if (s2 == NULL)
    return(1);

  val = strcmp(s1, s2); /* strcmp can return stuff like -97, but we want -1, 0, or 1 */

  if (val <= -1)
    return(-1);
  if (val >= 1)
    return(1);
  return(val);
}


/* forward decls */
static char *number_to_string_base_10(s7_pointer obj, int width, int precision, char float_choice, int *nlen, use_write_t choice);
static bool is_proper_list(s7_scheme *sc, s7_pointer lst);
static bool is_all_x_safe(s7_scheme *sc, s7_pointer p);
static void annotate_args(s7_scheme *sc, s7_pointer args);
static void annotate_arg(s7_scheme *sc, s7_pointer arg);
static void mark_embedded_objects(s7_pointer a); /* called by gc, calls c_obj's mark func */
static s7_pointer eval(s7_scheme *sc, opcode_t first_op);
static s7_pointer division_by_zero_error(s7_scheme *sc, s7_pointer caller, s7_pointer arg);
static s7_pointer file_error(s7_scheme *sc, const char *caller, const char *descr, const char *name);
static s7_pointer safe_reverse_in_place(s7_scheme *sc, s7_pointer list);
static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b);
static s7_pointer permanent_cons(s7_pointer a, s7_pointer b, int type);
static void free_object(s7_pointer a);
static s7_pointer make_atom(s7_scheme *sc, char *q, int radix, bool want_symbol, bool with_error);
static s7_pointer eval_error(s7_scheme *sc, const char *errmsg, s7_pointer obj);
static s7_pointer apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args);
static bool is_thunk(s7_scheme *sc, s7_pointer x);
static int remember_file_name(s7_scheme *sc, const char *file);
static const char *type_name(s7_scheme *sc, s7_pointer arg, int article);
static s7_pointer make_string_uncopied(s7_scheme *sc, char *str);
static s7_pointer make_string_uncopied_with_length(s7_scheme *sc, char *str, int len);
static s7_pointer make_protected_string(s7_scheme *sc, const char *str);
static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args);
static void pop_input_port(s7_scheme *sc);
static char *object_to_truncated_string(s7_scheme *sc, s7_pointer p, int len);
static token_t token(s7_scheme *sc);
static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices);
static bool s7_is_morally_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci);
static void remove_from_symbol_table(s7_scheme *sc, s7_pointer sym);
static s7_pointer find_symbol_or_bust(s7_scheme *sc, s7_pointer hdl);
static s7_pointer call_symbol_bind(s7_scheme *sc, s7_pointer symbol, s7_pointer new_value);
static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol);
static s7_pointer find_environment(s7_scheme *sc, s7_pointer obj);
static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator);
static s7_pointer g_make_hash_table_iterator(s7_scheme *sc, s7_pointer args);
static bool call_begin_hook(s7_scheme *sc);
static s7_pointer default_vector_setter(s7_scheme *sc, s7_pointer vec, s7_Int loc, s7_pointer val);
static s7_pointer default_vector_getter(s7_scheme *sc, s7_pointer vec, s7_Int loc);

static s7_pointer simple_wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typnam, s7_pointer descr);
static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer typnam, s7_pointer descr);
static s7_pointer out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, const char *descr);
static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, const char *descr);

/* putting off the type description until s7_error via the sc->GC_NIL marker below makes it possible
 *    for gcc to speed up the functions that call these as tail-calls.  1-2% overall speedup!
 */
#define simple_wrong_type_argument(Sc, Caller, Arg, Desired_Type) \
  simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->GC_NIL, prepackaged_type_names[Desired_Type])

#define simple_wrong_type_argument_with_type(Sc, Caller, Arg, Type) \
  simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, sc->GC_NIL, Type)

#define wrong_type_argument(Sc, Caller, Arg_Num, Arg, Desired_Type)	\
  wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg_Num, Arg, sc->GC_NIL, prepackaged_type_names[Desired_Type])

#define wrong_type_argument_with_type(Sc, Caller, Arg_Num, Arg, Type)	\
  wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg_Num, Arg, sc->GC_NIL, Type)

#define wrong_type_argument_n(Sc, Caller, Num, Arg, Desired_Type)	\
  wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->GC_NIL, prepackaged_type_names[Desired_Type])

#define wrong_type_argument_n_with_type(Sc, Caller, Num, Arg, Type)	\
  wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, sc->GC_NIL, Type)

#define simple_out_of_range(Sc, Caller, Arg, Description) \
  simple_out_of_range_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, Description)

#define out_of_range(Sc, Caller, Arg_Num, Arg, Description)		\
  out_of_range_error_prepackaged(Sc, symbol_name_cell(Caller), Arg_Num, Arg, Description)


static s7_pointer CAR_A_LIST, CDR_A_LIST;
static s7_pointer CAAR_A_LIST, CADR_A_LIST, CDAR_A_LIST, CDDR_A_LIST;
static s7_pointer CAAAR_A_LIST, CAADR_A_LIST, CADAR_A_LIST, CADDR_A_LIST, CDAAR_A_LIST, CDADR_A_LIST, CDDAR_A_LIST, CDDDR_A_LIST;
static s7_pointer A_LIST, AN_ASSOCIATION_LIST, AN_OUTPUT_PORT, AN_INPUT_PORT, AN_OPEN_PORT, A_NORMAL_REAL, A_RATIONAL, A_CLOSURE;
static s7_pointer A_NUMBER, AN_ENVIRONMENT, A_PROCEDURE, A_PROPER_LIST, A_THUNK, SOMETHING_APPLICABLE, A_SYMBOL, A_NON_NEGATIVE_INTEGER;
static s7_pointer CONSTANT_ARG_ERROR, BAD_BINDING, A_FORMAT_PORT, AN_UNSIGNED_BYTE;


#define WITH_COUNTS 0
#if WITH_COUNTS
#if 0
#if 0
#define NUM_COUNTS 65536
static int counts[NUM_COUNTS];
static void clear_counts(void) {int i; for (i = 0; i < NUM_COUNTS; i++) counts[i] = 0;}
void tick(int this) {counts[this]++;}
static void report_counts(s7_scheme *sc)
{
  int i, mx, mxi, total = 0;
  bool happy = true;

  for (i = 0; i < NUM_COUNTS; i++)
    total += counts[i];

  fprintf(stderr, "total: %d\n", total);
  while (happy)
    {
      mx = 0;
      for (i = 0; i < NUM_COUNTS; i++)
	{
	  if (counts[i] > mx)
	    {
	      mx = counts[i];
	      mxi = i;
	    }
	}
      if (mx > 0)
	{
	  /*
	  if (mx > total/100) 
	    fprintf(stderr, "%s: %d (%f)\n", opt_names[mxi], mx, 100.0*mx/(float)total);
	  */
	  fprintf(stderr, "%d: %d\n", mxi, mx);
	  counts[mxi] = 0;
	}
      else happy = false;
    }
}
#else
#if 1
#define NUM_COUNTS 1000
static int counts[NUM_COUNTS][NUM_COUNTS];
static void clear_counts(void) {int i, j; for (i = 0; i < NUM_COUNTS; i++) for (j = 0; j < NUM_COUNTS; j++) counts[i][j] = 0;}
static void tick(int op1, int op2) {counts[op1][op2]++;}
static void report_counts(s7_scheme *sc)
{
  int i, j, mx, mxi, mxj;
  bool happy = true;
  fprintf(stderr, "\n");
  while (happy)
    {
      mx = 0;
      for (i = 0; i < NUM_COUNTS; i++)
	for (j = 0; j < NUM_COUNTS; j++)
	  {
	    if (counts[i][j] > mx)
	      {
		mx = counts[i][j];
		mxi = i;
		mxj = j;
	      }
	  }
      if (mx > 0)
	{
	  fprintf(stderr, "%d: %s %s\n", mx, opt_names[mxi], opt_names[mxj]);
	  counts[mxi][mxj] = 0;
	}
      else happy = false;
    }
}
#else
#define NUM_COUNTS 1000
static int counts[NUM_COUNTS];
static void clear_counts(void) {int i; for (i = 0; i < NUM_COUNTS; i++) counts[i] = 0;}
static void tick(int op) {counts[op]++;}
static void report_counts(s7_scheme *sc)
{
  int k;
  fprintf(stderr, "\n");
  for (k = 0; k < OP_MAX_DEFINED; k++)
    {
      if (counts[k] > 0)
	fprintf(stderr, "%d: %d\n", k, counts[k]); /* fprintf(stderr, "%s ", opt_names[k]); */
    }
  /* fprintf(stderr, "\n"); */
}
#endif
#endif

static void init_hashes(s7_scheme *sc) {}

#else

void clear_counts(void) {}
static s7_pointer hashes;
void add_expr(s7_scheme *sc, s7_pointer expr);
void add_expr(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val;
  val = s7_hash_table_ref(sc, hashes, expr);
  if (val == sc->F)
    {
      if ((!is_closure(expr)) &&
	  (!is_closure_star(expr)))
	s7_hash_table_set(sc, hashes, expr, s7_make_integer(sc, 1));
    }
  else
    {
      s7_hash_table_set(sc, hashes, expr, s7_make_integer(sc, 1 + s7_integer(val)));
    }
}
static void init_hashes(s7_scheme *sc)
{
  hashes = s7_make_hash_table(sc, 65536);
  s7_gc_protect(sc, hashes);
}

typedef struct {
  s7_Int count;
  s7_pointer expr;
} datum;

static datum *new_datum(s7_Int ctr, s7_pointer e)
{
  datum *d;
  d = calloc(1, sizeof(datum));
  d->count = ctr;
  d->expr = e;
  return(d);
}
static int sort_data(const void *v1, const void *v2)
{
  datum *d1 = *(datum **)v1;
  datum *d2 = *(datum **)v2;
  if (d1->count > d2->count)
    return(-1);
  return(1);
}
static void report_counts(s7_scheme *sc)
{
  int len, i, loc = 0, entries;
  s7_pointer *elements;
  datum **data;

  len = hash_table_length(hashes);
  elements = hash_table_elements(hashes);
  entries = hash_table_entries(hashes);
  data = (datum **)calloc(entries, sizeof(datum *));

  for (i = 0; i < len; i++)
    {
      s7_pointer x;
      for (x = elements[i]; is_pair(x); x = cdr(x))
	data[loc++] = new_datum(s7_integer(cdar(x)), caar(x));
    }
  qsort((void *)data, loc, sizeof(datum *), sort_data);
  if (loc > 200) loc = 200;
  for (i = 0; i < loc; i++)
    if (data[i]->count > 0)
      fprintf(stderr, "%lld: %s\n", data[i]->count, DISPLAY_80(data[i]->expr));
}
#endif
#endif



static bool body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer args, s7_pointer body, bool at_end, bool *bad_set);
static s7_pointer (*finder)(s7_scheme *sc, s7_pointer symbol);

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


#define CHECK_METHOD(Sc, Obj, Method, Args)   \
  {                                           \
    s7_pointer func;                          \
    if ((has_methods(Obj)) &&                 \
        ((func = find_method(Sc, find_environment(Sc, Obj), Method)) != Sc->UNDEFINED)) \
      return(s7_apply_function(Sc, func, Args));        \
  }

/* unfortunately, in the simplest cases, where a function (like number?) accepts any argument,
 *   this costs about a factor of 1.5 in speed (we're doing the normal check like s7_is_number,
 *   but then have to check has_methods before returning #f).  We can't use the old form until
 *   open-environment is seen because the prior code might use #_number? which gets the value
 *   before the switch.  These simple functions normally do not dominate timing info, so I'll 
 *   go ahead. It's mostly boilerplate:
 */

#define CHECK_BOOLEAN_METHOD(Sc, Obj, Checker, Method, Args) \
  {                                                          \
    s7_pointer p;                                            \
    p = car(Args);                                           \
    if (Checker(p)) return(Sc->T);                           \
    CHECK_METHOD(Sc, p, Method, Args);                       \
    return(Sc->F);                                           \
  }

/* the old form would be: return(make_boolean(Sc, Checker(car(Args))))
 *
 * has_methods can only be true of c_object, env, closure, so perhaps
 *   an arr[type] opt here?
 */




/* -------------------------------- constants -------------------------------- */

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


bool s7_is_null(s7_scheme *sc, s7_pointer p) 
{
  return(is_null(p));
}


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)) || (val == sc->NO_VALUE));
}


s7_pointer s7_eof_object(s7_scheme *sc)          /* returns #<eof> -- not equivalent to "eof-object?" */
{
  return(sc->EOF_OBJECT);
}


static s7_pointer g_not(s7_scheme *sc, s7_pointer args)
{
  #define H_not "(not obj) returns #t if obj is #f, otherwise #t: (not '()) -> #f"
  return(make_boolean(sc, is_false(sc, car(args))));
}


bool s7_boolean(s7_scheme *sc, s7_pointer x)
{
  return(x != sc->F);
}


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


s7_pointer s7_make_boolean(s7_scheme *sc, bool x)
{
  return(make_boolean(sc, x));
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_boolean, sc->BOOLEANP, args);
}


bool s7_is_constant(s7_pointer p) 
{ 
  /* this means "always evaluates to the same thing", sort of
   *   not "evaluates to itself":
   *   (let ((x 'x)) (and (not (constant? x)) (equal? x (eval x))))
   *   (and (constant? (list + 1)) (not (equal? (list + 1) (eval (list + 1)))))
   */
  return((type(p) != T_SYMBOL) ||
	 ((typeflag(p) & (T_KEYWORD | T_IMMUTABLE)) != 0));
}


static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args)
{
  #define H_is_constant "(constant? obj) returns #t if obj is a constant (unsettable): (constant? pi) -> #t"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_constant, sc->CONSTANTP, args);
}





/* -------------------------------- GC -------------------------------- */

/* instead of saving the last released location, why not have a free list?
 *   (an int array growable, with a current top and size or whatever)
 */

#define is_gc_nil(p) ((p) == sc->GC_NIL)

int s7_gc_protect(s7_scheme *sc, s7_pointer x)
{
  unsigned int i, loc, size, new_size;

  loc = sc->protected_objects_loc++;
  size = sc->protected_objects_size;

  if (sc->protected_objects_loc >= size)
    sc->protected_objects_loc = 0;

  if (is_gc_nil(vector_element(sc->protected_objects, loc)))
    {
      vector_element(sc->protected_objects, loc) = x;
      return(loc);
    }
  
  for (i = 0; i < size; i++)
    {
      if (is_gc_nil(vector_element(sc->protected_objects, i)))
	{
	  vector_element(sc->protected_objects, i) = x;
	  return(i);
	}
    }
  
  new_size = 2 * size;
  vector_elements(sc->protected_objects) = (s7_pointer *)realloc(vector_elements(sc->protected_objects), new_size * sizeof(s7_pointer));
  for (i = size; i < new_size; i++)
    vector_element(sc->protected_objects, i) = sc->GC_NIL;
  vector_length(sc->protected_objects) = new_size;
  sc->protected_objects_size = new_size;
  sc->protected_objects_loc = size + 1;

  vector_element(sc->protected_objects, size) = x;
  return(size);
}


void s7_gc_unprotect(s7_scheme *sc, s7_pointer x)
{
  unsigned int i;

  for (i = 0; i < sc->protected_objects_size; i++)
    if (vector_element(sc->protected_objects, i) == x)
      {
	vector_element(sc->protected_objects, i) = sc->GC_NIL;
	sc->protected_objects_loc = i;
	return;
      }
}


void s7_gc_unprotect_at(s7_scheme *sc, int loc)
{
  if ((loc >= 0) &&
      (loc < (int)sc->protected_objects_size))
    {
#if DEBUGGING
      if (vector_element(sc->protected_objects, loc) == sc->GC_NIL)
	fprintf(stderr, "gc unprotect at %d, but it's already unprotected?\n", loc);
#endif
      vector_element(sc->protected_objects, loc) = sc->GC_NIL;
      sc->protected_objects_loc = loc;
    }
}


s7_pointer s7_gc_protected_at(s7_scheme *sc, int loc)
{
  s7_pointer obj;

  obj = sc->UNSPECIFIED;
  if ((loc >= 0) &&
      (loc < (int)sc->protected_objects_size))
    obj = vector_element(sc->protected_objects, loc);

  if (obj == sc->GC_NIL)
    return(sc->UNSPECIFIED);

  return(obj);
}

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


static void (*mark_function[NUM_TYPES])(s7_pointer p);

static void mark_noop(s7_pointer p)
{
}


static void mark_symbol(s7_pointer p)
{
  if (is_gensym(p))
    set_mark(p);
  /* don't set the mark bit of a normal symbol!  It wrecks the check against T_SYNTACTIC_TYPE,
   *   slowing everything down by a large amount.
   */
}


/* ports can be alloc'd and freed at a frightening pace, so I think I'll make a special free_heap for them.
 */

static s7_port_t *alloc_port(s7_scheme *sc)
{
  if (sc->port_heap_loc > 0)
    return(sc->port_heap[--sc->port_heap_loc]);
  return((s7_port_t *)calloc(1, sizeof(s7_port_t)));
}


static void free_port(s7_scheme *sc, s7_port_t *p)
{
  if (sc->port_heap_loc == sc->port_heap_size)
    {
      if (sc->port_heap_size == 0)
	{
	  sc->port_heap_size = 8;
	  sc->port_heap = (s7_port_t **)malloc(sc->port_heap_size * sizeof(s7_port_t *));
	}
      else
	{
	  sc->port_heap_size *= 2;
	  sc->port_heap = (s7_port_t **)realloc(sc->port_heap, sc->port_heap_size * sizeof(s7_port_t *));
	}
    }
  sc->port_heap[sc->port_heap_loc++] = p;
}


static void sweep(s7_scheme *sc)
{
  int i, j;
  if (sc->strings_loc > 0)
    {
      s7_pointer s1;
      int s2;
      s2 = sc->strings_loc - 2;
      i = 0;
      j = 0;
      while (i <= s2)
	{
	  s1 = sc->strings[i];
	  if (type(s1) == 0)
	    {
	      if (string_needs_free(s1))
		free(string_value(s1));
	    }
	  else sc->strings[j++] = s1;
	  i++;
	  s1 = sc->strings[i];
	  if (type(s1) == 0)
	    {
	      if (string_needs_free(s1))
		free(string_value(s1));
	    }
	  else sc->strings[j++] = s1;
	  i++;
	}
      if (i < sc->strings_loc)
	{
	  s1 = sc->strings[i];
	  if (type(s1) == 0)
	    {
	      if (string_needs_free(s1))
		free(string_value(s1));
	    }
	  else sc->strings[j++] = s1;
	}
      sc->strings_loc = j;
    }

  if (sc->gensyms_loc > 0)
    {
      for (i = 0, j = 0; i < sc->gensyms_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->gensyms[i];
	  if (type(s1) == 0)
	    {
	      remove_from_symbol_table(sc, s1); /* this uses symbol_name_cell data */
	      free(symbol_name(s1));
	      free(symbol_name_cell(s1));
	    }
	  else sc->gensyms[j++] = s1;
	}
      sc->gensyms_loc = j;
      if (j == 0)
	mark_function[T_SYMBOL] = mark_noop;
    }

  if (sc->c_objects_loc > 0)
    {
      for (i = 0, j = 0; i < sc->c_objects_loc; i++)
	{
	  if (type(sc->c_objects[i]) == 0)
	    free_object(sc->c_objects[i]);
	  else sc->c_objects[j++] = sc->c_objects[i];
	}
      sc->c_objects_loc = j;
    }

  if (sc->vectors_loc > 0)
    {
      for (i = 0, j = 0; i < sc->vectors_loc; i++)
	{
	  if (type(sc->vectors[i]) == 0)
	    {
	      s7_pointer a;
	      a = sc->vectors[i];

	      /* a multidimensional empty vector can have dimension info */
	      if (vector_dimension_info(a))
		{
		  if (vector_dimensions_allocated(a))
		    {
		      free(vector_dimensions(a));
		      free(vector_offsets(a));
		    }
		  if (vector_elements_allocated(a))
		    free(vector_elements(a));      /* I think this will work for any vector (int/float too) */
		  free(vector_dimension_info(a));
		}
	      else
		{
		  if (vector_length(a) != 0)
		    free(vector_elements(a));
		}
	    }
	  else sc->vectors[j++] = sc->vectors[i];
	  /* here (in the else branch) if a vector constant in a global function has been removed from the heap,
	   *   heap_location(v) == NOT_IN_HEAP, and we'll never see it freed, so if there were a lot of these, they might
	   *   glom up this loop.  Surely not a big deal!?
	   */
	}
      sc->vectors_loc = j;
    }

  if (sc->hash_tables_loc > 0)
    {
      for (i = 0, j = 0; i < sc->hash_tables_loc; i++)
	{
	  if (type(sc->hash_tables[i]) == 0)
	    {
	      if (hash_table_length(sc->hash_tables[i]) > 0)
		free(hash_table_elements(sc->hash_tables[i]));
	    }
	  else sc->hash_tables[j++] = sc->hash_tables[i];
	}
      sc->hash_tables_loc = j;
    }

  if (sc->input_ports_loc > 0)
    {
      for (i = 0, j = 0; i < sc->input_ports_loc; i++)
	{
	  if (type(sc->input_ports[i]) == 0)
	    {
	      s7_pointer a;
	      a = sc->input_ports[i];
	      if (port_needs_free(a))
		{
		  if (port_string(a))
		    {
		      free(port_string(a));
		      port_string(a) = NULL;
		      port_string_length(a) = 0;
		    }
		  port_needs_free(a) = false;
		}
	      
	      if (port_filename(a))
		{
		  free(port_filename(a));
		  port_filename(a) = NULL;
		}
	      free_port(sc, port_port(a));
	    }
	  else sc->input_ports[j++] = sc->input_ports[i];
	}
      sc->input_ports_loc = j;
    }

  if (sc->output_ports_loc > 0)
    {
      for (i = 0, j = 0; i < sc->output_ports_loc; i++)
	{
	  if (type(sc->output_ports[i]) == 0)
	    {
	      s7_close_output_port(sc, sc->output_ports[i]);
	      free_port(sc, port_port(sc->output_ports[i]));
	    }
	  else sc->output_ports[j++] = sc->output_ports[i];
	}
      sc->output_ports_loc = j;
    }

  if (sc->continuations_loc > 0)
    {
      for (i = 0, j = 0; i < sc->continuations_loc; i++)
	{
	  if (type(sc->continuations[i]) == 0)
	    {
	      s7_pointer c;
	      c = sc->continuations[i];
	      if (continuation_op_stack(c))
		{
		  free(continuation_op_stack(c));
		  continuation_op_stack(c) = NULL;
		}
	      free(continuation_data(c));
	    }
	  else sc->continuations[j++] = sc->continuations[i];
	}
      sc->continuations_loc = j;
    }

#if WITH_GMP
  if (sc->bigints_loc > 0)
    {
      for (i = 0, j = 0; i < sc->bigints_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->bigints[i];
	  if (type(s1) == 0)
	    {
	      mpz_clear(big_integer(s1));
	    }
	  else sc->bigints[j++] = s1;
	}
      sc->bigints_loc = j;
    }

  if (sc->bigratios_loc > 0)
    {
      for (i = 0, j = 0; i < sc->bigratios_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->bigratios[i];
	  if (type(s1) == 0)
	    {
	      mpq_clear(big_ratio(s1));
	    }
	  else sc->bigratios[j++] = s1;
	}
      sc->bigratios_loc = j;
    }

  if (sc->bigreals_loc > 0)
    {
      for (i = 0, j = 0; i < sc->bigreals_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->bigreals[i];
	  if (type(s1) == 0)
	    {
	      mpfr_clear(big_real(s1));
	    }
	  else sc->bigreals[j++] = s1;
	}
      sc->bigreals_loc = j;
    }

  if (sc->bignumbers_loc > 0)
    {
      for (i = 0, j = 0; i < sc->bignumbers_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->bignumbers[i];
	  if (type(s1) == 0)
	    {
	      mpc_clear(big_complex(s1));
	    }
	  else sc->bignumbers[j++] = s1;
	}
      sc->bignumbers_loc = j;
    }
#endif
}


static void add_string(s7_scheme *sc, s7_pointer p)
{
  if (sc->strings_loc == sc->strings_size)
    {
      sc->strings_size *= 2;
      sc->strings = (s7_pointer *)realloc(sc->strings, sc->strings_size * sizeof(s7_pointer));
    }
  sc->strings[sc->strings_loc++] = p;
}


static void add_gensym(s7_scheme *sc, s7_pointer p)
{
  if (sc->gensyms_loc == sc->gensyms_size)
    {
      sc->gensyms_size *= 2;
      sc->gensyms = (s7_pointer *)realloc(sc->gensyms, sc->gensyms_size * sizeof(s7_pointer));
    }
  sc->gensyms[sc->gensyms_loc++] = p;
  mark_function[T_SYMBOL] = mark_symbol;
}


static void add_c_object(s7_scheme *sc, s7_pointer p)
{
  if (sc->c_objects_loc == sc->c_objects_size)
    {
      sc->c_objects_size *= 2;
      sc->c_objects = (s7_pointer *)realloc(sc->c_objects, sc->c_objects_size * sizeof(s7_pointer));
    }
  sc->c_objects[sc->c_objects_loc++] = p;
}


static void add_hash_table(s7_scheme *sc, s7_pointer p)
{
  if (sc->hash_tables_loc == sc->hash_tables_size)
    {
      sc->hash_tables_size *= 2;
      sc->hash_tables = (s7_pointer *)realloc(sc->hash_tables, sc->hash_tables_size * sizeof(s7_pointer));
    }
  sc->hash_tables[sc->hash_tables_loc++] = p;
}


static void add_vector(s7_scheme *sc, s7_pointer p)
{
  if (sc->vectors_loc == sc->vectors_size)
    {
      sc->vectors_size *= 2;
      sc->vectors = (s7_pointer *)realloc(sc->vectors, sc->vectors_size * sizeof(s7_pointer));
    }
  sc->vectors[sc->vectors_loc++] = p;
}


static void add_input_port(s7_scheme *sc, s7_pointer p)
{
  if (sc->input_ports_loc == sc->input_ports_size)
    {
      sc->input_ports_size *= 2;
      sc->input_ports = (s7_pointer *)realloc(sc->input_ports, sc->input_ports_size * sizeof(s7_pointer));
    }
  sc->input_ports[sc->input_ports_loc++] = p;
}


static void add_output_port(s7_scheme *sc, s7_pointer p)
{
  if (sc->output_ports_loc == sc->output_ports_size)
    {
      sc->output_ports_size *= 2;
      sc->output_ports = (s7_pointer *)realloc(sc->output_ports, sc->output_ports_size * sizeof(s7_pointer));
    }
  sc->output_ports[sc->output_ports_loc++] = p;
}


static void add_continuation(s7_scheme *sc, s7_pointer p)
{
  if (sc->continuations_loc == sc->continuations_size)
    {
      sc->continuations_size *= 2;
      sc->continuations = (s7_pointer *)realloc(sc->continuations, sc->continuations_size * sizeof(s7_pointer));
    }
  sc->continuations[sc->continuations_loc++] = p;
}

#if WITH_GMP
static void add_bigint(s7_scheme *sc, s7_pointer p)
{
  if (sc->bigints_loc == sc->bigints_size)
    {
      sc->bigints_size *= 2;
      sc->bigints = (s7_pointer *)realloc(sc->bigints, sc->bigints_size * sizeof(s7_pointer));
    }
  sc->bigints[sc->bigints_loc++] = p;
}


static void add_bigratio(s7_scheme *sc, s7_pointer p)
{
  if (sc->bigratios_loc == sc->bigratios_size)
    {
      sc->bigratios_size *= 2;
      sc->bigratios = (s7_pointer *)realloc(sc->bigratios, sc->bigratios_size * sizeof(s7_pointer));
    }
  sc->bigratios[sc->bigratios_loc++] = p;
}


static void add_bigreal(s7_scheme *sc, s7_pointer p)
{
  if (sc->bigreals_loc == sc->bigreals_size)
    {
      sc->bigreals_size *= 2;
      sc->bigreals = (s7_pointer *)realloc(sc->bigreals, sc->bigreals_size * sizeof(s7_pointer));
    }
  sc->bigreals[sc->bigreals_loc++] = p;
}


static void add_bignumber(s7_scheme *sc, s7_pointer p)
{
  if (sc->bignumbers_loc == sc->bignumbers_size)
    {
      sc->bignumbers_size *= 2;
      sc->bignumbers = (s7_pointer *)realloc(sc->bignumbers, sc->bignumbers_size * sizeof(s7_pointer));
    }
  sc->bignumbers[sc->bignumbers_loc++] = p;
}
#endif



#define INIT_GC_CACHE_SIZE 512
static void init_gc_caches(s7_scheme *sc)
{
  sc->strings_size = INIT_GC_CACHE_SIZE;
  sc->strings_loc = 0;
  sc->strings = (s7_pointer *)malloc(sc->strings_size * sizeof(s7_pointer));
  sc->gensyms_size = INIT_GC_CACHE_SIZE;
  sc->gensyms_loc = 0;
  sc->gensyms = (s7_pointer *)malloc(sc->gensyms_size * sizeof(s7_pointer));
  sc->vectors_size = INIT_GC_CACHE_SIZE;
  sc->vectors_loc = 0;
  sc->vectors = (s7_pointer *)malloc(sc->vectors_size * sizeof(s7_pointer));
  sc->hash_tables_size = INIT_GC_CACHE_SIZE;
  sc->hash_tables_loc = 0;
  sc->hash_tables = (s7_pointer *)malloc(sc->hash_tables_size * sizeof(s7_pointer));
  sc->input_ports_size = INIT_GC_CACHE_SIZE;
  sc->input_ports_loc = 0;
  sc->input_ports = (s7_pointer *)malloc(sc->input_ports_size * sizeof(s7_pointer));
  sc->output_ports_size = INIT_GC_CACHE_SIZE;
  sc->output_ports_loc = 0;
  sc->output_ports = (s7_pointer *)malloc(sc->output_ports_size * sizeof(s7_pointer));
  sc->continuations_size = INIT_GC_CACHE_SIZE;
  sc->continuations_loc = 0;
  sc->continuations = (s7_pointer *)malloc(sc->continuations_size * sizeof(s7_pointer));
  sc->c_objects_size = INIT_GC_CACHE_SIZE;
  sc->c_objects_loc = 0;
  sc->c_objects = (s7_pointer *)malloc(sc->c_objects_size * sizeof(s7_pointer));
#if WITH_GMP
  sc->bigints_size = INIT_GC_CACHE_SIZE;
  sc->bigints_loc = 0;
  sc->bigints = (s7_pointer *)malloc(sc->bigints_size * sizeof(s7_pointer));
  sc->bigratios_size = INIT_GC_CACHE_SIZE;
  sc->bigratios_loc = 0;
  sc->bigratios = (s7_pointer *)malloc(sc->bigratios_size * sizeof(s7_pointer));
  sc->bigreals_size = INIT_GC_CACHE_SIZE;
  sc->bigreals_loc = 0;
  sc->bigreals = (s7_pointer *)malloc(sc->bigreals_size * sizeof(s7_pointer));
  sc->bignumbers_size = INIT_GC_CACHE_SIZE;
  sc->bignumbers_loc = 0;
  sc->bignumbers = (s7_pointer *)malloc(sc->bignumbers_size * sizeof(s7_pointer));
#endif
}


#define S7_MARK(Obj) do {s7_pointer _p_; _p_ = Obj; (*mark_function[type(_p_)])(_p_);} while (0)

static void mark_vector_1(s7_pointer p, s7_Int top)
{
  s7_pointer *tp, *tend, *tend4;

  set_mark(p);

  tp = (s7_pointer *)(vector_elements(p));
  if (!tp) return;
  tend = (s7_pointer *)(tp + top);

  tend4 = (s7_pointer *)(tend - 4);
  while (tp <= tend4)
    {
      S7_MARK(*tp++);
      S7_MARK(*tp++);
      S7_MARK(*tp++);
      S7_MARK(*tp++);
    }

  while (tp < tend) 
    S7_MARK(*tp++);
}


static void mark_environment(s7_pointer env)
{
  s7_pointer x;
  for (x = env; is_environment(x) && (!is_marked(x)); x = next_environment(x)) 
    { 
      s7_pointer y;
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))
	if (!is_marked(y))
	  {
	    set_mark(y);
	    S7_MARK(slot_value(y));
	  }
      set_mark(x);
    }
}


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


static void mark_c_proc(s7_pointer p)
{
  if (!is_marked(p)) /* this is needed since it is remotely possible a function is its own setter(?!?) and otherwise we get an infinite loop */
    {
      set_mark(p);
      S7_MARK(c_function_setter(p));
    }
}


static void mark_pair(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      S7_MARK(car(p));
      S7_MARK(cdr(p));
    }
}

static void mark_slot(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      S7_MARK(slot_value(p));
      /* should this also mark any pending_value? -- currently we don't initialize it.
       *   perhaps a bit if pending_value is in use checked here.  This procedure is not
       *   called very often, but the pending value set happens a lot.
       *   slot_set_pending_value and slot_transfer_pending_value.
       */
    }
}

static void mark_counter(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      S7_MARK(counter_result(p));
      S7_MARK(counter_list(p));
      S7_MARK(counter_environment(p));
    }
}


static void mark_closure(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      S7_MARK(closure_args(p));
      S7_MARK(closure_body(p));
      mark_environment(closure_environment(p));
      S7_MARK(closure_setter(p));
    }
}

static void mark_stack(s7_pointer p)
{
}

static void mark_stack_1(s7_pointer p, s7_Int top)
{
  s7_pointer *tp, *tend;

  set_mark(p);

  tp = (s7_pointer *)(vector_elements(p));
  if (!tp) return;
  tend = (s7_pointer *)(tp + top);
  
  while (tp < tend) 
    {
      S7_MARK(*tp++);
      S7_MARK(*tp++);
      S7_MARK(*tp++);
      tp++;
    }
}


static void mark_continuation(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      unsigned int i;
      set_mark(p);
      mark_stack_1(continuation_stack(p), continuation_stack_top(p));
      for (i = 0; i < continuation_op_loc(p); i++)
	S7_MARK(continuation_op_stack(p)[i]);
    }
}

static void mark_vector(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      /* If a subvector (an inner dimension) of a vector is the only remaining reference
       *    to the main vector, we want to make sure the main vector is not GC'd until
       *    the subvector is also GC-able.  The shared_vector 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 ((vector_is_multidimensional(p)) &&
	  (s7_is_vector(shared_vector(p))))
	{
	  /* set_mark(shared_vector(p)); */
	  S7_MARK(shared_vector(p));
	}
      mark_vector_1(p, vector_length(p));
    }
}

static void mark_c_object(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      mark_embedded_objects(p);
    }
}

static void mark_catch(s7_pointer p)
{
  if (!is_marked(p))
    {
      set_mark(p);
      S7_MARK(catch_tag(p));
      S7_MARK(catch_handler(p));
    }
}

static void mark_dynamic_wind(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      S7_MARK(dynamic_wind_in(p));
      S7_MARK(dynamic_wind_out(p));
      S7_MARK(dynamic_wind_body(p));
    }
}


static void mark_hash_table(s7_pointer p)
{
  if (!is_marked(p))
    {
      set_mark(p);
      if (hash_table_entries(p) > 0)
	{
	  s7_pointer *tp, *tend;
	  tp = (s7_pointer *)(hash_table_elements(p));
	  tend = (s7_pointer *)(tp + hash_table_length(p));
	  while (tp < tend)
	    {
	      if (is_pair(*tp))
		mark_pair(*tp);
	      tp++;
	    }
	}
    }
}


static void mark_input_port(s7_pointer p)
{
  if (!is_marked(p)) 
    {
      set_mark(p);
      set_mark(port_original_input_string(p));
    }
}


static void init_mark_functions(void)
{
  mark_function[T_FREE]                = mark_noop;
  mark_function[T_UNIQUE]              = just_mark;
  mark_function[T_NIL]                 = mark_noop;
  mark_function[T_STRING]              = just_mark;
  mark_function[T_INTEGER]             = just_mark;
  mark_function[T_RATIO]               = just_mark;
  mark_function[T_REAL]                = just_mark;
  mark_function[T_COMPLEX]             = just_mark;
  mark_function[T_BIG_INTEGER]         = just_mark;
  mark_function[T_BIG_RATIO]           = just_mark;
  mark_function[T_BIG_REAL]            = just_mark;
  mark_function[T_BIG_COMPLEX]         = just_mark;
  mark_function[T_SYMBOL]              = mark_noop; /* this changes to mark_symbol when gensyms are in the heap */
  mark_function[T_PAIR]                = mark_pair;
  mark_function[T_CLOSURE]             = mark_closure;
  mark_function[T_CLOSURE_STAR]        = mark_closure;
  mark_function[T_CONTINUATION]        = mark_continuation;
  mark_function[T_CHARACTER]           = mark_noop;
  mark_function[T_INPUT_PORT]          = mark_input_port;
  mark_function[T_VECTOR]              = mark_vector;
  mark_function[T_INT_VECTOR]          = just_mark;
  mark_function[T_FLOAT_VECTOR]        = just_mark;
  mark_function[T_MACRO]               = mark_closure;
  mark_function[T_BACRO]               = mark_closure;
  mark_function[T_C_OBJECT]            = mark_c_object;
  mark_function[T_GOTO]                = just_mark;
  mark_function[T_OUTPUT_PORT]         = just_mark;
  mark_function[T_CATCH]               = mark_catch;
  mark_function[T_DYNAMIC_WIND]        = mark_dynamic_wind;
  mark_function[T_HASH_TABLE]          = mark_hash_table;
  mark_function[T_BOOLEAN]             = mark_noop;
  mark_function[T_SYNTAX]              = mark_noop;
  mark_function[T_ENVIRONMENT]         = mark_environment;
  mark_function[T_STACK]               = mark_stack;
  mark_function[T_COUNTER]             = mark_counter;
  mark_function[T_SLOT]                = mark_slot;
  mark_function[T_BAFFLE]              = just_mark;
  mark_function[T_C_MACRO]             = just_mark;
  mark_function[T_C_POINTER]           = just_mark;
  mark_function[T_C_FUNCTION]          = just_mark;  /* these change if needed to mark_c_proc when setter is a scheme function */
  mark_function[T_C_ANY_ARGS_FUNCTION] = just_mark;
  mark_function[T_C_OPT_ARGS_FUNCTION] = just_mark;
  mark_function[T_C_RST_ARGS_FUNCTION] = just_mark;
  mark_function[T_C_LST_ARGS_FUNCTION] = just_mark;
}


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


static void mark_global_env(s7_scheme *sc)
{
  s7_pointer ge;
  s7_pointer *tmp, *top;

  ge = sc->global_env;
  tmp = vector_elements(ge);
  top = (s7_pointer *)(tmp + sc->global_env_entries);

  set_mark(ge);

  while (tmp < top)
    S7_MARK(slot_value(*tmp++));
}


void s7_mark_object(s7_pointer p)
{
  S7_MARK(p);
}

#define GC_TRIGGER_SIZE 64


#ifndef _MSC_VER
  #include <time.h>
  #include <sys/time.h>
  static struct timeval start_time;
  static struct timezone z0;
#endif

static int gc(s7_scheme *sc)
{
  s7_cell **old_free_heap_top;
  /* mark all live objects (the symbol table is in permanent memory, not the heap) */
  #define GC_CALL(P, Tp) p = (*tp++); if (is_marked(p)) clear_mark(p); else {if (typeflag(p) != 0) {typeflag(p) = 0; (*fp++) = p;}}

  if (sc->gc_stats)
    {
      fprintf(stdout, "gc ");
#ifndef _MSC_VER
      /* this is apparently deprecated in favor of clock_gettime -- what compile-time switch to use here?
       */
      gettimeofday(&start_time, &z0);
#endif
    }

  mark_global_env(sc);
  S7_MARK(sc->args);
  mark_environment(sc->envir);
  mark_environment(sc->error_env);
  S7_MARK(sc->code);
  S7_MARK(sc->cur_code);
  mark_stack_1(sc->stack, s7_stack_top(sc));
  S7_MARK(sc->v);
  S7_MARK(sc->w);
  S7_MARK(sc->x);
  S7_MARK(sc->y);
  S7_MARK(sc->z);
  S7_MARK(sc->value);  

  S7_MARK(sc->temp1);
  S7_MARK(sc->temp2);
  S7_MARK(sc->temp3);
  S7_MARK(sc->temp4);

  set_mark(sc->input_port);
  S7_MARK(sc->input_port_stack);
  set_mark(sc->output_port);
  set_mark(sc->error_port);

  mark_pair(sc->temp_cell_1);
  mark_pair(sc->temp_cell_2);
  mark_pair(sc->temp_cell_3);
  mark_pair(sc->temp_cell_4);
  S7_MARK(car(sc->T1_1));
  S7_MARK(car(sc->T2_1));
  S7_MARK(car(sc->T2_2));
  S7_MARK(car(sc->T3_1));
  S7_MARK(car(sc->T3_2));
  S7_MARK(car(sc->T3_3));

  S7_MARK(car(sc->A4_1));
  S7_MARK(car(sc->A4_2));
  S7_MARK(car(sc->A4_3));
  S7_MARK(car(sc->A4_4));
  {
    int i;
    s7_pointer p;
    for (i = 1; i < NUM_SAFE_LISTS; i++)
      for (p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
	S7_MARK(car(p));
  }
	

  S7_MARK(sc->protected_objects);
  
  /* now 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.
   *
   * There's one remaining possible problem.  s7_remove_from_heap frees cells outside
   *   the GC and might push free_heap_top beyond its previous_free_heap_top, then
   *   an immediate explicit gc call might not see those temp cells.
   */
  {
    s7_pointer *tmps, *tmps_top;

    tmps = sc->free_heap_top;
    tmps_top = tmps + GC_TEMPS_SIZE;
    if (tmps_top > sc->previous_free_heap_top)
      tmps_top = sc->previous_free_heap_top;

    while (tmps < tmps_top)
      S7_MARK(*tmps++);
  }
  mark_op_stack(sc);

  /* free up all unmarked objects */
  old_free_heap_top = sc->free_heap_top;

  {
    s7_pointer *fp, *tp, *heap_top;
    fp = sc->free_heap_top;

    tp = sc->heap;
    heap_top = (s7_pointer *)(sc->heap + sc->heap_size);

    while (tp < heap_top)          /* != here or ^ makes no difference */
      {
	s7_pointer p;
	/* from here down is GC_CALL, but I wanted one case explicit for readability
	 */
	p = (*tp++);

	if (is_marked(p))          /* this order is faster than checking typeflag(p) != 0 first */
	  clear_mark(p);
	else 
	  {
	    if (typeflag(p) != 0) /* if 0, it's an already-free object -- the free_heap is usually not empty when we call the GC */
	      {
#if DEBUGGING
		p->debugger_bits = 0;
#endif
		typeflag(p) = 0;  /* (this is needed -- otherwise we try to free some objects twice) */
		(*fp++) = p;
	      }
	  }

	/* this looks crazy, but it speeds up the entire GC process by 25%!
	 *   going from 16 to 32 saves .2% so it may not matter.
	 */
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);

	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
	GC_CALL(p, tp);
      }
    
    sc->free_heap_top = fp;
    sweep(sc);
  }

  if (sc->gc_stats)
    {
#ifndef _MSC_VER
      struct timeval t0;
      double secs;
      gettimeofday(&t0, &z0);
      secs = (t0.tv_sec - start_time.tv_sec) +  0.000001 * (t0.tv_usec - start_time.tv_usec);
      fprintf(stdout, "freed %d/%d, time: %f\n", (int)(sc->free_heap_top - old_free_heap_top), sc->heap_size, secs);
#else
      fprintf(stdout, "freed %d/%d\n", (int)(sc->free_heap_top - old_free_heap_top), sc->heap_size);
#endif
    }
  
  sc->previous_free_heap_top = sc->free_heap_top;
  return(sc->free_heap_top - old_free_heap_top); /* needed by cell allocator to decide when to increase heap size */
}


#define WITH_DUMP_HEAP 0
#if WITH_DUMP_HEAP
static s7_pointer g_dump_heap(s7_scheme *sc, s7_pointer args)
{
  FILE *fd;
  s7_pointer *tp;
  int i;

  gc(sc);

  fd = fopen("heap.data", "w");
  for (tp = sc->heap; (*tp); tp++)
    {
      s7_pointer p;
      p = (*tp);
      if (typeflag(p) != 0)
	fprintf(fd, "%s\n", s7_object_to_c_string(sc, p));
    }

  fflush(fd);
  fclose(fd);
  return(sc->NIL);
}
#endif


#define NEW_CELL(Sc, Obj) \
  do {						\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
    Obj = (*(--(Sc->free_heap_top))); \
    } while (0)

#define NEW_CELL_NO_CHECK(Sc, Obj) do {Obj = (*(--(Sc->free_heap_top)));} 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.
   */


static void try_to_call_gc(s7_scheme *sc)
{
  /* called only from NEW_CELL and cons */
  unsigned int freed_heap = 0;
  
  if (sc->gc_off) return;

  freed_heap = gc(sc);
  if ((freed_heap < sc->heap_size / 2) &&
      (freed_heap < 1000000)) /* if huge heap */
    {
      /* alloc more heap */
      unsigned int old_size, old_free;
      old_size = sc->heap_size;

      old_free = sc->free_heap_top - sc->free_heap;
      if (sc->heap_size < 512000)
	sc->heap_size *= 2;
      else sc->heap_size += 512000;

      sc->heap = (s7_cell **)realloc(sc->heap, sc->heap_size * sizeof(s7_cell *));
      if (!(sc->heap))
	fprintf(stderr, "heap reallocation failed! tried to get %lu bytes\n", (unsigned long)(sc->heap_size * sizeof(s7_cell *)));
      
      sc->free_heap = (s7_cell **)realloc(sc->free_heap, sc->heap_size * sizeof(s7_cell *));
      if (!(sc->free_heap))
	fprintf(stderr, "free heap reallocation failed! tried to get %lu bytes\n", (unsigned long)(sc->heap_size * sizeof(s7_cell *)));	  
      
      sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE);
      sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */

      { 
	/* optimization suggested by K Matheussen */
	unsigned int k;
	s7_cell *cells;
	cells = (s7_cell *)calloc(sc->heap_size - old_size, sizeof(s7_cell));
	for (k = old_size; k < sc->heap_size; k++)
	  {
	    sc->heap[k] = &cells[k - old_size];
	    (*sc->free_heap_top++) = sc->heap[k];
	    heap_location(sc->heap[k]) = k;
	  }
	sc->previous_free_heap_top = sc->free_heap_top;
      }
    }
}

  /* 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' 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!"

  if (is_not_null(args))
    {
      if (!s7_is_boolean(car(args)))
	return(simple_wrong_type_argument_with_type(sc, sc->GC, car(args), make_protected_string(sc, "#f (turn GC off) or #t (turn it on)")));

      sc->gc_off = (car(args) == sc->F);
      if (sc->gc_off) 
	return(sc->F);
    }

  gc(sc);
  return(sc->UNSPECIFIED);
}


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


static s7_pointer g_gc_stats_set(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_boolean(cadr(args)))
    {
      sc->gc_stats = (cadr(args) != sc->F);      
      return(cadr(args));
    }
  return(sc->ERROR);
}


void s7_gc_stats(s7_scheme *sc, bool on)
{
  sc->gc_stats = on;
  s7_symbol_set_value(sc, sc->GC_STATS, make_boolean(sc, on));
}


static s7_pointer g_safety_set(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_integer(cadr(args)))
    {
      sc->safety = s7_integer(cadr(args));
      return(cadr(args));
    }
  return(sc->ERROR);
}


static s7_pointer g_safety_bind(s7_scheme *sc, s7_pointer args)
{
  return(sc->ERROR);
}


static s7_cell *alloc_pointer(void)
{
  #define ALLOC_SIZE 256
  static unsigned int alloc_k = ALLOC_SIZE;
  static s7_cell *alloc_cells = NULL;

  if (alloc_k == ALLOC_SIZE)
    {
      alloc_cells = (s7_cell *)calloc(ALLOC_SIZE, sizeof(s7_cell));
      alloc_k = 0;
    }
  return(&alloc_cells[alloc_k++]);
}


void s7_remove_from_heap(s7_scheme *sc, s7_pointer x)
{
  int loc;
  s7_pointer p;

  /* global functions are very rarely redefined, so we can remove the function body from
   *   the heap when it is defined.  If redefined, we currently lose the memory held by the
   *   old definition.  (It is not trivial to recover this memory because it is allocated
   *   in blocks, not by the pointer, I think, but s7_define is the point to try).
   * 
   * There is at least one problem with this: if, for example, a function has
   *    a quoted (constant) list, then uses list-set! to change an element of it,
   *    then a GC happens, and the new element is GC'd because no one in the heap
   *    points to it, then we call the function again, and it tries to access
   *    that element.  I wonder if removal should be on a switch, so the user can
   *    choose a "safety" level.
   *
   *    (define (bad-idea)
   *      (let ((lst '(1 2 3))) ; or #(1 2 3) and vector-ref|set
   *        (let ((result (list-ref lst 1)))
   *          (list-set! lst 1 (* 2.0 16.6))
   *          (gc)
   *          result)))
   * 
   *     put that in a file, load it (to force removal), than call bad-idea a few times.
   * so... if *safety* is not 0, remove-from-heap is disabled.
   */

  /* (catch #t (lambda () (set! *safety* "hi")) (lambda args args)) */

  loc = heap_location(x); /* punned to syntax_opcode... is this necessary? */
  if (loc == NOT_IN_HEAP) return;

  switch (type(x))
    {
    case T_PAIR:
      heap_location(x) = NOT_IN_HEAP;
      p = alloc_pointer();
      typeflag(p) = 0;
      sc->heap[loc] = p;
      (*sc->free_heap_top++) = p;
      heap_location(p) = loc;

      s7_remove_from_heap(sc, car(x));
      s7_remove_from_heap(sc, cdr(x));
      return;


    case T_VECTOR:
      {
	s7_Int i;
	/* this can happen if a global function has an explicit vector constant.  (The vector remains in the sc->vectors
	 *    array forever -- also in the gensym case below).
	 */
	heap_location(x) = NOT_IN_HEAP;
	sc->heap[loc] = alloc_pointer();
	(*sc->free_heap_top++) = sc->heap[loc];
	heap_location(sc->heap[loc]) = loc;

	if ((!vector_is_multidimensional(x)) ||
	    (shared_vector(x) == sc->F))
	  {
	    for (i = 0; i < vector_length(x); i++)
	      s7_remove_from_heap(sc, vector_element(x, i));
	  }
      }
      return;

    case T_HASH_TABLE:
    case T_ENVIRONMENT:
      return;

    case T_SYMBOL:
      if (is_gensym(x))
	{
	  sc->heap[loc] = alloc_pointer();
	  (*sc->free_heap_top++) = sc->heap[loc];
	  heap_location(sc->heap[loc]) = loc;
	  clear_gensym(x);
	  heap_location(x) = NOT_IN_HEAP;
	}
      return;

    case T_SYNTAX:
      /* here hloc is usually NOT_IN_HEAP, but in the syntax case can be the syntax op code.
       */
      return;

    case T_CLOSURE:
    case T_CLOSURE_STAR:
    case T_MACRO:
    case T_BACRO:
      heap_location(x) = NOT_IN_HEAP;
      p = alloc_pointer();
      typeflag(p) = 0;
      sc->heap[loc] = p;
      (*sc->free_heap_top++) = p;
      heap_location(p) = loc;

      s7_remove_from_heap(sc, closure_args(x));
      s7_remove_from_heap(sc, closure_body(x));
      return;

    default:
      break;
    }

  heap_location(x) = NOT_IN_HEAP;
  p = alloc_pointer();
  typeflag(p) = 0;
  sc->heap[loc] = p;
  (*sc->free_heap_top++) = p;
  heap_location(p) = loc;
}



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

#define OP_STACK_INITIAL_SIZE 128
#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op
#define pop_op_stack(Sc)      (*(--(Sc->op_stack_now)))

static void initialize_op_stack(s7_scheme *sc)
{
  int i;
  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 (i = 0; i < OP_STACK_INITIAL_SIZE; i++)
    sc->op_stack[i] = sc->NIL;
}


static void resize_op_stack(s7_scheme *sc)
{
  int i, loc, new_size;
  loc = (int)(sc->op_stack_now - sc->op_stack);
  new_size = sc->op_stack_size * 2;
  sc->op_stack = (s7_pointer *)realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer));
  for (i = sc->op_stack_size; i < new_size; i++)
    sc->op_stack[i] = sc->NIL;
  sc->op_stack_size = new_size;
  sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc);
  sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
}


#define stack_code(Stack, Loc)        vector_element(Stack, Loc - 3)
#define stack_environment(Stack, Loc) vector_element(Stack, Loc - 2)
#define stack_args(Stack, Loc)        vector_element(Stack, Loc - 1)
#define stack_op(Stack, Loc)          ((opcode_t)(vector_element(Stack, Loc)))

/* these macros are faster than the equivalent simple function calls.  If the s7_scheme struct is set up to reflect the
 *    stack order [code envir args op], we can use memcpy here: 
 *      #define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
 *    but it is only slightly faster (.2% at best)!
 */

#define pop_stack(Sc) \
  do { \
      Sc->stack_end -= 4; \
      Sc->code =  Sc->stack_end[0]; \
      Sc->envir = Sc->stack_end[1]; \
      Sc->args =  Sc->stack_end[2]; \
      Sc->op =    (opcode_t)(Sc->stack_end[3]); \
  } while (0)

#define pop_stack_no_op(Sc) \
  do { \
      Sc->stack_end -= 4; \
      Sc->code =  Sc->stack_end[0]; \
      Sc->envir = Sc->stack_end[1]; \
      Sc->args =  Sc->stack_end[2]; \
  } while (0)

#define push_stack(Sc, Op, Args, Code) \
  do { \
      Sc->stack_end[0] = Code; \
      Sc->stack_end[1] = Sc->envir; \
      Sc->stack_end[2] = Args; \
      Sc->stack_end[3] = (s7_pointer)Op; \
      Sc->stack_end += 4; \
  } while (0)

/* next is used in reader, envir is needed */
#define push_stack_no_code(Sc, Op, Args) \
  do { \
      Sc->stack_end[1] = Sc->envir; \
      Sc->stack_end[2] = Args; \
      Sc->stack_end[3] = (s7_pointer)Op; \
      Sc->stack_end += 4; \
  } while (0)

#define push_stack_no_args(Sc, Op, Code) \
  do { \
      Sc->stack_end[0] = Code; \
      Sc->stack_end[1] = Sc->envir; \
      Sc->stack_end[3] = (s7_pointer)Op; \
      Sc->stack_end += 4; \
  } while (0)


#define main_stack_op(Sc)             ((opcode_t)(Sc->stack_end[-1]))
#define main_stack_args(Sc)           (Sc->stack_end[-2])
#define main_stack_environment(Sc)    (Sc->stack_end[-3])
#define main_stack_code(Sc)           (Sc->stack_end[-4])
#define pop_main_stack(Sc)            Sc->stack_end -= 4

#define IF_BEGIN_POP_STACK(Sc) do {if (main_stack_op(Sc) == OP_BEGIN1) goto POP_BEGIN; goto START;} while (0)
#define IF_BEGIN_POP_STACK_ELSE_SET_VALUE(Sc, Sym) do {if (main_stack_op(Sc) == OP_BEGIN1) goto POP_BEGIN; sc->value = slot_value(Sym); goto START;} while (0)


static void stack_reset(s7_scheme *sc) 
{ 
  sc->stack_end = sc->stack_start;
  push_stack(sc, OP_BARRIER, sc->NIL, sc->NIL);
} 


static void increase_stack_size(s7_scheme *sc)
{
  int i, new_size, loc;

  loc = s7_stack_top(sc);
  new_size = sc->stack_size * 2;

  vector_elements(sc->stack) = (s7_pointer *)realloc(vector_elements(sc->stack), new_size * sizeof(s7_pointer));
  for (i = sc->stack_size; i < new_size; i++)
    vector_element(sc->stack, i) = sc->NIL;
  vector_length(sc->stack) = new_size;
  sc->stack_size = new_size;

  sc->stack_start = vector_elements(sc->stack);
  sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
  sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + sc->stack_size / 2);
} 

#define CHECK_STACK_SIZE(Sc) \
  if (Sc->stack_end >= Sc->stack_resize_trigger) \
    { \
      if ((Sc->begin_hook) && (call_begin_hook(Sc))) return(Sc->F); \
      increase_stack_size(Sc); \
    }  


static s7_pointer g_stack_top(s7_scheme *sc, s7_pointer args)
{
  return(s7_make_integer(sc, (sc->stack_end - sc->stack_start) / 4));
}

#if 0
static s7_pointer g_stack(s7_scheme *sc, s7_pointer args)
{
  int loc;
  /* if this is ever exported, check here for wrong type arg */
  loc = (int)(s7_integer(car(args)) + 1) * 4 - 1;
  /* stack op is not a valid s7_pointer (it's the op enum), and args can be invalid
   *   since it is not always set and might have been gc'd previously.
   */
  return(list_2(sc, stack_code(sc->stack, loc), stack_environment(sc->stack, loc)));
}
#endif




/* -------------------------------- symbols -------------------------------- */

#define HASH_MULT 4

static int symbol_table_hash(const char *key) 
{ 
  unsigned int hashed = 0;
  const char *c; 
  for (c = key; *c; c++) 
    hashed = *c + hashed * HASH_MULT;
  return(hashed % SYMBOL_TABLE_SIZE); 
  /* using ints here is much faster, and the symbol table will not be enormous, so it's worth splitting out this case */
} 


static s7_pointer make_symbol(s7_scheme *sc, const char *name);

static s7_pointer new_symbol(s7_scheme *sc, const char *name, int location) 
{ 
  s7_pointer x, str; 

  str = s7_make_permanent_string(name);
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  symbol_name_cell(x) = str;
  set_type(x, T_SYMBOL);
  global_slot(x) = sc->UNDEFINED; /* was sc->NIL; */
  initial_slot(x) = sc->UNDEFINED;
  symbol_set_local(x, 0LL, sc->NIL);
  symbol_accessor(x) = -1;

  if (symbol_name_length(x) > 1)                           /* not 0, otherwise : is a keyword */
    {
      if (name[0] == ':')
	{
	  typeflag(x) |= (T_IMMUTABLE | T_KEYWORD); 
	  keyword_symbol(x) = make_symbol(sc, (char *)(name + 1));
	  global_slot(x) = s7_make_slot(sc, sc->NIL, x, x);
	}
      else
	{
	  char c;
	  c = name[symbol_name_length(x) - 1];
	  if (c == ':')
	    {
	      char *str;
	      str = (char *)malloc(symbol_name_length(x) * sizeof(char));
	      str[symbol_name_length(x) - 1] = 0;
	      memcpy((void *)str, (void *)name, symbol_name_length(x) - 1);
	      typeflag(x) |= (T_IMMUTABLE | T_KEYWORD); 
	      keyword_symbol(x) = make_symbol(sc, str);
	      global_slot(x) = s7_make_slot(sc, sc->NIL, x, x);
	      free(str);
	    }
	}
    }

  vector_element(sc->symbol_table, location) = permanent_cons(x, vector_element(sc->symbol_table, location), 
							      T_PAIR | T_IMMUTABLE);
  return(x); 
} 


static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, int location) 
{ 
  s7_pointer x; 
  for (x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x)) 
    { 
      const char *s; 
      s = symbol_name(car(x)); 
      if ((s) && (*s == *name) && (strings_are_equal(name, s)))
	return(car(x)); 
    }
  return(sc->NIL); 
} 


static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_table "(symbol-table) returns the s7 symbol table (a vector)"

  /* this is trouble -- we can't protect it by copying its vector elements into an s7 vector
   *   because the symbol-table is outside the gc's protection!  Not sure now what to do --
   *   maybe copy every list?!?
   */
  return(sc->symbol_table);
}


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?
   */
  int i; 
  s7_pointer x; 

  for (i = 0; i < vector_length(sc->symbol_table); i++) 
    for (x  = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) 
      if (symbol_func(symbol_name(car(x)), data))
	return(true);

  return((symbol_func("#t", data))             ||
	 (symbol_func("#f", data))             ||
	 (symbol_func("#<unspecified>", data)) ||
	 (symbol_func("#<undefined>", data))   ||
	 (symbol_func("#<eof>", data))         ||
	 (symbol_func("#true", data))          ||
	 (symbol_func("#false", data))); /* these 2 for r7rs */
}


bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, s7_pointer value, void *data), void *data)
{
  int i; 
  s7_pointer x; 

  for (i = 0; i < vector_length(sc->symbol_table); i++) 
    for (x  = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) 
      if (symbol_func(symbol_name(car(x)), cdr(x), data))
	return(true);

  return(false);
}

/* (for-each
   (lambda (lst)
      (for-each
         (lambda (sym)
            (format #t "~A ~S~%" sym (symbol->value sym)))
         lst))
   (symbol-table))
   
   at normal motif-snd startup there are 5699 globals (2583 of them constant), and 411 other undefined symbols
*/


static s7_pointer g_symbol_table_is_locked(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_table_is_locked "set (-s7-symbol-table-locked?) to #t to prohibit the creation of any new symbols"
  return(make_boolean(sc, sc->symbol_table_is_locked));
}


static s7_pointer g_set_symbol_table_is_locked(s7_scheme *sc, s7_pointer args)
{
  sc->symbol_table_is_locked = (car(args) != sc->F);
  return(car(args));
}


static s7_pointer make_symbol(s7_scheme *sc, const char *name) 
{
  s7_pointer x; 
  int location;

  location = symbol_table_hash(name); 
  x = symbol_table_find_by_name(sc, name, location); 
  if (is_not_null(x)) 
    return(x); 

  if (sc->symbol_table_is_locked)
    return(s7_error(sc, sc->ERROR, sc->NIL));

  x = new_symbol(sc, name, location); 
  symbol_hash(x) = location;
  return(x);
} 


s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) 
{ 
  if (!name) return(sc->F);
  return(make_symbol(sc, name));
}


s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name)
{
  int location;
  s7_pointer result;
  location = symbol_table_hash(name); 
  result = symbol_table_find_by_name(sc, name, location); 
  if (is_null(result))
    return(NULL);
  return(result);
}


static void remove_from_symbol_table(s7_scheme *sc, s7_pointer sym)
{
  unsigned int loc;
  s7_pointer x, y; 

  loc = symbol_hash(sym);
  x = vector_element(sc->symbol_table, loc);
  if (car(x) == sym)
    {
      vector_element(sc->symbol_table, loc) = cdr(x);
      free(x);
    }
  else
    {
      for (y = x, x = cdr(x); is_not_null(x); y = x, x = cdr(x))
	{
	  if (car(x) == sym)
	    {
	      cdr(y) = cdr(x);
	      free(x);
	      break;
	    }
	}
    }
}


s7_pointer s7_gensym(s7_scheme *sc, const char *prefix)
{ 
  char *name;
  int len, location;
  s7_pointer x;
  
  len = safe_strlen(prefix) + 32;
  name = (char *)calloc(len, sizeof(char));
  /* there's no point in heroic efforts here to avoid name collisions --
   *    the user can screw up no matter what we do.
   */
  snprintf(name, len, "{%s}-%d", prefix, sc->gensym_counter++); 
  location = symbol_table_hash(name); 
  x = new_symbol(sc, name, location);  /* not T_GENSYM -- might be called from outside */
  symbol_hash(x) = location;
  free(name);
  return(x); 
} 


/* should there be a built-in gensym? function?  I can't think of a use for it.
 */
static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) 
{
  #define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol"

  const char *prefix;
  char *name;
  int len, location;
  s7_pointer x, str, stc;

  /* get symbol name */
  if (is_not_null(args))
    {
      if (!is_string(car(args)))
	{
	  CHECK_METHOD(sc, car(args), sc->GENSYM, args);
	  return(simple_wrong_type_argument(sc, sc->GENSYM, car(args), T_STRING));
	}
      prefix = string_value(car(args));
    }
  else prefix = "gensym";
  len = safe_strlen(prefix) + 32;
  name = (char *)calloc(len, sizeof(char));
  snprintf(name, len, "{%s}-%d", prefix, sc->gensym_counter++); 
  location = symbol_table_hash(name); 
      
  /* make-string for symbol name */
  str = (s7_cell *)calloc(1, sizeof(s7_cell));
  heap_location(str) = NOT_IN_HEAP;
  set_type(str, T_STRING | T_IMMUTABLE);
  string_length(str) = safe_strlen(name);
  string_value(str) = name;
  string_needs_free(str) = false;

  /* allocate the symbol in the heap so GC'd when inaccessible */
  NEW_CELL(sc, x);
  symbol_name_cell(x) = str;
  set_type(x, T_SYMBOL | T_GENSYM);
  global_slot(x) = sc->NIL;
  initial_slot(x) = sc->UNDEFINED;
  symbol_set_local(x, 0LL, sc->NIL);
  symbol_accessor(x) = -1;
  symbol_hash(x) = location;

  /* place new symbol in symbol-table, but using calloc so we can easily free it (remove it from the table) in GC sweep */
  stc = (s7_cell *)calloc(1, sizeof(s7_cell));
  heap_location(stc) = NOT_IN_HEAP;
  car(stc) = x;
  set_type(stc, T_PAIR | T_IMMUTABLE);
  cdr(stc) = vector_element(sc->symbol_table, location);
  vector_element(sc->symbol_table, location) = stc;

  add_gensym(sc, x);
  return(x); 
}


s7_pointer s7_name_to_value(s7_scheme *sc, const char *name)
{
  return(s7_symbol_value(sc, make_symbol(sc, name)));
}


bool s7_is_symbol(s7_pointer p)   
{ 
  return(is_symbol(p));
}


bool s7_is_syntax(s7_pointer p)   
{ 
  return(is_syntax(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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_symbol, sc->SYMBOLP, args);
}


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


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"
  s7_pointer sym;

  sym = car(args);
  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->SYMBOL_TO_STRING, args);
      return(simple_wrong_type_argument(sc, sc->SYMBOL_TO_STRING, sym, T_SYMBOL));
    }
  /* s7_make_string uses strlen which stops at an embedded null
   */
  return(s7_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));    /* return a copy */
}

static s7_pointer symbol_to_string_uncopied;
static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym, x;

  sym = car(args);
  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->SYMBOL_TO_STRING, args);
      return(simple_wrong_type_argument(sc, sc->SYMBOL_TO_STRING, sym, T_SYMBOL));
    }
  x = make_string_uncopied_with_length(sc, symbol_name(sym), symbol_name_length(sym)); 
  string_needs_free(x) = false;
  return(x);
}



static s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
  s7_pointer str;
  str = car(args);

  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sym, args);
      return(simple_wrong_type_argument(sc, sym, str, T_STRING));
    }
  /* currently if the string has an embedded null, it marks the end of the new symbol name.
   *   I wonder if this is a bug...
   */
  return(make_symbol(sc, string_value(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"
  return(g_string_to_symbol_1(sc, args, sc->STRING_TO_SYMBOL));
}


static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol "(symbol str) returns the string str converted to a symbol"
  return(g_string_to_symbol_1(sc, args, sc->SYMBOL));
}





/* -------------------------------- environments -------------------------------- */

static unsigned long long int environment_number = 0;

#define NEW_FRAME(Sc, Old_Env, New_Env)  \
  do {                                   \
      s7_pointer _x_;                      \
      NEW_CELL(Sc, _x_);                   \
      environment_id(_x_) = ++environment_number; \
      environment_slots(_x_) = Sc->NIL;                  \
      next_environment(_x_) = Old_Env;		         \
      set_type(_x_, T_ENVIRONMENT | T_IMMUTABLE); \
      New_Env = _x_;		   \
     } while (0)


static s7_pointer new_frame_in_env(s7_scheme *sc, s7_pointer old_env) 
{ 
  /* return(cons(sc, sc->NIL, old_env)); */
  s7_pointer x;
  NEW_CELL(sc, x);
  environment_id(x) = ++environment_number;
  environment_slots(x) = sc->NIL;
  next_environment(x) = old_env;
  set_type(x, T_ENVIRONMENT | T_IMMUTABLE);
  return(x);
} 


static s7_pointer make_simple_environment(s7_scheme *sc)
{
  s7_pointer frame;
  NEW_CELL(sc, frame);
  environment_id(frame) = environment_number + 1;
  environment_slots(frame) = sc->NIL;
  next_environment(frame) = sc->envir;
  set_type(frame, T_ENVIRONMENT | T_IMMUTABLE);
  return(frame);
}


/* in all these macros, symbol_set_local should follow slot_set_value so that we can evaluate the
 *    slot's value in its old state.
 */
#define ADD_SLOT(Frame, Symbol, Value) \
  do { \
    s7_pointer _slot_, _sym_;			\
    _sym_ = Symbol; \
    NEW_CELL_NO_CHECK(sc, _slot_);\
    slot_symbol(_slot_) = _sym_;\
    slot_set_value(_slot_, Value);	\
    symbol_set_local(_sym_, environment_id(Frame), _slot_); \
    set_type(_slot_, T_SLOT | T_IMMUTABLE);\
    next_slot(_slot_) = environment_slots(Frame);\
    environment_slots(Frame) = _slot_;\
  } while (0)

/* no set_local here -- presumably done earlier in check_* 
 */


#define NEW_FRAME_WITH_SLOT(Sc, Old_Env, New_Env, Symbol, Value) \
  do {                                   \
      s7_pointer _x_, _slot_, _sym_;		   \
      _sym_ = Symbol; \
      NEW_CELL(Sc, _x_);                   \
      environment_id(_x_) = ++environment_number; \
      next_environment(_x_) = Old_Env;		         \
      set_type(_x_, T_ENVIRONMENT | T_IMMUTABLE); \
      New_Env = _x_;		   \
      NEW_CELL_NO_CHECK(Sc, _slot_);\
      slot_symbol(_slot_) = _sym_;\
      slot_set_value(_slot_, Value);	\
      symbol_set_local(_sym_, environment_number, _slot_); \
      set_type(_slot_, T_SLOT | T_IMMUTABLE);\
      next_slot(_slot_) = sc->NIL;\
      environment_slots(_x_) = _slot_;\
     } while (0)


#define NEW_FRAME_WITH_TWO_SLOTS(Sc, Old_Env, New_Env, Symbol1, Value1, Symbol2, Value2) \
  do {                                   \
      s7_pointer _x_, _slot_, _sym_;		   \
      NEW_CELL(Sc, _x_);                   \
      environment_id(_x_) = ++environment_number; \
      next_environment(_x_) = Old_Env;		         \
      set_type(_x_, T_ENVIRONMENT | T_IMMUTABLE); \
      New_Env = _x_;		   \
      NEW_CELL_NO_CHECK(Sc, _slot_);\
      _sym_ = Symbol1; \
      slot_symbol(_slot_) = _sym_;\
      slot_set_value(_slot_, Value1);	\
      symbol_set_local(_sym_, environment_number, _slot_); \
      set_type(_slot_, T_SLOT | T_IMMUTABLE);\
      environment_slots(_x_) = _slot_;\
      NEW_CELL_NO_CHECK(Sc, _x_);\
      _sym_ = Symbol2; \
      slot_symbol(_x_) = _sym_;\
      slot_set_value(_x_, Value2);	\
      symbol_set_local(_sym_, environment_number, _x_); \
      set_type(_x_, T_SLOT | T_IMMUTABLE);\
      next_slot(_x_) = sc->NIL;\
      next_slot(_slot_) = _x_;\
     } while (0)


#define NEW_FRAME_WITH_CHECKED_SLOT(Sc, Old_Env, New_Env, Symbol, Value) \
  do {                                   \
      s7_pointer _x_, _slot_, _sym_;		   \
      _sym_ = Symbol; \
      NEW_CELL(Sc, _x_);                   \
      environment_id(_x_) = ++environment_number; \
      next_environment(_x_) = Old_Env;		         \
      set_type(_x_, T_ENVIRONMENT | T_IMMUTABLE); \
      New_Env = _x_;		   \
      NEW_CELL_NO_CHECK(Sc, _slot_);\
      slot_symbol(_slot_) = _sym_;\
      if (symbol_has_accessor(_sym_)) \
        slot_set_value(_slot_, call_symbol_bind(Sc, _sym_, Value)); \
      else slot_set_value(_slot_, Value);		\
      symbol_set_local(_sym_, environment_number, _slot_); \
      set_type(_slot_, T_SLOT | T_IMMUTABLE);\
      next_slot(_slot_) = sc->NIL;\
      environment_slots(_x_) = _slot_;\
     } while (0)


#define ADD_CHECKED_SLOT(Frame, Symbol, Value) \
  do {\
    s7_pointer _slot_, _sym_;				\
    _sym_ = Symbol; \
    NEW_CELL_NO_CHECK(sc, _slot_);\
    slot_symbol(_slot_) = _sym_;\
    if (symbol_has_accessor(_sym_)) \
      slot_set_value(_slot_, call_symbol_bind(sc, _sym_, Value)); \
    else slot_set_value(_slot_, Value);		\
    symbol_set_local(_sym_, environment_id(Frame), _slot_); \
    set_type(_slot_, T_SLOT | T_IMMUTABLE);\
    next_slot(_slot_) = environment_slots(Frame);\
    environment_slots(Frame) = _slot_;\
  } while (0)


static s7_pointer old_frame_in_env(s7_scheme *sc, s7_pointer frame, s7_pointer next_frame)
{
  environment_slots(frame) = sc->NIL;                  
  next_environment(frame) = next_frame;
  set_type(frame, T_ENVIRONMENT | T_IMMUTABLE); 
  environment_id(frame) = ++environment_number; 
  return(frame);
}


static s7_pointer old_frame_with_slot(s7_scheme *sc, s7_pointer env, s7_pointer val)
{
  s7_pointer x, sym;
  unsigned long long int id;

  id = ++environment_number;
  environment_id(env) = id;
  x = environment_slots(env);
  slot_set_value(x, val);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);

  return(env);
}


static s7_pointer old_frame_with_two_slots(s7_scheme *sc, s7_pointer env, s7_pointer val1, s7_pointer val2)
{
  s7_pointer x, sym;
  unsigned long long int id;

  id = ++environment_number;
  environment_id(env) = id;
  x = environment_slots(env);
  slot_set_value(x, val1);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);
  x = next_slot(x);
  slot_set_value(x, val2);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);

  return(env);
}


static s7_pointer old_frame_with_three_slots(s7_scheme *sc, s7_pointer env, s7_pointer val1, s7_pointer val2, s7_pointer val3)
{
  s7_pointer x, sym;
  unsigned long long int id;

  id = ++environment_number;
  environment_id(env) = id;
  x = environment_slots(env);

  slot_set_value(x, val1);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);
  x = next_slot(x);

  slot_set_value(x, val2);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);
  x = next_slot(x);

  slot_set_value(x, val3);
  sym = slot_symbol(x);
  symbol_set_local(sym, id, x);

  return(env);
}


static s7_pointer permanent_slot(s7_pointer symbol, s7_pointer value)
{
  s7_pointer x;
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  slot_symbol(x) = symbol;
  slot_set_value(x, value);
  set_type(x, T_SLOT | T_IMMUTABLE);
  return(x);
}


bool s7_is_environment(s7_pointer e)
{
  return(is_environment(e));
}


static s7_pointer g_is_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_is_environment "(environment? obj) returns #t if obj is an environment."
  CHECK_BOOLEAN_METHOD(sc, car(args), is_environment, sc->ENVIRONMENTP, args);
}


static s7_pointer find_environment(s7_scheme *sc, s7_pointer obj)
{
  switch (type(obj))
    {
    case T_ENVIRONMENT:
      return(obj);

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      return(closure_environment(obj));

    case T_C_OBJECT:
      return(c_object_environment(obj));
    }
  return(sc->NIL);
}


static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol) 
{ 
  s7_pointer x, y;

  for (x = env; is_environment(x); x = next_environment(x))
    for (y = environment_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	return(slot_value(y));

  return(sc->UNDEFINED);
} 


static int environment_length(s7_scheme *sc, s7_pointer e)
{
  /* used by length, applicable_length, and some length optimizations */
  int i;
  s7_pointer p;

  if (e == sc->global_env)
    return(sc->global_env_entries);

  if (has_methods(e))
    {
      s7_pointer length_func;
      length_func = find_method(sc, e, sc->LENGTH);
      if (length_func != sc->UNDEFINED)
	return((int)s7_integer(s7_apply_function(sc, length_func, list_1(sc, e))));
    }

  for (i = 0, p = environment_slots(e); is_slot(p); i++, p = next_slot(p));
  return(i);
}


s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value) 
{ 
  s7_pointer slot;

  if ((!is_environment(env)) ||
      (env == sc->global_env))
    {
      s7_pointer ge;

      if ((sc->safety == 0) &&
	  ((is_closure(value))      ||
	   (is_closure_star(value)) ||
	   (is_macro(value))        ||
	   (is_bacro(value))))
	{
	  s7_remove_from_heap(sc, closure_args(value));
	  s7_remove_from_heap(sc, closure_body(value));
	}

      ge = sc->global_env;
      slot = permanent_slot(symbol, value);
      vector_element(ge, sc->global_env_entries++) = slot;
      if (sc->global_env_entries >= vector_length(ge))
	{
	  int i;
	  vector_length(ge) *= 2;
	  vector_elements(ge) = (s7_pointer *)realloc(vector_elements(ge), vector_length(ge) * sizeof(s7_pointer));
	  for (i = sc->global_env_entries; i < vector_length(ge); i++)
	    vector_element(ge, i) = sc->NIL;
	}
      global_slot(symbol) = slot;
      if (symbol_id(symbol) == 0) /* never defined locally? */
	{
	  if (initial_slot(symbol) == sc->UNDEFINED)
	    initial_slot(symbol) = permanent_slot(symbol, value);
	  local_slot(symbol) = slot;
	  set_global(symbol);
	}
    }
  else 
    {
      set_local(symbol); 

      NEW_CELL(sc, slot);
      slot_symbol(slot) = symbol;
      slot_set_value(slot, value);
      set_type(slot, T_SLOT | T_IMMUTABLE);
      next_slot(slot) = environment_slots(env);
      environment_slots(env) = slot;
      /* this is called by augment-environment! so we have to be careful about the resultant environment_id
       *   check for greater to ensure shadowing stays in effect, and equal to do updates (set! in effect)
       */
      if (environment_id(env) >= symbol_id(symbol))
	symbol_set_local(symbol, environment_id(env), slot);
    }

  /* there are about the same number of frames as local variables -- this
   *   strikes me as surprising, but it holds up across a lot of code.
   */

  return(slot);
} 


static s7_pointer add_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) 
{ 
  /* this is called when it is guaranteed that there is a local environment */
  s7_pointer y;

  NEW_CELL(sc, y);
  slot_symbol(y) = variable;
  slot_set_value(y, value);
  set_type(y, T_SLOT | T_IMMUTABLE);
  next_slot(y) = environment_slots(sc->envir);
  environment_slots(sc->envir) = y;
  set_local(variable);
  symbol_set_local(variable, environment_id(sc->envir), y);
  return(y);
} 


static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) 
{
  /* this is for a do-loop optimization -- an unattached slot */
  s7_pointer y;
  NEW_CELL(sc, y);
  slot_symbol(y) = variable;
  slot_set_value(y, value);
  set_type(y, T_SLOT | T_IMMUTABLE);
  return(y);
}



/* -------- initial-environment -------- */

#define INITIAL_ENV_ENTRIES 400

static void save_initial_environment(s7_scheme *sc)
{
  /* there are ca 270 predefined functions (and another 80 or so other things): 348 at last count
   */
  int i, k = 0;
  s7_pointer x;
  s7_pointer *inits;

  sc->initial_env = (s7_pointer)calloc(1, sizeof(s7_cell));
  set_type(sc->initial_env, T_VECTOR);
  vector_length(sc->initial_env) = INITIAL_ENV_ENTRIES;
  vector_elements(sc->initial_env) = (s7_pointer *)malloc(INITIAL_ENV_ENTRIES * sizeof(s7_pointer));
  vector_getter(sc->initial_env) = default_vector_getter;
  vector_setter(sc->initial_env) = default_vector_setter;
  inits = vector_elements(sc->initial_env);
  s7_vector_fill(sc, sc->initial_env, sc->NIL);
  heap_location(sc->initial_env) = NOT_IN_HEAP;

  for (i = 0; i < vector_length(sc->symbol_table); i++) 
    for (x  = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) 
      {
	s7_pointer sym, val;
	sym = car(x);
	if (is_slot(initial_slot(sym)))
	  {
	    val = slot_value(initial_slot(sym));
	    if ((is_procedure(val)) || (is_syntax(val)))
	      inits[k++] = initial_slot(sym);

	    /* (let ((begin +)) (with-environment (initial-environment) (begin 1 2))) */
	    /*
	    if (k >= INITIAL_ENV_ENTRIES)
	      {
		fprintf(stderr, "oops: overran inits\n");
		return;
	      }
	    */
	  }
      }
}


static s7_pointer g_initial_environment(s7_scheme *sc, s7_pointer args)
{
  /* add sc->initial_env bindings to the current environment */
  #define H_initial_environment "(initial-environment) establishes the original bindings of all the predefined functions"

  /* maybe this should be named unshadowed-current-environment or something -- it currently looks
   *   like it simply returns the initial env, but it actually shadows the global env entries
   *   that have changed.  
   *
   * slightly confusing:
   *    :((initial-environment) 'abs)
   *    #<undefined>
   *    :(defined? 'abs (initial-environment))
   *    #t
   * this is because initial-environment sets up a local environment of unshadowed symbols,
   *   and s7_environment_ref below only looks at the local env chain (that is, if env is not
   *   the global env, then the global env is not searched).
   */
  int i;
  s7_pointer *inits;
  s7_pointer x, sym;

  sc->w = new_frame_in_env(sc, sc->envir);
  inits = vector_elements(sc->initial_env);

  for (i = 0; (i < INITIAL_ENV_ENTRIES) && (is_slot(inits[i])); i++)
    {
      x = slot_value(inits[i]);
      sym = slot_symbol(inits[i]);
      if (is_procedure(x))
	{
	  if (((!is_global(sym)) &&                  /* it might be shadowed locally */
	       (s7_symbol_local_value(sc, sym, sc->envir) != slot_value(global_slot(sym)))) ||
	      (x != slot_value(global_slot(sym))))   /* it's not shadowed, but has been changed globally */
	    s7_make_slot(sc, sc->w, sym, x);
	}
      else
	{
	  if ((is_syntax(x)) &&
	      (local_slot(sym) != sc->NIL))
	    s7_make_slot(sc, sc->w, sym, x);
	}
    }
  /* if (set! + -) then + needs to be overridden, but the local bit isn't set,
   *   so we have to check the actual values in the non-local case.
   *   (define (f x) (with-environment (initial-environment) (+ x 1))) 
   */

  x = sc->w;
  sc->w = sc->NIL;
  return(x);
}


#if 0
static void save_null_environment(s7_scheme *sc)
{
  #define NULL_ENV_SIZE 18
  static const char *null_env_names[NULL_ENV_SIZE] = {
    "define" "quote" "lambda" "if" "set!" "define*" "lambda*" "cond" "case" "and" "or" "let" "let*" "letrec" "letrec*" "begin" "do" "quasiquote"};
  int i;
  s7_pointer *nulls;
  /* g_null_environment would return sc->null_env */
  
  sc->null_env = (s7_pointer)calloc(1, sizeof(s7_cell));
  set_type(sc->null_env, T_VECTOR);
  vector_length(sc->null_env) = NULL_ENV_SIZE;
  vector_elements(sc->null_env) = (s7_pointer *)malloc(NULL_ENV_SIZE * sizeof(s7_pointer));
  vector_getter(sc->null_env) = default_vector_getter;
  vector_setter(sc->null_env) = default_vector_setter;
  nulls = vector_elements(sc->null_env);
  heap_location(sc->null_env) = NOT_IN_HEAP;

  for (i = 0; i < NULL_ENV_SIZE; i++)
    {
      s7_pointer sym;
      sym = make_symbol(sc, null_env_names[i]);
      nulls[i] = permanent_slot(sym, s7_symbol_value(sc, sym));
    }
}
#endif


static s7_pointer g_is_open_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_is_open_environment "(open-environment? obj) returns #t is 'obj' has methods."
  CHECK_BOOLEAN_METHOD(sc, car(args), has_methods, sc->OPEN_ENVIRONMENTP, args);
}


static s7_pointer g_open_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_open_environment "(open-environment e) marks the environment 'e for special handling by generic functions and so on."
  s7_pointer e;

  e = car(args);
  if (((is_environment(e)) && (e != sc->global_env)) ||
      (is_closure(e)) ||
      (is_closure_star(e)) ||
      ((is_c_object(e)) && (c_object_environment(e) != sc->NIL)))
    {
      set_has_methods(e);
      return(e);
    }
  CHECK_METHOD(sc, e, sc->OPEN_ENVIRONMENT, args);
  return(simple_wrong_type_argument_with_type(sc, sc->OPEN_ENVIRONMENT, e, AN_ENVIRONMENT));
}


s7_pointer s7_open_environment(s7_pointer e)
{
  set_has_methods(e);
  return(e);
}


bool s7_is_open_environment(s7_pointer e)
{
  return(has_methods(e));
}


s7_pointer s7_search_open_environment(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  return(find_method(sc, find_environment(sc, e), symbol));
}


static void append_environment(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e)
{
  s7_pointer x;

  if (old_e == sc->global_env) 
    return;

  if (new_e != sc->global_env)
    {
      for (x = environment_slots(old_e); is_slot(x); x = next_slot(x))
	s7_make_slot(sc, new_e, slot_symbol(x), slot_value(x));
    }
  else
    {
      for (x = environment_slots(old_e); is_slot(x); x = next_slot(x))
	{
	  s7_pointer sym, val;
	  sym = slot_symbol(x);
	  val = slot_value(x);
	  if (is_slot(global_slot(sym)))
	    slot_set_value(global_slot(sym), val);
	  else s7_make_slot(sc, new_e, sym, val);
	}
    }
}


/* should these two augment-envs check for symbol accessors?
 */

static s7_pointer g_augment_environment_direct(s7_scheme *sc, s7_pointer args)
{
  #define H_augment_environment_direct "(augment-environment! env ...) adds its \
arguments (each an environment or a cons: symbol . value) directly to the environment env, and returns the \
environment."

  s7_pointer x, e;
  int i;

  e = car(args);
  if (is_null(e))
    e = sc->global_env;
  else
    {
      if (!is_environment(e))
	{
	  CHECK_METHOD(sc, e, sc->AUGMENT_ENVIRONMENTB, args);
	  return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENTB, small_int(1), e, AN_ENVIRONMENT));
	}
    }
  for (i = 2, x = cdr(args); is_not_null(x); x = cdr(x), i++)
    {
      s7_pointer sym, val, p;
      p = car(x);
      if (!is_environment(p))
	{
	  if (!is_pair(p))
	    return(wrong_type_argument(sc, sc->AUGMENT_ENVIRONMENTB, make_integer(sc, i), p, T_PAIR));
	  if (!is_symbol(car(p)))
	    return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENTB, make_integer(sc, i), p, 
						 make_protected_string(sc, "a pair whose car is a symbol: '(symbol . value)")));
	  sym = car(p);
	  val = cdr(p);
	  if ((is_immutable(sym)) &&                    /* check for (eval 'pi (augment-environment! () '(pi . 1))) */
	      (!s7_is_equal(sc, val, s7_symbol_value(sc, sym))))
	    return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENTB, make_integer(sc, i), sym, 
						 make_protected_string(sc, "a non-contant symbol")));
	}
    }
  
  if (e == sc->global_env)
    {
      for (i = 2, x = cdr(args); is_not_null(x); i++, x = cdr(x))
	{
	  s7_pointer p;
	  p = car(x);
	  if (is_pair(p))
	    {
	      s7_pointer sym;
	      sym = car(p);
	      if (is_slot(global_slot(sym)))
		{
		  if (is_syntax(slot_value(global_slot(sym))))
		    return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENTB, make_integer(sc, i), p, 
							 make_protected_string(sc, "a non-syntactic keyword")));
		  /*  without this check we can end up turning our code into gibberish:
		   *
		   * :(set! quote 1)
		   * ;can't set! quote
		   * :(augment-environment! (global-environment) '(quote . 1))
		   * :quote
		   * 1
		   * or worse set quote to a function of one arg that tries to quote something -- infinite loop
		   */
		  slot_set_value(global_slot(sym), cdr(p));
		}
	      else s7_make_slot(sc, e, sym, cdr(p));
	    }
	  else append_environment(sc, e, p);
	}
    }
  else
    {
      for (x = cdr(args); is_not_null(x); x = cdr(x))
	{
	  s7_pointer p;
	  p = car(x);
	  if (is_pair(p))
	    {
	      s7_pointer x;
	      bool found_it = false;
	      for (x = environment_slots(e); is_slot(x); x = next_slot(x))
		if (slot_symbol(x) == car(p))
		  {
		    slot_set_value(x, cdr(p));
		    found_it = true;
		    break;
		  }
	      if (!found_it)
		s7_make_slot(sc, e, car(p), cdr(p));
	    }
	  else append_environment(sc, e, p);
	}
    }
  return(e);
}


s7_pointer s7_augment_environment(s7_scheme *sc, s7_pointer e, s7_pointer bindings)
{
  s7_pointer new_e;

  if (e == sc->global_env)
    new_e = new_frame_in_env(sc, sc->NIL);
  else new_e = new_frame_in_env(sc, e);

  if (!is_null(bindings))
    {
      s7_pointer x;
      int gc_loc;
      gc_loc = s7_gc_protect(sc, new_e);

      for (x = bindings; is_not_null(x); x = cdr(x))
	{
	  s7_pointer p;
	  p = car(x);
	  if (is_pair(p))
	    s7_make_slot(sc, new_e, car(p), cdr(p));
	  else append_environment(sc, new_e, p);
	  /* env as arg for common case: 
	   *   (with-environment (augment-environment (current-environment) (object-environment obj)) ...)
	   * to bring in all of obj's fields/methods but keep access to the surrounding context.
	   * But chaining is not safe or even unambiguous, and this form will not work if obj's fields
	   *  are being set -- we've made a new slot!  Not sure how to handle this.
	   */
	}
      s7_gc_unprotect_at(sc, gc_loc);
    }

  return(new_e);
}


/* currently (eval 'a (augment-environment () '(a . 1) '(a . 2))) -> 2,
 *   but should it be an error?
 */

static s7_pointer g_augment_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_augment_environment "(augment-environment env ...) adds its \
arguments (each an environment or a cons: symbol . value) to the environment env, and returns the \
new environment."

  s7_pointer e, x;
  int i;

  e = car(args);
  if (is_null(e))
    e = sc->global_env;
  else
    {
      if (!is_environment(e))
	{
	  CHECK_METHOD(sc, e, sc->AUGMENT_ENVIRONMENT, args);
	  return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENT, small_int(1), e, AN_ENVIRONMENT));
	}
    }
  if (!is_null(cdr(args)))
    for (i = 2, x = cdr(args); is_not_null(x); x = cdr(x), i++)
      {
	s7_pointer sym, val, p;
	p = car(x);
	if (!is_environment(p))
	  {
	    if (!is_pair(p))
	      return(wrong_type_argument(sc, sc->AUGMENT_ENVIRONMENT, make_integer(sc, i), p, T_PAIR));
	    if (!is_symbol(car(p)))
	      return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENT, make_integer(sc, i), p, 
						   make_protected_string(sc, "a pair whose car is a symbol: '(symbol . value)")));
	    sym = car(p);
	    val = cdr(p);
	    if ((is_immutable(sym)) &&                            /* check for (eval 'pi (augment-environment () '(pi . 1))) */
		(!s7_is_equal(sc, val, s7_symbol_value(sc, sym))))
	      return(wrong_type_argument_with_type(sc, sc->AUGMENT_ENVIRONMENT, make_integer(sc, i), sym, make_protected_string(sc, "a non-constant symbol")));
	  }
      }
  return(s7_augment_environment(sc, e, cdr(args)));
}


static s7_pointer g_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_environment "(environment ...) adds its \
arguments (each an environment or a cons: symbol . value) to a new environment, and returns the \
new environment."

  s7_pointer x;
  int i;
  static s7_pointer errstr = NULL;

  if (!is_null(args))
    for (i = 1, x = args; is_not_null(x); x = cdr(x), i++)
      {
	s7_pointer sym, val, p;
	p = car(x);
	if (!is_environment(p))
	  {
	    if (!is_pair(p))
	      return(wrong_type_argument(sc, sc->ENVIRONMENT, make_integer(sc, i), p, T_PAIR));
	    if (!is_symbol(car(p)))
	      {
		if (!errstr)
		  errstr = s7_make_permanent_string("a pair whose car is a symbol: '(symbol . value)");
		return(wrong_type_argument_with_type(sc, sc->ENVIRONMENT, make_integer(sc, i), p, errstr));
	      }
	    sym = car(p);
	    val = cdr(p);
	    if ((is_immutable(sym)) &&                            /* check for (eval 'pi (augment-environment () '(pi . 1))) */
		(!s7_is_equal(sc, val, s7_symbol_value(sc, sym))))
	      return(wrong_type_argument_with_type(sc, sc->ENVIRONMENT, make_integer(sc, i), sym, make_protected_string(sc, "a non-constant symbol")));
	  }
      }
  return(s7_augment_environment(sc, sc->global_env, args));
}


/* augment-environment is, it turns out, not quite the right thing for method lists -- in that case
 *   we don't want to redirect searchers from the global value which is still correct, or turn off
 *   optimization (based on safe=global).
 */


s7_pointer s7_environment_to_list(s7_scheme *sc, s7_pointer env)
{
  s7_pointer x;
  sc->temp4 = sc->w;
  sc->w = sc->NIL;
  if (env == sc->global_env)
    {
      unsigned int i;
      for (i = 0; i < sc->global_env_entries; i++)
	sc->w = cons(sc, cons(sc, slot_symbol(vector_element(env, i)), slot_value(vector_element(env, i))), sc->w);
    }
  else
    {
      for (x = environment_slots(env); is_slot(x); x = next_slot(x))
	sc->w = cons(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w);
    }
  x = sc->w;
  sc->w = sc->temp4;
  return(x);
}


static s7_pointer g_environment_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_environment_to_list "(environment->list env) returns env's bindings as a list of cons's: '(symbol . value)."

  s7_pointer env;
  env = car(args);
  if (!is_environment(env))
    {
      CHECK_METHOD(sc, env, sc->ENVIRONMENT_TO_LIST, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_TO_LIST, env, AN_ENVIRONMENT));
    }
  return(s7_environment_to_list(sc, env));
}


#if 0
static s7_pointer g_environment_function(s7_scheme *sc, s7_pointer args)
{
  /* an experiment -- maybe we can func info in the stacktrace */
  s7_pointer e;
  e = car(args);
  if (is_function_env(e))
    return(environment_function(e));
  return(sc->F);
}
#endif


s7_pointer s7_environment_ref(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
  s7_pointer x, y;
  /* (let ((a 1)) ((current-environment) 'a)) 
   * ((global-environment) 'abs) 
   */

  if (environment_id(env) == symbol_id(symbol))
    return(slot_value(local_slot(symbol)));

  if (env == sc->global_env)
    {
      y = global_slot(symbol);
      if (is_slot(y))
	return(slot_value(y));
      return(sc->UNDEFINED);
    }

  for (x = env; is_environment(x); x = next_environment(x))
    for (y = environment_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	return(slot_value(y));

  return(sc->UNDEFINED);
}


s7_pointer s7_environment_set(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
  s7_pointer x, y;

  /* this costs slightly more than it saves (ref case above gets many more hits)
  if (environment_id(env) == symbol_id(symbol))
    {
      slot_set_value(local_slot(symbol), value);
      return(value);
    }
  */

  if (env == sc->global_env)
    {
      y = global_slot(symbol);
      if (is_slot(y))
	{
	  slot_set_value(y, value);
	  return(value);
	}
      return(sc->UNDEFINED);
    }

  for (x = env; is_environment(x); x = next_environment(x))
    for (y = environment_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	{
	  slot_set_value(y, value);
	  return(value);
	}
  return(sc->UNDEFINED);
}


static s7_pointer g_environment_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_environment_ref "(environment-ref env sym) returns the value of the symbol sym in the environment env"
  s7_pointer e, sym;

  e = car(args);
  if (!is_environment(e))
    return(s7_wrong_type_arg_error(sc, "environment-ref", 1, e, "an environment"));

  sym = cadr(args);
  if (!is_symbol(sym))
    return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_REF, sym, A_SYMBOL));

  return(s7_environment_ref(sc, e, sym));
}


static s7_pointer g_environment_set(s7_scheme *sc, s7_pointer args)
{
  /* (let ((a 1)) (set! ((current-environment) 'a) 32) a) */
  #define H_environment_set "(environment-set! env sym val) sets the symbol sym's value in the environment env to val"
  s7_pointer e, sym;

  e = car(args);
  if (!is_environment(e))
    return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_SET, e, AN_ENVIRONMENT));

  sym = cadr(args);
  if (!is_symbol(sym))
    return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_SET, sym, A_SYMBOL));

  return(s7_environment_set(sc, e, sym, caddr(args)));
}


static s7_pointer reverse_slots(s7_scheme *sc, s7_pointer list)
{
  s7_pointer p = list, result, q;
  result = sc->NIL;

  while (is_slot(p))
    {
      q = next_slot(p);
      next_slot(p) = result;
      result = p;
      p = q;
    }
  return(result);
}


static s7_pointer environment_copy(s7_scheme *sc, s7_pointer env)
{
  if (is_environment(env))
    {
      s7_pointer x, new_e;
      int gc_loc;

      if (env == sc->global_env)   /* (copy (global-environment)) or (copy (procedure-environment abs)) etc */
	return(sc->global_env);

      /* we can't make copy handle environments-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.
       */
      if (has_methods(env))
	{
	  /* mark the new env as open */
	  new_e = new_frame_in_env(sc, next_environment(env));
	  set_has_methods(new_e);
	}
      else new_e = new_frame_in_env(sc, next_environment(env));
      gc_loc = s7_gc_protect(sc, new_e);

      for (x = environment_slots(env); is_slot(x); x = next_slot(x))
	ADD_SLOT(new_e, slot_symbol(x), slot_value(x));
      environment_slots(new_e) = reverse_slots(sc, environment_slots(new_e));
      
      s7_gc_unprotect_at(sc, gc_loc);      
      return(new_e);
    }
  return(sc->NIL);
}


static s7_pointer g_global_environment(s7_scheme *sc, s7_pointer ignore)
{
  #define H_global_environment "(global-environment) returns the current top-level definitions (symbol bindings)."
  return(sc->global_env);
}

/* as with the symbol-table, this function can lead to disaster -- user could
 *   clobber the environment etc.  But we want it to be editable and augmentable,
 *   so I guess I'll leave it alone.  (See current|procedure-environment as well).
 */


s7_pointer s7_global_environment(s7_scheme *sc) 
{
  return(sc->global_env);
}


static s7_pointer g_current_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_current_environment "(current-environment) returns the current definitions (symbol bindings)"

  sc->capture_env_counter++;
  if (is_environment(sc->envir))
    return(sc->envir);
  return(sc->global_env);
}


s7_pointer s7_current_environment(s7_scheme *sc) 
{
  sc->capture_env_counter++;
  return(sc->envir);
}


s7_pointer s7_set_current_environment(s7_scheme *sc, s7_pointer e) 
{
  s7_pointer old_e;
  old_e = sc->envir;
  sc->envir = e;
  return(old_e);
}


s7_pointer s7_outer_environment(s7_pointer e)
{
  return(next_environment(e));
}


static s7_pointer g_outer_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_outer_environment "(outer-environment env) returns the environment that contains env."
  s7_pointer env;

  env = car(args);
  if (!is_environment(env))
    {
      CHECK_METHOD(sc, env, sc->OUTER_ENVIRONMENT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->OUTER_ENVIRONMENT, env, AN_ENVIRONMENT));  
    }
  if ((env == sc->global_env) ||
      (is_null(next_environment(env))))
    return(sc->global_env);
  return(next_environment(env));
}


static s7_pointer find_symbol(s7_scheme *sc, s7_pointer hdl)
{ 
  s7_pointer x;	

  if (environment_id(sc->envir) == symbol_id(hdl))
    return(local_slot(hdl));	

  for (x = sc->envir; symbol_id(hdl) < environment_id(x); x = next_environment(x));

  if (environment_id(x) == symbol_id(hdl))
    return(local_slot(hdl));	

  for (; is_environment(x); x = next_environment(x))
    {
      s7_pointer y; 
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
	if (slot_symbol(y) == hdl)
	  return(y); 
    }

  return(global_slot(hdl));
} 


s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol)
{
  return(find_symbol(sc, symbol));
}


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


static s7_pointer find_local_symbol(s7_scheme *sc, s7_pointer env, s7_pointer hdl) 
{ 
  s7_pointer y;

  if (!is_environment(env))
    return(global_slot(hdl));

  for (y = environment_slots(env); is_slot(y); y = next_slot(y))
    if (slot_symbol(y) == hdl)
      return(y);

  return(sc->UNDEFINED);
} 


s7_pointer s7_local_slot(s7_scheme *sc, s7_pointer symbol)
{
  s7_pointer y;
  for (y = environment_slots(sc->envir); is_slot(y); y = next_slot(y))
    if (slot_symbol(y) == symbol)
      return(y);
  return(NULL);
}


s7_pointer s7_is_local_variable(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  /* search from env e inward */
  s7_pointer x, y;
  for (x = sc->envir; (x != e) && (is_environment(x)); x = next_environment(x))
    for (y = environment_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	return(y);
  return(NULL);
}


s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) /* was searching just the global environment? */
{
  s7_pointer x;

  x = find_symbol(sc, sym);
  if (is_slot(x))
    return(slot_value(x));

  return(sc->UNDEFINED);
}


s7_pointer s7_value(s7_scheme *sc, s7_pointer sym)
{
  return(finder(sc, sym));
}


s7_pointer s7_car_value(s7_scheme *sc, s7_pointer lst)
{
  return(finder(sc, car(lst)));
}


s7_pointer s7_cadr_value(s7_scheme *sc, s7_pointer lst)
{
  return(finder(sc, cadr(lst)));
}


size_t s7_number_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, object.number.real_value));
}


size_t s7_slot_value_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, object.slt.val));
}


size_t s7_denominator_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, object.number.fraction_value.denominator));
}


size_t s7_type_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, tf.type_field));
}


size_t s7_c_object_type_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, object.c_obj.type));
}


size_t s7_c_object_value_offset(s7_scheme *sc)
{
  return(offsetof(s7_cell, object.c_obj.value));
}


int s7_c_object_built_in_type(s7_scheme *sc)
{
  return(T_C_OBJECT);
}


s7_pointer s7_cadar_value(s7_scheme *sc, s7_pointer lst)
{
  return(finder(sc, cadar(lst)));
}


s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env)
{
  s7_pointer x;
  if (is_environment(local_env))
    {
      for (x = local_env; is_environment(x); x = next_environment(x))
	{
	  s7_pointer y;
	  for (y = environment_slots(x); is_slot(y); y = next_slot(y))
	    if (slot_symbol(y) == sym)
	      return(slot_value(y));
	}
    }
  return(s7_symbol_value(sc, sym)); 
}


#define SYMBOL_TO_VALUE(Sc, Sym) ((is_global(Sym)) ? slot_value(global_slot(Sym)) : finder(Sc, Sym))

static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_value "(symbol->value sym (env (current-environment))) returns the binding of (the value associated with) the \
symbol sym in the given environment: (let ((x 32)) (symbol->value 'x)) -> 32"

  s7_pointer sym;
  sym = car(args);

  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->SYMBOL_TO_VALUE, args);
      return(wrong_type_argument(sc, sc->SYMBOL_TO_VALUE, small_int(1), sym, T_SYMBOL));
    }
  if (is_not_null(cdr(args)))
    {
      s7_pointer x, local_env;
      local_env = cadr(args);
      if (!is_environment(local_env))
	{
	  CHECK_METHOD(sc, local_env, sc->SYMBOL_TO_VALUE, args);
	  return(wrong_type_argument_with_type(sc, sc->SYMBOL_TO_VALUE, small_int(2), local_env, AN_ENVIRONMENT));
	}
      if (local_env == sc->global_env)
	{
	  x = global_slot(sym);
	  if (is_slot(x))
	    return(slot_value(x));
	  return(sc->UNDEFINED);
	}
      return(s7_symbol_local_value(sc, sym, local_env));
    }
  
  if (is_global(sym))
    return(slot_value(global_slot(sym)));

  return(s7_symbol_value(sc, sym));
}


s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  s7_pointer x;
  /* if immutable should this return an error? */
  x = find_symbol(sc, sym);
  if (is_slot(x))
    slot_set_value(x, val);
  return(val);
}


static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, long long int *id)
{ 
  for (; symbol_id(sym) < environment_id(x); x = next_environment(x));

  if (environment_id(x) == symbol_id(sym))
    {
      (*id) = environment_id(x);
      return(slot_value(local_slot(sym)));
    }
  for (; (is_environment(x)) && (environment_id(x) > (*id)); x = next_environment(x))
    {
      s7_pointer y; 
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
	if (slot_symbol(y) == sym)
	  {
	    (*id) = environment_id(x);
	    return(slot_value(y));
	  }
    }
  return(sc->GC_NIL);
} 


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"

  s7_pointer sym, val;
  long long int top_id;
  int i;

  sym = car(args);

  if (!is_symbol(sym))
    return(wrong_type_argument(sc, sc->SYMBOL_TO_DYNAMIC_VALUE, small_int(1), sym, T_SYMBOL));
  
  if (is_global(sym))
    return(slot_value(global_slot(sym)));

  if (environment_id(sc->envir) == symbol_id(sym))
    return(slot_value(local_slot(sym)));	

  top_id = -1;
  val = find_dynamic_value(sc, sc->envir, sym, &top_id);
  if (top_id == symbol_id(sym))
    return(val);

  for (i = s7_stack_top(sc) - 1; i > 0; i -= 4)
    {
      s7_pointer cur_val;
      cur_val = find_dynamic_value(sc, stack_environment(sc->stack, i), sym, &top_id);
      if (cur_val != sc->GC_NIL)
	val = cur_val;
      if (top_id == symbol_id(sym))
	return(val);
    }
  
  if (val == sc->GC_NIL)
    return(s7_symbol_value(sc, sym));
  return(val);
}


static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, int type) 
{
  /* this is called every time a lambda form is evaluated, or during letrec, etc */

  s7_pointer x;
  NEW_CELL(sc, x);
  closure_args(x) = args;
  closure_body(x) = code;
  closure_setter(x) = sc->F;
  if (is_null(args))
    closure_arity(x) = 0;
  else closure_arity(x) = CLOSURE_ARITY_NOT_SET;
  closure_environment(x) = sc->envir;
  if (is_safe_closure(code))
    {
      if (type == T_CLOSURE)
	set_type(x, T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS);
      else set_type(x, T_CLOSURE_STAR | T_PROCEDURE | T_SAFE_CLOSURE);
    }
  else
    {
      if (type == T_CLOSURE)
	set_type(x, T_CLOSURE | T_PROCEDURE | T_COPY_ARGS);
      else set_type(x, T_CLOSURE_STAR | T_PROCEDURE);
    }
  if (is_null(cdr(code))) set_one_liner(x);
  sc->capture_env_counter++;
  return(x);
}


s7_pointer s7_make_closure(s7_scheme *sc, s7_pointer a, s7_pointer c, s7_pointer e)
{
  /* c is a list: args code, so 
   *   (define (proc a b) (+ a b)) becomes
   *   make_closure ((a b) (+ a b)) e
   */
  s7_pointer p;
  p = make_closure(sc, a, c, T_CLOSURE);
  closure_environment(p) = e;
  /* sc->capture_env_counter++; */ /* happens in make_closure */
  return(p);
}


#define MAKE_CLOSURE(Sc, X, Args, Code, Env)	\
  do { \
       NEW_CELL(Sc, X); \
       closure_args(X) = Args;	\
       closure_body(X) = Code; \
       closure_setter(X) = sc->F; \
       if (is_null(Args)) closure_arity(X) = 0; else closure_arity(X) = CLOSURE_ARITY_NOT_SET; \
       closure_environment(X) = Env; \
       if (is_safe_closure(closure_body(X))) \
          set_type(X, T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS); \
       else set_type(X, T_CLOSURE | T_PROCEDURE | T_COPY_ARGS); \
       if (is_null(cdr(Code))) set_one_liner(X); \
       sc->capture_env_counter++; \
      } while (0)


#define MAKE_CLOSURE_NO_CAPTURE(Sc, X, Args, Code, Env)	\
  do { \
       NEW_CELL(Sc, X); \
       closure_args(X) = Args;	\
       closure_body(X) = Code; \
       closure_setter(X) = sc->F; \
       if (is_null(Args)) closure_arity(X) = 0; else closure_arity(X) = CLOSURE_ARITY_NOT_SET; \
       closure_environment(X) = Env; \
       if (is_safe_closure(closure_body(X))) \
          set_type(X, T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS); \
       else set_type(X, T_CLOSURE | T_PROCEDURE | T_COPY_ARGS); \
       if (is_null(cdr(Code))) set_one_liner(X); \
      } while (0)



static int closure_length(s7_scheme *sc, s7_pointer e)
{
  /* we can't use environment_length(sc, closure_environment(e)) because the closure_environment(closure)
   *   changes.  So the open bit is not always on.  Besides, the fallbacks need to be for closures, not environments.
   */
  s7_pointer length_func;
  length_func = find_method(sc, closure_environment(e), sc->LENGTH);
  if (length_func != sc->UNDEFINED)
    return((int)s7_integer(s7_apply_function(sc, length_func, list_1(sc, e))));

  /* there are cases where this should raise a wrong-type-arg error, but for now... */
  return(-1);
}


static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
{
  #define H_is_defined "(defined? obj (env (current-environment))) returns #t if obj has a binding (a value) in the environment env"
  s7_pointer sym, x;

  sym = car(args);
  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->DEFINEDP, args);
      return(wrong_type_argument(sc, sc->DEFINEDP, small_int(1), sym, T_SYMBOL));
    }

  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_environment(e))
	{
	  CHECK_METHOD(sc, e, sc->DEFINEDP, args);
	  return(wrong_type_argument_with_type(sc, sc->DEFINEDP, small_int(2), e, AN_ENVIRONMENT));
	}

      if (e == sc->global_env)
	return(make_boolean(sc, global_slot(sym) != sc->UNDEFINED));

      x = find_local_symbol(sc, e, sym); 
      if (is_slot(x))
	return(sc->T);
      /* here we can't fall back on find_symbol:
       *    (let ((b 2))
       *      (let ((e (current-environment)))
       *        (let ((a 1))
       *          (if (defined? 'a e)
       *              (format #t "a: ~A in ~{~A ~}" (symbol->value 'a e) e))))
       *    "a: 1 in (b . 2)"
       *
       * but we also can't just return #f: 
       *    (let ((b 2))
       *      (let ((e (current-environment)))
       *        (let ((a 1))
       *          (format #t "~A: ~A" (defined? 'abs e) (eval '(abs -1) e)))))
       *    "#f: 1"
       */
      return(make_boolean(sc, global_slot(sym) != sc->UNDEFINED));
    }
  else 
    {
      if (is_global(sym))
	return(sc->T);
    }
  
  return(make_boolean(sc, is_slot(find_symbol(sc, sym))));
}


bool s7_is_defined(s7_scheme *sc, const char *name)
{
  s7_pointer x;
  x = s7_symbol_table_find_name(sc, name);
  if (x)
    {
      x = find_symbol(sc, x);
      return(is_slot(x));
    }
  return(false);
}


void s7_define(s7_scheme *sc, s7_pointer envir, s7_pointer symbol, s7_pointer value) 
{
  s7_pointer x;

  if (envir == sc->global_env) envir = sc->NIL; /* for C-side backwards compatibility */
  x = find_local_symbol(sc, envir, symbol);
  if (is_slot(x)) 
    slot_set_value(x, value); 
  else s7_make_slot(sc, envir, symbol, value); /* I think this means C code can override "constant" defs */
}


void s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value)
{
  s7_pointer sym;

  sym = make_symbol(sc, name);
  s7_define(sc, sc->NIL, sym, value);
}


void s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value)
{
  s7_pointer x, sym;
  
  sym = make_symbol(sc, name);
  s7_define(sc, sc->NIL, sym, value);
  x = global_slot(sym);
  set_immutable(slot_symbol(x));
}

/* (define (func a) (let ((cvar (+ a 1))) cvar))
 * (define-constant cvar 23)
 * (func 1)
 * ;can't bind an immutable object: cvar
 */




/* -------- keywords -------- */

bool s7_is_keyword(s7_pointer obj)
{
  return(is_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? :key) -> #t"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_keyword, sc->KEYWORDP, args);
}


s7_pointer s7_make_keyword(s7_scheme *sc, const char *key)
{
  s7_pointer sym;
  char *name;
  int len;
  
  len = safe_strlen(key) + 2;
  name = (char *)malloc(len * sizeof(char));
  snprintf(name, len, ":%s", key);                     /* prepend ":" */
  sym = make_symbol(sc, name);
  typeflag(sym) |= (T_IMMUTABLE); 
  free(name);
  keyword_symbol(sym) = make_symbol(sc, key);
  
  s7_make_slot(sc, sc->NIL, sym, sym); /* make it global, not in the local env! */

  return(sym);
}


static s7_pointer g_make_keyword(s7_scheme *sc, s7_pointer args)
{
  #define H_make_keyword "(make-keyword str) prepends ':' to str and defines that as a keyword"
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->MAKE_KEYWORD, args);
      return(simple_wrong_type_argument(sc, sc->MAKE_KEYWORD, car(args), T_STRING));
    }
  return(s7_make_keyword(sc, string_value(car(args))));
}


static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon"
  s7_pointer sym;

  sym = car(args);
  if (!is_keyword(sym))
    {
      CHECK_METHOD(sc, sym, sc->KEYWORD_TO_SYMBOL, args);
      return(simple_wrong_type_argument_with_type(sc, sc->KEYWORD_TO_SYMBOL, sym, make_protected_string(sc, "a keyword")));
    }
  return(keyword_symbol(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"
  if (!is_symbol(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->SYMBOL_TO_KEYWORD, args);
      return(simple_wrong_type_argument(sc, sc->SYMBOL_TO_KEYWORD, car(args), T_SYMBOL));
    }
  return(s7_make_keyword(sc, symbol_name(car(args))));
}



/* ---------------- uninterpreted pointers ---------------- */

bool s7_is_c_pointer(s7_pointer arg) 
{
  return(type(arg) == T_C_POINTER);
}


void *s7_c_pointer(s7_pointer p) 
{
  if ((is_number(p)) && 
      (s7_integer(p) == 0))
    return(NULL); /* special case where the null pointer has been cons'd up by hand */

  if (type(p) != T_C_POINTER)
    {
      fprintf(stderr, "s7_c_pointer argument is not a c pointer?");
      return(NULL);
    }

  return(raw_pointer(p));
}


s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_C_POINTER);
  raw_pointer(x) = ptr;
  return(x);
}


static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args)
{
  #define H_is_c_pointer "(c-pointer? obj) returns #t if obj is a C pointer being held in s7."
  return(make_boolean(sc, type(car(args)) == T_C_POINTER));
}


static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer "(c-pointer int) returns a c-pointer object."
  if (!s7_is_integer(car(args)))
    return(wrong_type_argument(sc, sc->C_POINTER, small_int(1), car(args), T_INTEGER));
  return(s7_make_c_pointer(sc, (void *)s7_integer(car(args))));
}




/* -------------------------------- continuations and gotos -------------------------------- */

bool s7_is_continuation(s7_pointer p)    
{ 
  return(is_continuation(p));
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_continuation, sc->CONTINUATIONP, 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).
 *
 * how to recognize the call-with-exit function?  "goto" is an internal name.
 */

static s7_pointer protected_list_copy(s7_scheme *sc, s7_pointer a) 
{
  s7_pointer slow, fast, p;

  sc->w = cons(sc, car(a), sc->NIL);
  p = sc->w;

  slow = fast = cdr(a);
  while (true)
    {
      if (!is_pair(fast))
	{
	  if (is_null(fast))
	    return(sc->w);
	  cdr(p) = fast;
	  return(sc->w);
	}
      
      cdr(p) = cons(sc, car(fast), sc->NIL);
      p = cdr(p);

      fast = cdr(fast);
      if (!is_pair(fast)) 
	{
	  if (is_null(fast))
	    return(sc->w);
	  cdr(p) = fast;
	  return(sc->w);
	}
      /* if unrolled further, it's a lot slower? */
      cdr(p) = cons(sc, car(fast), sc->NIL);
      p = cdr(p);
      
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow) 
	return(sc->w);
    }
  return(sc->w);
}

static s7_pointer list_copy(s7_scheme *sc, s7_pointer x, s7_pointer y, bool step)
{
  if ((!is_pair(x)) ||
       (x == y))
    return(x);
  return(cons(sc, car(x), list_copy(sc, cdr(x), (step) ? cdr(y) : y, !step)));
}


static s7_pointer copy_arg_list(s7_scheme *sc, s7_pointer lst)
{
  /* 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))
   *
   * on the first call, we know lst is a pair
   */
  return(protected_list_copy(sc, lst));
}


static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer nobj;
  NEW_CELL(sc, nobj);
  counter_result(nobj) = counter_result(obj);
  counter_list(nobj) = counter_list(obj);
  counter_count(nobj) = counter_count(obj);
  counter_length(nobj) = counter_length(obj);
  counter_environment(nobj) = counter_environment(obj);
  set_type(nobj, T_COUNTER);
  return(nobj);
}


static s7_pointer copy_object(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer nobj;
  int nloc;

  NEW_CELL(sc, nobj);
  nloc = heap_location(nobj);
  memcpy((void *)nobj, (void *)obj, sizeof(s7_cell));
  heap_location(nobj) = nloc;
  
  /* nobj is safe here because the gc is off */
  if (dont_copy(car(obj)))
    car(nobj) = car(obj);
  else car(nobj) = copy_object(sc, car(obj));
  
  if ((dont_copy(cdr(obj))) ||
      (is_procedure_or_macro(obj)))
    cdr(nobj) = cdr(obj); /* closure_environment in func cases */
  else cdr(nobj) = copy_object(sc, cdr(obj));
  
  return(nobj);
}


static s7_pointer copy_stack(s7_scheme *sc, s7_pointer old_v, int top)
{
  int i, len;
  s7_pointer new_v;
  s7_pointer *nv, *ov;

  /* stacks can grow temporarily, so sc->stack_size grows, but we don't normally need all that
   *   leftover space here, so choose the original stack size if it's smaller.
   */

  len = vector_length(old_v);
  if ((top < INITIAL_STACK_SIZE / 2) &&
      (len > INITIAL_STACK_SIZE * 2))
    len = INITIAL_STACK_SIZE;

  new_v = s7_make_vector(sc, len);
  set_type(new_v, T_STACK);
  /* we can't leave the upper stuff simply malloc-garbage because we're sure to call the GC.
   *   We also can't just copy the vector since that seems to confuse the gc mark process.
   */

  nv = vector_elements(new_v);
  ov = vector_elements(old_v);
  
  s7_gc_on(sc, false);

  for (i = 0; i < top; i += 4)
    {
      s7_pointer p;
      if (dont_copy(ov[i]))
	nv[i] = ov[i];
      else nv[i] = copy_object(sc, ov[i]);    /* code */

      nv[i + 1] = ov[i + 1];                  /* environment pointer */
      nv[i + 3] = ov[i + 3];                  /* op (constant int) */

      p = ov[i + 2];
      if (is_pair(p))                         /* args need not be a list (it can be a port or #f, etc) */
	nv[i + 2] = copy_arg_list(sc, p);     /* args (copy is needed -- see s7test.scm) */
      else
	{
	  if (is_counter(p))                  /* these can only occur in this context */
	    nv[i + 2] = copy_counter(sc, p);
	  else nv[i + 2] = p;                 /* is this a safe assumption? */
	}
    }
  
  s7_gc_on(sc, true);
  return(new_v);
}


static s7_pointer make_goto(s7_scheme *sc) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  call_exit_goto_loc(x) = s7_stack_top(sc);
  call_exit_op_loc(x) = (int)(sc->op_stack_now - sc->op_stack);
  call_exit_active(x) = true;
  set_type(x, T_GOTO | T_PROCEDURE);
  return(x);
}


static s7_pointer *copy_op_stack(s7_scheme *sc)
{
  int len;
  s7_pointer *ops;
  ops = (s7_pointer *)malloc(sc->op_stack_size * sizeof(s7_pointer));
  /* memcpy((void *)ops, (void *)(sc->op_stack), sc->op_stack_size * sizeof(s7_pointer)); */
  len = (int)(sc->op_stack_now - sc->op_stack);
  if (len > 0)
    memcpy((void *)ops, (void *)(sc->op_stack), len * sizeof(s7_pointer));
  return(ops);
}


/* (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.
 *    It sets a T_BAFFLE var in a new env, that has a unique key.  Call/cc then always
 *    checks the env chain for any such variable, saving the localmost.  Apply of a continuation
 *    looks for such a saved variable, if none, go ahead, else check the current env (before the
 *    jump) for that variable.  If none, error, else go ahead.  This is different from a delimited
 *    continuation which simply delimits the extent of the continuation (why not use lambda?) -- we want to block it
 *    from coming at us from some unknown place.  
 */  


static int baffle_ctr = 0;

static s7_pointer make_baffle(s7_scheme *sc)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  baffle_key(x) = baffle_ctr++;
  set_type(x, T_BAFFLE);
  return(x);
}


static bool find_baffle(s7_scheme *sc, int key)
{
  /* search backwards through sc->envir for sc->BAFFLE with key as value
   */
  s7_pointer x, y;	
  for (x = sc->envir; is_environment(x); x = next_environment(x))
    for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
      if ((slot_symbol(y) == sc->BAFFLE) &&
	  (baffle_key(slot_value(y)) == key))
	return(true);
  return(false);
}


static int find_any_baffle(s7_scheme *sc)
{
  /* search backwards through sc->envir for any sc->BAFFLE
   */
  s7_pointer x, y;	
  if (baffle_ctr > 0)
    for (x = sc->envir; is_environment(x); x = next_environment(x))
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
	if (slot_symbol(y) == sc->BAFFLE)
	  return(baffle_key(slot_value(y)));
  return(-1);
}


s7_pointer s7_make_continuation(s7_scheme *sc) 
{
  s7_pointer x;
  int loc;
  if ((int)(sc->free_heap_top - sc->free_heap) < (int)(sc->heap_size / 4))
    gc(sc);

  /* this gc call is needed if there are lots of call/cc's -- by pure bad luck
   *   we can end up hitting the end of the gc free list time after time while
   *   in successive copy_stack's below, causing s7 to core up until it runs out of memory.
   */

  loc = s7_stack_top(sc);

  NEW_CELL(sc, x);
  continuation_data(x) = (s7_continuation_t *)calloc(1, sizeof(s7_continuation_t));
  continuation_stack(x) = copy_stack(sc, sc->stack, s7_stack_top(sc));
  continuation_stack_size(x) = vector_length(continuation_stack(x));   /* copy_stack can return a smaller stack than the current one */
  continuation_stack_start(x) = vector_elements(continuation_stack(x));
  continuation_stack_end(x) = (s7_pointer *)(continuation_stack_start(x) + loc);

  continuation_op_stack(x) = copy_op_stack(sc);
  continuation_op_loc(x) = (int)(sc->op_stack_now - sc->op_stack);
  continuation_op_size(x) = sc->op_stack_size;

  continuation_key(x) = find_any_baffle(sc);

  set_type(x, T_CONTINUATION | T_PROCEDURE);
  add_continuation(sc, x);
  return(x);
}


static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
{
  int i, s_base = 0, c_base = -1;
  opcode_t op;

  for (i = s7_stack_top(sc) - 1; i > 0; i -= 4)
    {
      s7_pointer x;

      op = stack_op(sc->stack, i);
      switch (op)
	{
	case OP_DYNAMIC_WIND:
	  {
	    int j;
	    x = stack_code(sc->stack, i);
	    for (j = 3; j < continuation_stack_top(c); j += 4)
	      if ((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) &&
		  (x == stack_code(continuation_stack(c), j)))
		{
		  s_base = i;
		  c_base = j;
		  break;
		}
	  
	    if (s_base != 0)
	      break;	  
	  
	    if (dynamic_wind_state(x) == DWIND_BODY)
	      {
		dynamic_wind_state(x) = DWIND_FINISH;
		if (dynamic_wind_out(x) != sc->F)
		  {
		    push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
		    sc->args = sc->NIL;
		    sc->code = dynamic_wind_out(x);
		    eval(sc, OP_APPLY);
		  }
	      }
	  }
	  break;

	case OP_BARRIER:
	  if (i > continuation_stack_top(c))  /* otherwise it's some unproblematic outer eval-string? */
	    return(false);                    /*    but what if we've already evaluated a dynamic-wind closer? */
	  break;

	case OP_DEACTIVATE_GOTO:              /* here we're jumping out of an unrelated call-with-exit block */
	  if (i > continuation_stack_top(c))
	    call_exit_active(stack_args(sc->stack, i)) = false;
	  break;

	default:
	  break;
	}
    }
  
  for (i = c_base + 4; i < continuation_stack_top(c); i += 4)
    {
      op = stack_op(continuation_stack(c), i);

      if (op == OP_DYNAMIC_WIND)
	{
	  s7_pointer x;
	  x = stack_code(continuation_stack(c), i);
	  if (dynamic_wind_in(x) != sc->F)
	    {
	      push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
	      sc->args = sc->NIL;
	      sc->code = dynamic_wind_in(x);
	      eval(sc, OP_APPLY);
	    }
	  dynamic_wind_state(x) = DWIND_BODY;
	}
      else
	{
	  if (op == OP_DEACTIVATE_GOTO)
	    call_exit_active(stack_args(continuation_stack(c), i)) = true;
	}
    }
  return(true);
}


static bool call_with_current_continuation(s7_scheme *sc)
{
  s7_pointer c;
  c = sc->code;

  /* check for (baffle ...) blocking the current attempt to continue
   */
  if (continuation_key(c) >= 0)
    {
      if (!(find_baffle(sc, continuation_key(c))))
	{
	  /* should this raise an error? */
	  return(false);
	}
    }

  if (!check_for_dynamic_winds(sc, c)) /* if OP_BARRIER on stack deeper than continuation top(?), but when does this happen? */
    return(true);

  /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc
   */

  sc->stack = copy_stack(sc, continuation_stack(c), continuation_stack_top(c));
  sc->stack_size = continuation_stack_size(c);
  sc->stack_start = vector_elements(sc->stack);
  sc->stack_end = (s7_pointer *)(sc->stack_start + continuation_stack_top(c));
  sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + sc->stack_size / 2);

  {
    int i, top;
    top = continuation_op_loc(c);
    sc->op_stack_now = (s7_pointer *)(sc->op_stack + top);
    sc->op_stack_size = continuation_op_size(c);
    sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
    for (i = 0; i < top; i++)
      sc->op_stack[i] = continuation_op_stack(c)[i];
  }

  if (is_null(sc->args))
    sc->value = sc->NIL;
  else
    {
      if (is_null(cdr(sc->args)))
	sc->value = car(sc->args);
      else sc->value = splice_in_values(sc, sc->args);
    }
  return(true);
}


static void call_with_exit(s7_scheme *sc)
{
  int i, new_stack_top;
  
  if (!call_exit_active(sc->code))
    s7_error(sc, make_symbol(sc, "invalid-escape-function"),
	     list_1(sc, make_protected_string(sc, "call-with-exit escape procedure called outside its block")));
  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 */
  for (i = s7_stack_top(sc) - 1; i > new_stack_top; i -= 4)
    {
      opcode_t op;

      op = stack_op(sc->stack, i);
      switch (op)
	{
	case OP_DYNAMIC_WIND:
	  {
	    sc->z = stack_code(sc->stack, i);
	    if (dynamic_wind_state(sc->z) == DWIND_BODY)
	      {
		dynamic_wind_state(sc->z) = DWIND_FINISH;
		if (dynamic_wind_out(sc->z) != sc->F)
		  {
		    push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
		    sc->args = sc->NIL;
		    sc->code = dynamic_wind_out(sc->z);
		    sc->z = sc->NIL;
		    eval(sc, OP_APPLY);
		  }
		else sc->z = sc->NIL;
	      }
	  }
	  break;

	case OP_EVAL_STRING_2:
	  s7_close_input_port(sc, sc->input_port);
	  pop_input_port(sc);
	  break;

	case OP_BARRIER:                /* oops -- we almost certainly went too far */
	  return; 

	case OP_DEACTIVATE_GOTO:        /* here we're jumping into an unrelated call-with-exit block */
	  call_exit_active(stack_args(sc->stack, i)) = false;
	  break;

	  /* call/cc does not close files, but I think call-with-exit should */
	case OP_UNWIND_OUTPUT:
	  {
	    s7_pointer x;
	    x = stack_code(sc->stack, i);                /* "code" = port that we opened */
	    s7_close_output_port(sc, x);
	    x = stack_args(sc->stack, i);                /* "args" = port that we shadowed, if not #f */
	    if (x != sc->F)
	      sc->output_port = x;
	  }
	  break;

	case OP_UNWIND_INPUT:
	  s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */
	  sc->input_port = stack_args(sc->stack, i);         /* "args" = port that we shadowed */
	  break;

	default:
	  break;
	}
    }
	    
  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 */
  if (is_null(sc->args))
    sc->value = sc->NIL;
  else
    {
      if (is_null(cdr(sc->args)))
	sc->value = car(sc->args);
      else sc->value = 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 func) is always a mistake!"
  s7_pointer p;

  p = car(args);                             /* this is the procedure passed to call/cc */
  
  if (!is_procedure(p))                      /* this includes continuations */
    {
      CHECK_METHOD(sc, p, sc->CALL_CC, args);
      return(simple_wrong_type_argument_with_type(sc, sc->CALL_CC, p, A_PROCEDURE));
    }
  if (!s7_is_aritable(sc, p, 1))
    return(s7_error(sc, sc->WRONG_TYPE_ARG, 
		    list_2(sc, make_protected_string(sc, "call/cc procedure, ~A, should take one argument"), p)));

  sc->w = s7_make_continuation(sc);
  push_stack(sc, OP_APPLY, list_1(sc, sc->w), p);
  sc->w = sc->NIL;

  return(sc->NIL);
}

/* we can't naively optimize call/cc to call-with-exit if the continuation is only
 *   used as a function in the call/cc body because it might (for example) be wrapped
 *   in a lambda form that is being exported.  See b-func in s7test for an example.
 */


static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_exit "(call-with-exit func) is call/cc without the ability to jump back into a previous computation."
  s7_pointer p, x;
  
  /* (call-with-exit (lambda (return) ...)) */
  p = car(args);
  if (!is_procedure(p))                           /* this includes continuations */
    {
      CHECK_METHOD(sc, p, sc->CALL_WITH_EXIT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->CALL_WITH_EXIT, p, A_PROCEDURE));
    }
  x = make_goto(sc);
  push_stack(sc, OP_DEACTIVATE_GOTO, x, sc->NIL); /* this means call-with-exit is not tail-recursive */
  push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->NIL), p);

  /* if the lambda body calls the argument as a function, 
   *   it is applied to its arguments, apply notices that it is a goto, and...
   *   
   *      (conceptually...) sc->stack_top = call_exit_goto_loc(sc->code);      
   *      s_pop(sc, (is_not_null(sc->args)) ? car(sc->args) : sc->NIL);
   * 
   *   which jumps to the point of the goto returning car(args).
   *
   * There is one gotcha: we can't jump back in from outside, so if the caller saves the goto
   *   and tries to invoke it outside the call-with-exit block, we have to
   *   make sure it triggers an error.  So, if the escape is called, it then
   *   deactivates itself.  Otherwise the block returns, we pop to OP_DEACTIVATE_GOTO,
   *   and it finds the goto in sc->args.
   * Even worse:
   *
       (let ((cc #f))
         (call-with-exit
           (lambda (c3)
             (call/cc (lambda (ret) (set! cc ret)))
             (c3)))
         (cc))
   *
   * where we jump back into a call-with-exit body via call/cc, the goto has to be
   * re-established.
   *
   * I think call-with-exit could be based on catch, but it's a simpler notion,
   *   and certainly at the source level it is easier to read.
   */
  
  return(sc->NIL);
}





/* -------------------------------- numbers -------------------------------- */

#if WITH_GMP
static char *big_number_to_string_with_radix(s7_pointer p, int radix, int width, int *nlen, use_write_t use_write);
  static bool big_numbers_are_eqv(s7_pointer a, s7_pointer b);
  static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int radix);
  static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const char *dstr, int radix);
  static s7_pointer string_to_either_real(s7_scheme *sc, const char *str, int radix);
  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, 
					     int radix, int has_plus_or_minus);
  static s7_pointer big_add(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_subtract(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_multiply(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_divide(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_random(s7_scheme *sc, s7_pointer args);
  static s7_pointer s7_Int_to_big_integer(s7_scheme *sc, s7_Int val);
  static s7_pointer s7_ratio_to_big_ratio(s7_scheme *sc, s7_Int num, s7_Int den);
  static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer p);
  static s7_pointer promote_number(s7_scheme *sc, int type, s7_pointer x);
  static s7_pointer big_equal(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_negate(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_invert(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_inexact_to_exact(s7_scheme *sc, s7_pointer args);
  static s7_pointer big_exact_to_inexact(s7_scheme *sc, s7_pointer args);
  static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val);
  static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val);
  static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val);
  static s7_pointer mpc_to_big_complex(s7_scheme *sc, mpc_t val);
  static s7_Int big_integer_to_s7_Int(mpz_t n);
#endif


#define s7_Int_abs(x) ((x) >= 0 ? (x) : -(x))
/* can't use abs even in gcc -- it doesn't work with long long ints! */

#define s7_fabsl(x) (((x) < 0.0) ? -(x) : (x))
/* fabsl doesn't exist in netBSD! There is a __NetBSD__ flag I think
 */

static bool is_NaN(s7_Double x) {return(x != x);}
/* callgrind says this is faster than isnan, I think (very confusing data...) */

/* in c++11 I think we'll have to #define is_inf(x) std::isinf(x) or some such subterfuge
 *   does std::isinf work in all earlier versions?
 *   Another possibility: (x * 0) != 0
 */
#if __cplusplus
  #define is_inf(x) std::isinf(x)
#else
  #define is_inf(x) isinf(x)
#endif

#if MS_WINDOWS
/* need to provide inverse hyperbolic trig funcs and cbrt */

double asinh(double x);
double asinh(double x) 
{ 
  return(log(x + sqrt(1.0 + x * x))); 
} 


double acosh(double x);
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)))
   */
} 


double atanh(double x);
double atanh(double x)
{ 
  return(log((1.0 + x) / (1.0 - x)) / 2.0); 
} 


double cbrt(double x);
double cbrt(double x)
{
  if (x >= 0.0)
    return(pow(x, 1.0 / 3.0));
  return(-pow(-x, 1.0 / 3.0));
}

//static bool is_inf(s7_Double x) { return((x == x) && (is_NaN(x - x))); }

#endif


#if defined(__sun) && defined(__SVR4)
  static bool is_inf(s7_Double x) {return((x == x) && (is_NaN(x - x)));}
#endif


#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 csinh(x) sinh(x)
  #define ccosh(x) cosh(x)
#else
  typedef double complex s7_Complex;
#endif

/* Trigonometric functions. 
 *    FreeBSD's math library does not include the complex form of the trig funcs.
 *    FreeBSD supplies cabs carg cimag creal conj csqrt, so can we assume those exist if complex.h exists?
 */

#if 0
static s7_Double carg(s7_Complex z) {return(atan2(cimag(z), creal(z)));} 
static s7_Double cabs(s7_Complex z) {return(hypot(creal(z), cimag(z)));} 
static s7_Complex conj(s7_Complex z){return(~z);} 
static s7_Complex csqrt(s7_Complex z) 
{ 
  if (cimag(z) < 0.0) 
    return(conj(csqrt(conj(z)))); 
  else 
    { 
      s7_Double r = cabs(z); 
      s7_Double x = creal(z); 
      return(sqrt((r + x) / 2.0) + sqrt((r - x) / 2.0) * _Complex_I); 
    } 
} 
#endif


#if (!HAVE_COMPLEX_TRIG)

#if (!__cplusplus)
#if (!defined(__FreeBSD_version)) || (__FreeBSD_version < 1000000)
/* FreeBSD 9 doesn't have csin ccos ctan, but 10 does */

static s7_Complex csin(s7_Complex z) 
{ 
  return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * _Complex_I); 
} 


static s7_Complex ccos(s7_Complex z) 
{ 
  return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * _Complex_I); 
} 


static s7_Complex csinh(s7_Complex z) 
{ 
  return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * _Complex_I); 
} 


static s7_Complex ccosh(s7_Complex z) 
{ 
  return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * _Complex_I); 
} 

#endif /* FreeBSD 9 */
#endif /* c++ */


#if (!defined(__FreeBSD_version)) || (__FreeBSD_version < 1000000)

static s7_Complex ctan(s7_Complex z) 
{ 
  return(csin(z) / ccos(z)); 
} 


static s7_Complex ctanh(s7_Complex z) 
{ 
  return(csinh(z) / ccosh(z)); 
} 

#endif /* FreeBSD 9 */


#if (!__cplusplus)
#if (!defined(__FreeBSD_version)) || (__FreeBSD_version < 900000)
/* FreeBSD 8 doesn't have cexp, but 9 does */

static s7_Complex cexp(s7_Complex z) 
{ 
  return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * _Complex_I); 
} 
#endif /* FreeBSD 8 */


static s7_Complex clog(s7_Complex z) 
{ 
  return(log(fabs(cabs(z))) + carg(z) * _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)) * _Complex_I); /* make-polar */ 
} 

#endif /* c++ */


static s7_Complex casin(s7_Complex z) 
{ 
  return(-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z))); 
} 


static s7_Complex cacos(s7_Complex z) 
{ 
  return(-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z))); 
} 


static s7_Complex catan(s7_Complex z) 
{ 
  return(_Complex_I * clog((_Complex_I + z) / (_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))); 
  /* perhaps less prone to numerical troubles (untested):
   *   2.0 * clog(csqrt(0.5 * (z + 1.0)) + csqrt(0.5 * (z - 1.0)))
   */
} 


static s7_Complex catanh(s7_Complex z) 
{ 
  return(clog((1.0 + z) / (1.0 - z)) / 2.0); 
} 
#endif

#else
/* not HAVE_COMPLEX_NUMBERS */
  typedef double s7_Complex;
  #define _Complex_I 1
  #define creal(x) x
  #define cimag(x) x
  #define csin(x) sin(x)
  #define casin(x) x
  #define ccos(x) cos(x)
  #define cacos(x) x
  #define ctan(x) x
  #define catan(x) x
  #define csinh(x) x
  #define casinh(x) x
  #define ccosh(x) x
  #define cacosh(x) x
  #define ctanh(x) x
  #define catanh(x) x
  #define cexp(x) exp(x)
  #define cpow(x, y) pow(x, y)
  #define clog(x) log(x)
  #define csqrt(x) sqrt(x)
  #define conj(x) x
#endif


bool s7_is_number(s7_pointer p)
{
#if WITH_GMP
  return((is_number(p)) || (is_big_number(p)));
#else
  return(is_number(p));
#endif
}


bool s7_is_integer(s7_pointer p) 
{ 
#if WITH_GMP
  return((type(p) == T_INTEGER) ||
	 (type(p) == T_BIG_INTEGER));
#else
  return(is_integer(p));
#endif
}


bool s7_is_real(s7_pointer p) 
{ 
#if WITH_GMP
  return((is_real(p)) ||
	 (type(p) == T_BIG_INTEGER) ||
	 (type(p) == T_BIG_RATIO) ||
	 (type(p) == T_BIG_REAL));
#else
  return(is_real(p)); /* in GSL, a NaN or inf is not a real, or perhaps better, finite = not (nan or inf) */
#endif
}


bool s7_is_rational(s7_pointer p)
{
#if WITH_GMP
  return((is_rational(p)) ||
	 (type(p) == T_BIG_INTEGER) ||
	 (type(p) == T_BIG_RATIO));
#else
  return(is_rational(p));
#endif
}


bool s7_is_ratio(s7_pointer p)
{
#if WITH_GMP
  return((type(p) == T_RATIO) ||
	 (type(p) == T_BIG_RATIO));
#else
  return(type(p) == T_RATIO);
#endif
}


bool s7_is_complex(s7_pointer p)
{
#if WITH_GMP
  return((is_number(p)) || (is_big_number(p)));
#else
  return(is_number(p));
#endif
}


bool s7_is_exact(s7_pointer p)
{
  return(s7_is_rational(p));
}


bool s7_is_inexact(s7_pointer p)
{
  return(!s7_is_rational(p));
}


static s7_Int c_gcd(s7_Int u, s7_Int v)
{
  s7_Int a, b, temp;
  
  a = s7_Int_abs(u);  /* trouble if either is most-negative-fixnum... */
  b = s7_Int_abs(v);
  while (b != 0)
    {
      temp = a % b;
      a = b;
      b = temp;
    }
  if (a < 0)
    return(-a);
  return(a);
}


static bool c_rationalize(s7_Double ux, s7_Double error, s7_Int *numer, s7_Int *denom)
{
  /*
    (define* (rat ux (err 0.0000001))
      ;; translated from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms"
      (let ((x0 (- ux error))
	    (x1 (+ ux error)))
        (let ((i (ceiling x0))
	      (i0 (floor x0))
	      (i1 (ceiling x1))
	      (r 0))
          (if (>= x1 i)
	      i
	      (do ((p0 i0 (+ p1 (* r p0)))
	           (q0 1 (+ q1 (* r q0)))
	           (p1 i1 p0)
	           (q1 1 q0)
	           (e0 (- i1 x0) e1p)
	           (e1 (- x0 i0) (- e0p (* r e1p)))
	           (e0p (- i1 x1) e1)
	           (e1p (- x1 i0) (- e0 (* r e1))))
	          ((<= x0 (/ p0 q0) x1)
	           (/ p0 q0))
	        (set! r (min (floor (/ e0 e1))
			     (ceiling (/ e0p e1p)))))))))
  */
  
  double x0, x1, val;
  s7_Int i, i0, i1, r, r1, p0, q0, p1, q1;
  double e0, e1, e0p, e1p;
  s7_Int old_p1, old_q1;
  double old_e0, old_e1, old_e0p;
  int tries = 0;
  /* don't use s7_Double here;  if it is "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 ((ux > s7_Int_max) || (ux < s7_Int_min))
    {
      /* can't return false here because that confuses some of the callers!
       */
      if (ux > s7_Int_min) (*numer) = s7_Int_max; else (*numer) = s7_Int_min;
      (*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)
	{
	  if (x1 < 0)
	    (*numer) = (s7_Int)floor(x1);
	  else (*numer) = 0;
	}
      else
	{
	  (*numer) = i;
	}
      (*denom) = 1;
      return(true);
    }
  
  if (x1 >= i)
    {
      if (i >= 0)
	(*numer) = i;
      else (*numer) = (s7_Int)floor(x1);
      (*denom) = 1;
      return(true);
    }

  i0 = (s7_Int)floor(x0);
  i1 = (s7_Int)ceil(x1);

  p0 = i0; 
  q0 = 1;
  p1 = i1; 
  q1 = 1; 
  e0 = i1 - x0;
  e1 = x0 - i0;
  e0p = i1 - x1;
  e1p = x1 - i0;

  while (true)
    {
      val = (double)p0 / (double)q0;
      
      if (((x0 <= val) && (val <= x1)) ||
	  (e1 == 0)                    ||
	  (e1p == 0)                   ||
	  (tries > 100))
	{
	  (*numer) = p0;
	  (*denom) = q0;
	  return(true);
	}
      tries++;

      r = (s7_Int)floor(e0 / e1);
      r1 = (s7_Int)ceil(e0p / e1p);
      if (r1 < r) r = r1;

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

#if 0
/* there is another way to rationalize (in fact there are many ways!).  Here is a scheme version of
 *   Bill Gosper's farint:

(define* (farint x (err 1/1000000))
  
  (define* (farint-1 x nhi dhi (ln 0) (ld 1) (hn 1) (hd 0))
    (if (> (+ ln hn) (* (+ ld hd) x))
	(let* ((m (min (if (= 0 ln) 
			   nhi 
			 (floor (/ (- nhi hn) ln)))
		       (floor (/ (- dhi hd) ld))))
	       (d (- (* x ld) ln))
	       (k (if (= 0 d) 
		      m 
		    (ceiling (/ (- hn (* x hd)) d)))))
	  (if (< k m)
	      (let ((hn1 (+ (* k ln) hn))
		    (hd1 (+ (* k ld) hd)))
		(farint-1 x nhi dhi hn1 hd1 (- hn1 ln) (- hd1 ld)))

	    (let* ((n (+ (* m ln) hn)) (d (+ (* m ld) hd)))
	      (if (< (* 2 d ld x) (+ (* ld n) (* ln d)))
		  (/ ln ld) 
		(/ n d)))))

      (let* ((m (min (floor (/ (- nhi ln) hn))
		     (if (= 0 hd) 
			 dhi 
		       (floor (/ (- dhi ld) hd)))))
	     (d (- hn (* x hd)))
	     (k (if (= 0 d) 
		    m 
		  (ceiling (/ (- (* x ld) ln) d)))))
	(if (< k m)
	    (let ((ln1 (+ (* k hn) ln))
		  (ld1 (+ (* k hd) ld)))
	    (farint-1 x nhi dhi (- ln1 hn) (- ld1 hd) ln1 ld1))
	  (let* ((n (+ (* m hn) ln)) (d (+ (* m hd) ld)))
	    (if (< (* 2 d hd x) (+ (* hd n) (* hn d)))
		(/ n d) 
	      (/ hn hd)))))))

  (farint-1 x (/ err) (/ err)))
*/
#endif


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(s7_make_ratio(sc, numer, denom));
  return(s7_make_real(sc, x));
}



#if (!WITH_GCC)
static s7_Double number_to_real(s7_pointer n)
{
  if (type(n) >= T_REAL)
    return(real(n));
  if (type(n) == T_INTEGER)
    return((s7_Double)integer(n));
  return(fraction(n));
}
#else
#define number_to_real(_n_) ({ s7_pointer N; N = _n_; ((type(N) >= T_REAL) ? real(N) : ((type(N) == T_INTEGER) ? ((s7_Double)integer(N)) : (s7_Double)(fraction(N)))); })
#endif


static s7_Int number_to_numerator(s7_pointer n)
{
  if (type(n) == T_RATIO)
    return(numerator(n));
  return(integer(n));
}


static s7_Int number_to_denominator(s7_pointer n)
{
  if (type(n) == T_RATIO)
    return(denominator(n));
  return(1);
}


s7_pointer s7_make_integer(s7_scheme *sc, s7_Int n) 
{
  s7_pointer x;

  /* if ((n & ~(NUM_SMALL_INTS - 1)) == 0)   */         /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */
  if (is_small(n))
    return(small_int(n));

  NEW_CELL(sc, x);
  set_type(x, T_INTEGER);
  integer(x) = n;

  return(x);
}


static s7_pointer make_mutable_integer(s7_scheme *sc, s7_Int n)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_INTEGER | T_MUTABLE);
  integer(x) = n;
  return(x);
}


static s7_pointer make_permanent_integer(s7_Int i)
{
  s7_pointer p;
  p = (s7_pointer)calloc(1, sizeof(s7_cell));
  typeflag(p) = T_IMMUTABLE | T_INTEGER;
  heap_location(p) = NOT_IN_HEAP;
  integer(p) = i;
  return(p);
}


s7_pointer s7_make_real(s7_scheme *sc, s7_Double n) 
{
  s7_pointer x;

  if (n == 0.0)
    return(real_zero);

  NEW_CELL(sc, x);
  set_type(x, T_REAL);
  real(x) = n;
  
  return(x);
}


s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_Double n) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_REAL | T_MUTABLE);
  real(x) = n;
  return(x);
}

bool s7_is_mutable(s7_pointer p)
{
  return(is_mutable(p));
}


static s7_pointer make_permanent_real(s7_Double n) 
{
  s7_pointer x;
  int nlen = 0;
  char *str;

  x = (s7_pointer)calloc(1, sizeof(s7_cell));
  set_type(x, T_IMMUTABLE | T_REAL);
  heap_location(x) = NOT_IN_HEAP;
  real(x) = n;

  str = number_to_string_base_10(x, 0, WRITE_REAL_PRECISION, 'g', &nlen, USE_WRITE);
  set_print_name(x, str, nlen);

  return(x);
}


s7_pointer s7_remake_real(s7_scheme *sc, s7_pointer rl, s7_Double n) 
{
  if (is_simple_real(rl))
    {
      real(rl) = n;
      return(rl);
    }
  return(make_real(sc, n));
}


s7_pointer s7_make_complex(s7_scheme *sc, s7_Double a, s7_Double b)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  if (b == 0.0)
    {
      set_type(x, T_REAL);
      real(x) = a;
    }
  else
    {
      set_type(x, T_COMPLEX);
      real_part(x) = a;
      imag_part(x) = b;
    }
  return(x);
}


s7_pointer s7_make_ratio(s7_scheme *sc, s7_Int a, s7_Int b)
{
  s7_pointer x;
  s7_Int divisor;

  if (b == 0)
    return(division_by_zero_error(sc, make_protected_string(sc, "make-ratio"), list_2(sc, make_integer(sc, a), small_int(0))));
  if (a == 0)
    return(small_int(0));
  if (b == 1)
    return(make_integer(sc, a));

#if (!WITH_GMP)
  if (b == S7_LLONG_MIN)
    {
      if (a == b)
	return(small_int(1));

      /* we've got a problem... 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.
       *   We'll try to do something...
       */
      if (a & 1)
	{
	  if (a == 1)
	    return(real_NaN);
	  /* not an error here because 1/9223372036854775808 might be in a block of unevaluated code */
	  b = b + 1;
	}
      else
	{
	  a /= 2;
	  b /= 2;
	}
    }
#endif

  if (b < 0)
    {
      a = -a;
      b = -b;
    }
  divisor = c_gcd(a, b);
  if (divisor != 1)
    {
      a /= divisor;
      b /= divisor;
    }
  if (b == 1)
    return(make_integer(sc, a));
  
  NEW_CELL(sc, x);
  set_type(x, T_RATIO);
  numerator(x) = a;
  denominator(x) = b;

  return(x);
}



static s7_pointer exact_to_inexact(s7_scheme *sc, s7_pointer x)
{
  /* this is tricky because a big int can mess up when turned into a double:
   *   (truncate (exact->inexact most-positive-fixnum)) -> -9223372036854775808
   */
  switch (type(x))
    {
    case T_INTEGER:
      return(make_real(sc, (s7_Double)(integer(x))));

    case T_RATIO:
      return(make_real(sc, (s7_Double)(fraction(x))));

    case T_REAL:
    case T_COMPLEX:              /* apparently (exact->inexact 1+i) is not an error */
      return(x);

    default:
      CHECK_METHOD(sc, x, sc->EXACT_TO_INEXACT, list_1(sc, x));
      return(simple_wrong_type_argument_with_type(sc, sc->INEXACT_TO_EXACT, x, A_NUMBER));
    }
}



#define WITH_OVERFLOW_ERROR true
#define WITHOUT_OVERFLOW_ERROR false

static double default_rationalize_error = 1.0e-12;

static s7_pointer inexact_to_exact(s7_scheme *sc, s7_pointer x, bool with_error)
{
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(x);

    case T_REAL:
      {
	s7_Int numer = 0, denom = 1;
	s7_Double val;

	val = s7_real(x);
	if ((is_inf(val)) || (is_NaN(val)))
	  {
	    if (with_error)
	      return(simple_wrong_type_argument_with_type(sc, sc->INEXACT_TO_EXACT, x, A_NORMAL_REAL));
	    return(sc->NIL);
	  }

	if ((val > S7_LLONG_MAX) ||
	    (val < S7_LLONG_MIN))
	  {
	    if (with_error)
	      return(simple_out_of_range(sc, sc->INEXACT_TO_EXACT, x, "too large to express as an integer"));
	    return(sc->NIL);
	  }

	if (c_rationalize(val, default_rationalize_error, &numer, &denom))
	  return(s7_make_ratio(sc, numer, denom));
      }

    default:
      if (with_error)
	{
	  CHECK_METHOD(sc, x, sc->INEXACT_TO_EXACT, list_1(sc, x));
	  return(simple_wrong_type_argument(sc, sc->INEXACT_TO_EXACT, x, T_REAL));
	}
      return(sc->NIL);
    }

  return(x);
}


s7_Double s7_number_to_real(s7_scheme *sc, s7_pointer x)
{
  if (type(x) == T_REAL)
    return(real(x));
  /* this is nearly always the case in current usage, so by avoiding the "switch" we can go twice as fast */

  switch (type(x))
    {
    case T_INTEGER: 
      return((s7_Double)integer(x));

    case T_RATIO:   
      return((s7_Double)numerator(x) / (s7_Double)denominator(x));

    case T_REAL:    
      return(real(x));

    case T_COMPLEX:
      return(real_part(x));

#if WITH_GMP
    case T_BIG_INTEGER:
      return((s7_Double)big_integer_to_s7_Int(big_integer(x)));

    case T_BIG_RATIO:
      return((s7_Double)((long double)big_integer_to_s7_Int(mpq_numref(big_ratio(x))) / (long double)big_integer_to_s7_Int(mpq_denref(big_ratio(x)))));

    case T_BIG_REAL:
      return((s7_Double)mpfr_get_d(big_real(x), GMP_RNDN));

    case T_BIG_COMPLEX:
      return((s7_Double)mpfr_get_d(mpc_realref(big_complex(x)), GMP_RNDN));
#endif
    }

  s7_wrong_type_arg_error(sc, "s7_number_to_real", 0, x, "a real number"); 
  return(0.0);
}


s7_Int s7_number_to_integer(s7_scheme *sc, s7_pointer x)
{
  /* this is called in xen.c */
  if (type(x) == T_INTEGER)
    return(integer(x));

  switch (type(x))
    {
    case T_INTEGER: 
      return(integer(x));

    case T_RATIO:   
      return((s7_Int)numerator(x) / (s7_Double)denominator(x));

    case T_REAL:    
      return((s7_Int)real(x));

    case T_COMPLEX: 
      return((s7_Int)real_part(x));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(big_integer_to_s7_Int(big_integer(x)));

    case T_BIG_RATIO:
      return((s7_Int)((double)big_integer_to_s7_Int(mpq_numref(big_ratio(x))) / (double)big_integer_to_s7_Int(mpq_denref(big_ratio(x)))));

    case T_BIG_REAL:
      return((s7_Int)mpfr_get_d(big_real(x), GMP_RNDN));

    case T_BIG_COMPLEX:
      return((s7_Int)mpfr_get_d(mpc_realref(big_complex(x)), GMP_RNDN));
#endif
    }
  s7_wrong_type_arg_error(sc, "s7_number_to_integer", 0, x, "an integer");
  return(0);
}


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(big_integer_to_s7_Int(big_integer(x)));

    case T_BIG_RATIO:
      return(big_integer_to_s7_Int(mpq_numref(big_ratio(x))));
#endif
    }

  return(0);
}


s7_Int s7_denominator(s7_pointer x)
{
  switch (type(x))
    {
    case T_RATIO:
      return(denominator(x));

#if WITH_GMP
    case T_BIG_RATIO:
      return(big_integer_to_s7_Int(mpq_denref(big_ratio(x))));
#endif
    }

  return(1);
}


s7_Int s7_integer(s7_pointer p)
{
#if WITH_GMP
  if (type(p) == T_BIG_INTEGER)
    return(big_integer_to_s7_Int(big_integer(p)));
#endif
  return(integer(p));
}


s7_Double s7_real(s7_pointer p)
{
#if WITH_GMP
  if (type(p) == T_BIG_REAL)
    return((s7_Double)mpfr_get_d(big_real(p), GMP_RNDN));
#endif
  return(real(p));
}


#if (!WITH_GMP)
static s7_Complex s7_complex(s7_pointer p)
{
  /* TODO: with-gmp case for big_complex
   *   and do we need to export the s7_Complex type?  This is all for cload.
   */
  return(s7_real_part(p) + s7_imag_part(p) * _Complex_I);
}


static s7_pointer s7_from_c_complex(s7_scheme *sc, s7_Complex z)
{
  return(s7_make_complex(sc, creal(z), cimag(z)));
}
#endif


static int integer_length(s7_Int a)
{
  static const int bits[256] =
    {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 
     6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 
     7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 
     7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 
     8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 
     8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 
     8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 
     8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8};

  #define I_8 256LL
  #define I_16 65536LL
  #define I_24 16777216LL
  #define I_32 4294967296LL
  #define I_40 1099511627776LL
  #define I_48 281474976710656LL
  #define I_56 72057594037927936LL

  /* a might be most-negative-fixnum! in Clisp: (integer-length -9223372036854775808) -> 63
   */
  if (a < 0) 
    {
      if (a == S7_LLONG_MIN) return(63);
      a = -a;
    }
  if (a < I_8) return(bits[a]);
  if (a < I_16) return(8 + bits[a >> 8]);
  if (a < I_24) return(16 + bits[a >> 16]);
  if (a < I_32) return(24 + bits[a >> 24]);
  /* this generates compiler warnings if s7_Int = int: how to make C happy? (we can't assume SIZEOF* is available) */
  if (a < I_40) return(32 + bits[a >> 32]);
  if (a < I_48) return(40 + bits[a >> 40]);
  if (a < I_56) return(48 + bits[a >> 48]);
  return(56 + bits[a >> 56]);
}


static int s7_int_max = 0, s7_int_min = 0, s7_int_bits = 0, s7_int_digits = 0; /* initialized later */
static int s7_int_digits_by_radix[17];


#if (!WITH_GMP)
static s7_pointer s7_negate(s7_scheme *sc, s7_pointer p)     /* can't use "negate" because it confuses C++! */
{
  switch (type(p))
    {
    case T_INTEGER: 
      return(make_integer(sc, -integer(p)));
      
    case T_RATIO:
      return(s7_make_ratio(sc, -numerator(p), denominator(p)));
      
    case T_REAL:
      return(make_real(sc, -real(p)));
      
    default:
      return(s7_make_complex(sc, -real_part(p), -imag_part(p)));
    }
}
#endif


static s7_pointer s7_invert(s7_scheme *sc, s7_pointer p)      /* s7_ to be consistent... */
{
  switch (type(p))
    {
    case T_INTEGER:
      return(s7_make_ratio(sc, 1, integer(p)));      /* a already checked, not 0 */
      
    case T_RATIO:
      return(s7_make_ratio(sc, denominator(p), numerator(p)));

    case T_REAL:
      return(make_real(sc, 1.0 / real(p)));

    case T_COMPLEX:
      {
	s7_Double r2, i2, den;
	r2 = real_part(p);
	i2 = imag_part(p);
	den = (r2 * r2 + i2 * i2);
	return(s7_make_complex(sc, r2 / den, -i2 / den));
      }

    default:
      return(wrong_type_argument_with_type(sc, sc->DIVIDE, small_int(1), p, A_NUMBER));
    }
}


static s7_pointer subtract_ratios(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  s7_Int d1, d2, n1, n2;
  d1 = number_to_denominator(x);
  n1 = number_to_numerator(x);
  d2 = number_to_denominator(y);
  n2 = number_to_numerator(y);
  
  if (d1 == d2)                                     /* the easy case -- if overflow here, it matches the int case */
    return(s7_make_ratio(sc, n1 - n2, d1));

#if (!WITH_GMP)
  if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
      (n1 > s7_int_max) || (n2 > s7_int_max) ||
      (n1 < s7_int_min) || (n2 < s7_int_min))
    {
      int d1bits, d2bits;
      d1bits = integer_length(d1);
      d2bits = integer_length(d2);
      if (((d1bits + d2bits) > s7_int_bits) ||
	  ((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
	  ((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
	return(make_real(sc, ((long double)n1 / (long double)d1) - ((long double)n2 / (long double)d2)));
      return(s7_make_ratio(sc, n1 * d2 - n2 * d1, d1 * d2));
    }
#endif
  return(s7_make_ratio(sc, n1 * d2 - n2 * d1, d1 * d2));
}



static bool s7_is_negative(s7_pointer obj)
{
  switch (type(obj))
    {
    case T_INTEGER: 
      return(integer(obj) < 0);

    case T_RATIO:   
      return(numerator(obj) < 0);

#if WITH_GMP
    case T_BIG_INTEGER:
      return(mpz_cmp_ui(big_integer(obj), 0) < 0);

    case T_BIG_RATIO:
      return(mpq_cmp_ui(big_ratio(obj), 0, 1) < 0);

    case T_BIG_REAL:
      return(mpfr_cmp_ui(big_real(obj), 0) < 0);
#endif

    default:        
      return(real(obj) < 0);
    }
}


static bool s7_is_positive(s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER: 
      return(integer(x) > 0);

    case T_RATIO:   
      return(numerator(x) > 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:        
      return(real(x) > 0.0);
    }
}



static bool s7_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 s7_is_one(s7_pointer x)
  {
  switch (type(x))
    {
    case T_INTEGER: 
      return(integer(x) == 1);

    case T_REAL:    
      return(real(x) == 1.0);

    default:        
      return(false);
    }
}


/* optimize exponents */
#define MAX_POW 32
static double pepow[17][MAX_POW], mepow[17][MAX_POW];

static void init_pows(void)
{
  int i, j;
  for (i = 2; i < 17; i++)        /* radix between 2 and 16 */
    for (j = 0; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */
      {
	pepow[i][j] = pow((double)i, (double)j);
	mepow[i][j] = pow((double)i, (double)(-j));
      }
}

static double ipow(int x, int y)
{
  if ((y < MAX_POW) && (y > (-MAX_POW)))
    {
      if (y >= 0)
	return(pepow[x][y]);
      return(mepow[x][-y]);
    }
  return(pow((double)x, (double)y));
}


static void s7_Int_to_string(char *p, s7_Int n, int radix, int width)
{
  static const char dignum[] = "0123456789abcdef";
  int i = 2, len, start = 0, end = 0;
  s7_Int pown = (s7_Int)1;
  bool sign;

  if ((radix < 2) || (radix > 16))
    return;
  if (n == 0)
    {
      if (width <= 1)
	{
	  p[0] = '0';
	  p[1] = '\0';
	}
      else
	{
	  for (i = 0; i < width - 1; i++) 
	    p[i] = ' ';
	  p[width - 1] = '0';
	  p[width] = '\0';
	}
      return;
    }

  if (n == S7_LLONG_MIN)
    {
      /* a special case -- we can't use abs on this because it goes to 0, we won't get here if gmp.
       * (number->string most-negative-fixnum 2) -> "-0" unless we do something special 
       */
      int j;
      p[0] = '-';
      /* build it backwards (will reverse digits below) */
      p[1] = dignum[-(n % (s7_Int)radix)];
      n /= (s7_Int)radix;
      n = -n;
      for (i = 2; n >= (s7_Int)radix; i++)
	{
	  p[i] = dignum[n % (s7_Int)radix];
	  n /= (s7_Int)radix;
	}
      p[i] = dignum[n];
      len = i;
      /* reverse digits (leave sign alone) */
      for (i = 1, j = len; i < j; i++, j--)
	{
	  char tmp;
	  tmp = p[i];
	  p[i] = p[j];
	  p[j] = tmp;
	}
      p[len + 1] = 0;
      return;
      /* there has to be a better way... */
    }
      
  sign = (n < 0);
  n = s7_Int_abs(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++;

  if (width > len)                  /* (format #f "~10B" 123) */
    {
      start = width - len - 1;
      end += start;
      memset((void *)p, (int)' ', start);
      /*
      for (i = 0; i < start; i++) 
	p[i] = ' ';
      */
    }

  if (sign)
    {
      p[start] = '-';
      end++;
    }

  for (i = start + len; i >= end; i--)
    {
      p[i] = dignum[n % (s7_Int)radix];
      n /= (s7_Int)radix;
    }
  p[len + start + 1] = '\0';
}


static char *integer_to_string_base_10_no_width(s7_pointer obj, int *nlen) /* do not free the returned string */
{
  #define INT_TO_STR_SIZE 64
  static char int_to_str[INT_TO_STR_SIZE];

  if (has_print_name(obj))
    {
      (*nlen) = print_name_length(obj);
      return((char *)print_name(obj));
    }
  (*nlen) = snprintf(int_to_str, INT_TO_STR_SIZE, "%lld", (long long int)integer(obj));
  return(int_to_str);
}


#define BASE_10 10
static int num_to_str_size = 0;
static char *num_to_str = NULL;

static char *floatify(char *str, int *nlen)
{
  if ((strchr(str, 'e') == NULL) &&
      (strchr(str, '.') == NULL))
    {
      int len;
      len = *nlen;
      str[len]='.';
      str[len + 1]='0';
      str[len + 2]='\0';
      (*nlen) = len + 2;
    }
  return(str);
}


static char *number_to_string_base_10(s7_pointer obj, int width, int precision, char float_choice, int *nlen, use_write_t choice) /* don't free result */
{
  int len;
  len = 256 + width;
  if (len > num_to_str_size)
    {
      if (num_to_str) free(num_to_str);
      num_to_str_size = len;
      num_to_str = (char *)malloc(len);
    }
  /* bignums can't happen here */
  switch (type(obj))
    {
    case T_INTEGER:
      if (width == 0)
	{
	  int nlen = 0;
	  return(integer_to_string_base_10_no_width(obj, &nlen));
	}
      (*nlen) = snprintf(num_to_str, num_to_str_size, "%*lld", width, (long long int)integer(obj));
      break;
      
    case T_RATIO:
      len = snprintf(num_to_str, num_to_str_size, "%lld/%lld", (long long int)numerator(obj), (long long int)denominator(obj));
      if (width > len)
	{
	  int spaces;
	  if (width >= num_to_str_size)
	    {
	      num_to_str_size = width + 1;
	      num_to_str = (char *)realloc(num_to_str, num_to_str_size * sizeof(char));
	    }
	  spaces = width - len;
	  num_to_str[width] = '\0';
	  memmove((void *)(num_to_str + spaces), (void *)num_to_str, len);    
	  memset((void *)num_to_str, (int)' ', spaces);	    
	  (*nlen) = width;
	}
      else (*nlen) = len;
      break;
      
    case T_REAL:
      {
	const char *frmt;

	if (sizeof(double) >= sizeof(s7_Double))
	  frmt = (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e");
	else frmt = (float_choice == 'g') ? "%*.*Lg" : ((float_choice == 'f') ? "%*.*Lf" : "%*.*Le");

	len = snprintf(num_to_str, num_to_str_size, frmt, width, precision, s7_real(obj));
	(*nlen) = len;
	floatify(num_to_str, nlen);
      }
      break;
      
    default:
      {
	if ((choice == USE_READABLE_WRITE) &&
	    ((is_NaN(real_part(obj))) || (is_NaN(imag_part(obj))) || ((is_inf(real_part(obj))) || (is_inf(imag_part(obj))))))
	  {
	    char rbuf[128], ibuf[128];
	    char *rp, *ip;
	    if (is_NaN(real_part(obj)))
	      rp = (char *)"nan.0";
	    else
	      {
		if (is_inf(real_part(obj)))
		  {
		    if (real_part(obj) < 0.0)
		      rp = (char *)"-inf.0";
		    else rp = (char *)"inf.0";
		  }
		else
		  {
		    snprintf(rbuf, 128, "%.*g", precision, real_part(obj));
		    rp = rbuf;
		  }
	      }
	    if (is_NaN(imag_part(obj)))
	      ip = (char *)"nan.0";
	    else
	      {
		if (is_inf(imag_part(obj)))
		  {
		    if (imag_part(obj) < 0.0)
		      ip = (char *)"-inf.0";
		    else ip = (char *)"inf.0";
		  }
		else
		  {
		    snprintf(ibuf, 128, "%.*g", precision, imag_part(obj));
		    ip = ibuf;
		  }
	      }
	    len = snprintf(num_to_str, num_to_str_size, "(make-rectangular %s %s)", rp, ip);
	  }
	else
	  {
	    const char *frmt;
	    if (sizeof(double) >= sizeof(s7_Double))
	      {
		if (imag_part(obj) >= 0.0)
		  frmt = (float_choice == 'g') ? "%.*g+%.*gi" : ((float_choice == 'f') ? "%.*f+%.*fi" : "%.*e+%.*ei"); 
		else frmt = (float_choice == 'g') ? "%.*g%.*gi" : ((float_choice == 'f') ? "%.*f%.*fi" :"%.*e%.*ei"); /* minus sign comes with the imag_part */
	      }
	    else 
	      {
		if (imag_part(obj) >= 0.0)
		  frmt = (float_choice == 'g') ? "%.*Lg+%.*Lgi" : ((float_choice == 'f') ? "%.*Lf+%.*Lfi" : "%.*Le+%.*Lei");
		else frmt = (float_choice == 'g') ? "%.*Lg%.*Lgi" : ((float_choice == 'f') ? "%.*Lf%.*Lfi" : "%.*Le%.*Lei");
	      }
	    
	    len = snprintf(num_to_str, num_to_str_size, frmt, precision, real_part(obj), precision, imag_part(obj));
	  }

	if (width > len)  /* (format #f "~20g" 1+i) */
	  {
	    int spaces;
	    if (width >= num_to_str_size)
	      {
		num_to_str_size = width + 1;
		num_to_str = (char *)realloc(num_to_str, num_to_str_size * sizeof(char));
	      }
	    spaces = width - len;
	    num_to_str[width] = '\0';
	    memmove((void *)(num_to_str + spaces), (void *)num_to_str, len);    
	    memset((void *)num_to_str, (int)' ', spaces);	    
	    (*nlen) = width;
	  }
	else (*nlen) = len;
      }
      break;
    }
  return(num_to_str);
}


static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int radix, int width, int precision, char float_choice, int *nlen)
{
  char *p, *n, *d;
  int len, str_len;

#if WITH_GMP
  if (s7_is_bignum(obj))
    return(big_number_to_string_with_radix(obj, radix, width, nlen, USE_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.
   */
#endif

  if (radix == 10)
    return(copy_string(number_to_string_base_10(obj, width, precision, float_choice, nlen, USE_WRITE)));

  switch (type(obj))
    {
    case T_INTEGER:
      if ((width == 0) &&
	  (radix == 10))
	return(copy_string(integer_to_string_base_10_no_width(obj, nlen)));
      p = (char *)malloc((128 + width) * sizeof(char));
      s7_Int_to_string(p, s7_integer(obj), radix, width);
      return(p);
      break;
      
    case T_RATIO:
      {
	char n[128], d[128];
	s7_Int_to_string(n, numerator(obj), radix, 0);
	s7_Int_to_string(d, denominator(obj), radix, 0);
	p = (char *)malloc(256 * sizeof(char));
	len = snprintf(p, 256, "%s/%s", n, d);
	str_len = 256;
      }
      break;
      
    case T_REAL:
      {
	int i;
	s7_Int int_part;
	s7_Double x, frac_part, min_frac, base;
	bool sign = false;
	char n[128], d[256];

	x = s7_real(obj);

	if (is_NaN(x))
	  return(copy_string_with_len("nan.0", 5));
	if (is_inf(x))
	  {
	    if (x < 0.0)
	      return(copy_string_with_len("-inf.0", 6));    
	    return(copy_string_with_len("inf.0", 5));    
	  }

	if (x < 0.0)
	  {
	    sign = true;
	    x = -x;
	  }

	int_part = (s7_Int)floor(x);
	frac_part = x - int_part;
	s7_Int_to_string(n, int_part, radix, 0);
	min_frac = (s7_Double)ipow(radix, -precision);

	for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix)
	  {
	    s7_Int ipart;
	    ipart = (int)(frac_part * base);
	    if (ipart >= radix)         /* rounding confusion */
	      ipart = radix - 1;
	    frac_part -= (ipart / base);
	    if (ipart < 10)
	      d[i] = (char)('0' + ipart);
	    else d[i] = (char)('a' + ipart -  10);
	  }
	if (i == 0)
	  d[i++] = '0';
	d[i] = '\0';
	p = (char *)malloc(256 * sizeof(char));
	len = snprintf(p, 256, "%s%s.%s", (sign) ? "-" : "", n, d);
	str_len = 256;
      }
      break;

    default:
      p = (char *)malloc(512 * sizeof(char));
      n = number_to_string_with_radix(sc, make_real(sc, real_part(obj)), radix, 0, precision, float_choice, &len);
      d = number_to_string_with_radix(sc, make_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &len);
      len = snprintf(p, 512, "%s%s%si", n, (imag_part(obj) < 0.0) ? "" : "+", d);
      str_len = 512;
      free(n);
      free(d);
      break;
    }

  if (width > len)
    {
      int spaces;
      if (width >= str_len)
	{
	  str_len = width + 1;
	  p = (char *)realloc(p, str_len * sizeof(char));
	}
      spaces = width - len;
      p[width] = '\0';
      memmove((void *)(p + spaces), (void *)p, len);    
      memset((void *)p, (int)' ', spaces);	    
      (*nlen) = width;
    }
  else (*nlen) = len;
  return(p);
}


char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, int radix)
{
  int nlen = 0;
  return(number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen)); 
  /* (log top 10) so we get all the digits in base 10 (??) */
}


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."
  s7_Int radix = 10;
  int size = 20, nlen = 0;
  char *res;
  s7_pointer x;

  x = car(args);
  if (!s7_is_number(x))
    {
      CHECK_METHOD(sc, x, sc->NUMBER_TO_STRING, args);
      return(wrong_type_argument_with_type(sc, sc->NUMBER_TO_STRING, small_int(1), x, A_NUMBER));
    }
  if (is_pair(cdr(args)))
    {
      s7_pointer y;
      y = cadr(args);
      if (s7_is_integer(y))
	radix = s7_integer(y);
      else 
	{
	  CHECK_METHOD(sc, y, sc->NUMBER_TO_STRING, args);
	  return(wrong_type_argument(sc, sc->NUMBER_TO_STRING, small_int(2), y, T_INTEGER));
	}
      if ((radix < 2) || (radix > 16))
	return(out_of_range(sc, sc->NUMBER_TO_STRING, small_int(2), y, "should be between 2 and 16"));
    }

#if WITH_GMP
  if (s7_is_bignum(x))
    return(make_string_uncopied(sc, big_number_to_string_with_radix(x, radix, 0, &nlen, USE_WRITE)));
#endif

  if (!is_rational(x))
    {
      /* if size = 20, (number->string .1) gives "0.10000000000000000555", but if it's less than 20,
       *    large numbers (or very small numbers) mess up the less significant digits.
       */
      if (is_real(x))
	{
	  s7_Double val;
	  val = fabs(s7_real(x));
	  if ((val < (S7_LONG_MAX / 4)) && (val > 1.0e-6))
	    size = WRITE_REAL_PRECISION;
	}
      else
	{
	  s7_Double rl, im;
	  rl = fabs(s7_real_part(x));
	  if ((rl < (S7_LONG_MAX / 4)) && (rl > 1.0e-6))
	    {
	      im = fabs(s7_imag_part(x));
	      if ((im < (S7_LONG_MAX / 4)) && (im > 1.0e-6))
		size = WRITE_REAL_PRECISION;
	    }
	}
    }

  if (radix != 10)
    res = number_to_string_with_radix(sc, x, radix, 0, (radix == 10) ? size : 20, 'g', &nlen);
  else res = copy_string(number_to_string_base_10(x, 0, size, 'g', &nlen, USE_WRITE));
  
  return(make_string_uncopied(sc, res));
}


#define CTABLE_SIZE 256
static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space;
static int *digits;

static void init_ctables(void)
{
  int i;

  exponent_table = (bool *)calloc(CTABLE_SIZE, sizeof(bool));
  slashify_table = (bool *)calloc(CTABLE_SIZE, sizeof(bool));
  char_ok_in_a_name = (bool *)calloc(CTABLE_SIZE, sizeof(bool));
  white_space = (bool *)calloc(CTABLE_SIZE + 1, sizeof(bool));
  white_space++;    /* leave white_space[-1] false for white_space[EOF] */
  
  for (i = 1; i < CTABLE_SIZE; i++)
    char_ok_in_a_name[i] = true;
  char_ok_in_a_name[0] = false;
  char_ok_in_a_name['('] = false;
  char_ok_in_a_name[')'] = false;
  char_ok_in_a_name[';'] = false;
  char_ok_in_a_name['\t'] = false;
  char_ok_in_a_name['\n'] = false;
  char_ok_in_a_name['\r'] = false;
  char_ok_in_a_name[' '] = false;
  char_ok_in_a_name['"'] = false;
  /* double-quote is recent, but I want '(1 ."hi") to be parsed as '(1 . "hi") 
   * what about stuff like vertical tab?  or comma?
   */

  for (i = 0; i < CTABLE_SIZE; i++)
    white_space[i] = false;
  white_space['\t'] = true;
  white_space['\n'] = true;
  white_space['\r'] = true;
  white_space['\f'] = true;
  white_space['\v'] = true;
  white_space[' '] = true;

  /* surely only 'e' is needed... */
  exponent_table['e'] = true; exponent_table['E'] = true;
#if WITH_AT_SIGN_AS_EXPONENT
  exponent_table['@'] = true; 
#endif
#if WITH_EXTRA_EXPONENT_MARKERS
  exponent_table['s'] = true; exponent_table['S'] = true; 
  exponent_table['f'] = true; exponent_table['F'] = true;
  exponent_table['d'] = true; exponent_table['D'] = true;
  exponent_table['l'] = true; exponent_table['L'] = true;
#endif

  for (i = 0; i < 32; i++)
    slashify_table[i] = true;
  for (i = 127; i < 160; i++)
    slashify_table[i] = true;
  slashify_table['\\'] = true;
  slashify_table['"'] = true;
  slashify_table['\n'] = false;

  digits = (int *)calloc(CTABLE_SIZE, sizeof(int));
  for (i = 0; i < CTABLE_SIZE; i++)
    digits[i] = 256;

  digits['0'] = 0; digits['1'] = 1; digits['2'] = 2; digits['3'] = 3; digits['4'] = 4;
  digits['5'] = 5; digits['6'] = 6; digits['7'] = 7; digits['8'] = 8; digits['9'] = 9;
  digits['a'] = 10; digits['A'] = 10;
  digits['b'] = 11; digits['B'] = 11;
  digits['c'] = 12; digits['C'] = 12;
  digits['d'] = 13; digits['D'] = 13;
  digits['e'] = 14; digits['E'] = 14;
  digits['f'] = 15; digits['F'] = 15;
}


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


static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
{
  s7_pointer reader, value, args;
  value = sc->F;
  args = sc->F; 

  /* *#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.
   * This search happens after #|, #t, and #f (and #nD for multivectors?).
   */

  for (reader = slot_value(sc->sharp_readers); is_not_null(reader); reader = cdr(reader))
    {
      if (name[0] == s7_character(caar(reader)))
	{
	  if (args == sc->F) 
	    args = list_1(sc, s7_make_string(sc, name));
	  /* args is GC protected by s7_apply_function (placed on the stack */
	  value = s7_apply_function(sc, cdar(reader), args);
	  if (value != sc->F)
	    break;
	}
    }
  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) */
  if (is_null(cadr(args))) return(cadr(args));
  if (is_pair(cadr(args)))
    {
      s7_pointer x;
      for (x = cadr(args); is_pair(x); x = cdr(x))
	{
	  if ((!is_pair(car(x))) ||
	      (!s7_is_character(caar(x))) ||
	      (!s7_is_procedure(cdar(x))))
	    return(sc->ERROR);
	}
      if (is_null(x))
	return(cadr(args));
    }
  return(sc->ERROR);
}


static bool is_abnormal(s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(false);

    case T_REAL:
      return(is_inf(real(x)) || 
	     is_NaN(real(x)));

    case T_COMPLEX:
      return(((is_inf(s7_real_part(x)))  || 
	      (is_inf(s7_imag_part(x)))  ||
	      (is_NaN(s7_real_part(x))) || 
	      (is_NaN(s7_imag_part(x)))));

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
      return(false);
      
    case T_BIG_REAL:
      return((is_inf(s7_real_part(x))) || 
	     (is_NaN(s7_real_part(x))));

    case T_BIG_COMPLEX:
      return((is_inf(s7_real_part(x))) || 
	     (is_inf(s7_imag_part(x))) ||
	     (is_NaN(s7_real_part(x))) || 
	     (is_NaN(s7_imag_part(x))));
#endif

    default:
      return(true);
    }
}


#define NESTED_SHARP false
#define UNNESTED_SHARP true

#define SYMBOL_OK true
#define NO_SYMBOLS false

static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool at_top, int radix, bool with_error) 
{
  /* name is the stuff after the '#', return sc->NIL if not a recognized #... entity */
  int len;
  s7_pointer x;

  if ((name[0] == 't') && 
      ((name[1] == '\0') || (strings_are_equal(name, "true"))))
    return(sc->T);
  
  if ((name[0] == 'f') && 
      ((name[1] == '\0') || (strings_are_equal(name, "false"))))
    return(sc->F);

  if (is_not_null(slot_value(sc->sharp_readers)))
    {
      x = check_sharp_readers(sc, name);
      if (x != sc->F)
	return(x);
    }
  
  len = safe_strlen5(name); /* just count up to 5 */
  if (len < 2)
    return(sc->NIL);
      
  switch (name[0])
    {
      /* -------- #< ... > -------- */
    case '<':
      if (strings_are_equal(name, "<unspecified>"))
	return(sc->UNSPECIFIED);

      if (strings_are_equal(name, "<undefined>"))
	return(sc->UNDEFINED);

      if (strings_are_equal(name, "<eof>"))
	return(sc->EOF_OBJECT);

      return(sc->NIL);
      break;
      

      /* -------- #o #d #x #b -------- */
    case 'o':   /* #o (octal) */
    case 'd':   /* #d (decimal) */
    case 'x':   /* #x (hex) */
    case 'b':   /* #b (binary) */
      {
	bool to_inexact = false, to_exact = false;
	int num_at = 1;
  
	if (name[1] == '#')
	  {
	    if (!at_top)
	      return(sc->NIL);
	    if ((len > 2) && ((name[2] == 'e') || (name[2] == 'i'))) /* r6rs includes caps here */
	      {
		if ((len > 3) && (name[3] == '#'))
		  return(sc->NIL);
		to_inexact = (name[2] == 'i');
		to_exact = (name[2] == 'e');
		num_at = 3;
	      }
	    else return(sc->NIL);
	  }
	/* the #b or whatever overrides any radix passed in earlier */
	x = make_atom(sc, (char *)(name + num_at), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : ((name[0] == 'b') ? 2 : 10)), NO_SYMBOLS, with_error);

	/* #x#i1 apparently makes sense, so #x1.0 should also be accepted.
	 * here we can get #b#e0/0 or #b#e+1/0 etc.
	 * surely if #e1+i is an error (or #f), and #e#x1+i is an error,
	 *   #x#e1+i should also be an error, but #e1+0i is not an error I guess since there actually isn't any imaginary part
	 */
	if (is_abnormal(x))
	  return(sc->NIL);

	if ((!to_exact) && (!to_inexact))
	  return(x);

	if ((s7_imag_part(x) != 0.0) && (to_exact))  /* #x#e1+i */
	  return(sc->NIL);

#if WITH_GMP
	if (s7_is_bignum(x))
	  {
	    if (to_exact)
	      return(big_inexact_to_exact(sc, list_1(sc, x)));
	    return(big_exact_to_inexact(sc, list_1(sc, x)));
	  }
#endif
	if (to_exact)
	  return(inexact_to_exact(sc, x, with_error)); 
	return(exact_to_inexact(sc, x));
      }
      break;


      /* -------- #i -------- */
    case 'i':   /* #i<num> = ->inexact (see token for table of choices here) */
      if (name[1] == '#')
	{
	  /* there are special cases here: "#e0/0" or "#e#b0/0" -- all infs are complex: 
	   *    #i1/0=nan.0 but #i1/0+i=inf+1i so e->i is a no-op but i->e is not
	   *
	   * even trickier: a *#reader* like #t<num> could be used as #e#t13.25 so make_sharp_constant
	   *   needs to be willing to call the readers even when not at_top (i.e. when NESTED_SHARP).
	   */

	  if ((name[2] == 'e') ||                        /* #i#e1 -- assume these aren't redefinable? */
	      (name[2] == 'i'))
	    return(sc->NIL);

	  x = make_sharp_constant(sc, (char *)(name + 2), NESTED_SHARP, radix, with_error);
	  if (s7_is_number(x))
	    {
	      if (is_abnormal(x))
		return(sc->NIL);
#if WITH_GMP
	      if (s7_is_bignum(x))                        /* (string->number "#b#e-11e+111") */
		return(big_exact_to_inexact(sc, list_1(sc, x)));
#endif
	      return(exact_to_inexact(sc, x));
	    }
	  return(sc->NIL);
	}
      x = make_atom(sc, (char *)(name + 1), radix, NO_SYMBOLS, with_error);
      if (!s7_is_number(x))  /* not is_abnormal(x) -- #i0/0 -> nan etc */
	return(sc->NIL);
#if WITH_GMP
      if (s7_is_bignum(x))
	return(big_exact_to_inexact(sc, list_1(sc, x)));
#endif
      return(exact_to_inexact(sc, x));
      break;
  

      /* -------- #e -------- */
    case 'e':   /* #e<num> = ->exact */
      if (name[1] == '#')
	{
	  if ((name[2] == 'e') ||                        /* #e#e1 */
	      (name[2] == 'i'))
	    return(sc->NIL);

	  x = make_sharp_constant(sc, (char *)(name + 2), NESTED_SHARP, radix, with_error);
	  if (s7_is_number(x))
	    {
	      if (is_abnormal(x))                        /* (string->number "#e#b0/0") */
		return(sc->NIL);
	      if (!s7_is_real(x))                        /* (string->number "#e#b1+i") */
		return(sc->NIL);
#if WITH_GMP
	      return(big_inexact_to_exact(sc, list_1(sc, x)));
#endif
	      return(inexact_to_exact(sc, x, with_error));
	    }
	  return(sc->NIL);
	}

      x = make_atom(sc, (char *)(name + 1), radix, NO_SYMBOLS, with_error);
#if WITH_GMP
      /* #e1e310 is a simple case */
      if (s7_is_bignum(x))
	return(big_inexact_to_exact(sc, list_1(sc, x)));
#endif	
      if (is_abnormal(x))                                /* (string->number "#e0/0") */
	return(sc->NIL);
      if (!s7_is_real(x))                                /* (string->number "#e1+i") */
	return(sc->NIL);
      
#if WITH_GMP
      /* there are non-big floats that are greater than most-positive-fixnum:
       *    :(> .1e20 most-positive-fixnum) -> #t
       *    :(bignum? .1e20) -> #f
       * so we have to check that, not just is it a bignum.
       */
      return(big_inexact_to_exact(sc, list_1(sc, x)));
#endif
      return(inexact_to_exact(sc, x, with_error));
      break;


      /* -------- #_... -------- */
    case '_':
      /* now implement the #_<name> -> built-in value of <name> stuff 
       */
      {
	s7_pointer built_in_value;
	built_in_value = initial_slot(make_symbol(sc, (char *)(name + 1)));
	if (built_in_value != sc->UNDEFINED)
	  return(slot_value(built_in_value));
      }
      break;


      /* -------- #\... -------- */
    case '\\':
      if (name[2] == 0)                             /* the most common case: #\a */
	return(chars[(unsigned char)(name[1])]);
      /* not unsigned int here!  (unsigned int)255 (as a char) returns -1!! */

      if (strings_are_equal(name + 1, "space")) 
	return(chars[' ']);

      if ((strings_are_equal(name + 1, "newline")) || 
	  (strings_are_equal(name + 1, "linefeed")))
	return(chars['\n']);

      if (strings_are_equal(name + 1, "return")) 
	return(chars['\r']);

      if (strings_are_equal(name + 1, "tab")) 
	return(chars['\t']);

      if ((strings_are_equal(name + 1, "null")) || 
	  (strings_are_equal(name + 1, "nul")))
	return(chars[0]);

      /* the next 4 are for r7rs */
      if (strings_are_equal(name + 1, "alarm")) 
	return(chars[7]);

      if (strings_are_equal(name + 1, "backspace")) 
	return(chars[8]);

      if (strings_are_equal(name + 1, "escape")) 
	return(chars[0x1b]);

      if (strings_are_equal(name + 1, "delete")) 
	return(chars[0x7f]);

      if (name[1] == 'x')     /* #\x is just x, but apparently #\x<num> is int->char? #\x65 -> #\e -- Guile doesn't have this
			       *
			       * r7rs has 2/3/4-byte "characters" of the form #\xcebb but this is not compatible with
			       *   make-string, string-length, and so on.  We'd either have to have 2-byte chars
			       *   so (string-length (make-string 3 #\xcebb)) = 3, or accept 6 here for number of chars.
			       *   Then substring and string-set! and so on have to use utf8 encoding throughout or
			       *   risk changing the string length unexpectedly.
			       */
	{
	  /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3,
	   *   #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at
	   *   an even lower level.
	   *
	   * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught
	   */
	  bool happy = true;
	  char *tmp;
	  int lval = 0;

	  tmp = (char *)(name + 2);
	  while ((*tmp) && (happy) && (lval >= 0))
	    {
	      int dig;
	      dig = digits[(int)(*tmp++)];
	      if (dig < 16)
		lval = dig + (lval * 16);
	      else happy = false;
	    }
	  if ((happy) &&
	      (lval < 256) &&
	      (lval >= 0))
	    return(chars[lval]);
	}
    }
  return(sc->NIL);
}


static s7_Int string_to_integer(const char *str, int radix, bool *overflow)
{
  bool negative = false;
  s7_Int lval = 0;
  int dig;
  char *tmp = (char *)str;
  char *tmp1;

  if (str[0] == '+')
    tmp++;
  else 
    {
      if (str[0] == '-')
	{
	  negative = true;
	  tmp++;
	}
    }
  while (*tmp == '0') {tmp++;};
  tmp1 = tmp;

 if (radix == 10)
    {
      while (true)
	{
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig < 10)
	    lval = dig + (lval * 10);
	  else break;
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig < 10)
	    lval = dig + (lval * 10);
	  else break;
	}
    }
  else
    {
      while (true)
	{
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig < radix)
	    lval = dig + (lval * radix);
	  else break;
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig < radix)
	    lval = dig + (lval * radix);
	  else break;
	}
    }

#if WITH_GMP
  (*overflow) = ((lval > S7_LONG_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)
   */
#else
  if ((tmp - tmp1 - 2) > s7_int_digits_by_radix[radix])
    {
      /* I can't decide what to do with these non-gmp overflows.  Perhaps NAN in all cases? 
       *     overflow: 9223372036854775810 -> -9223372036854775806 -- this is not caught currently
       */
      (*overflow) = true;
      if (negative)
	return(s7_Int_min);       /* or INFINITY? */
      return(s7_Int_max);         /* 0/100000000000000000000000000000000000000000000000000000000000000000000 */
    }
#endif

  if (negative)
    return(-lval);
  return(lval);
}


/*  9223372036854775807                9223372036854775807
 * -9223372036854775808               -9223372036854775808
 * 0000000000000000000000000001.0     1.0
 * 1.0000000000000000000000000000     1.0
 * 1000000000000000000000000000.0e-40 1.0e-12
 * 0.0000000000000000000000000001e40  1.0e12
 * 1.0e00000000000000000001           10.0
 */

static s7_Double string_to_double_with_radix(const char *ur_str, int radix, bool *overflow)
{
  /* 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
   */

  int i, sign = 1, frac_len, int_len, dig, max_len, exponent = 0;
  long long int int_part = 0, frac_part = 0;
  char *str;
  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. 
   *   mpfr says "e" as exponent only in bases <= 10 -- else use '@' which works in any base.  This can only cause confusion
   *   in scheme, unfortunately, due to the idiotic scheme polar notation.  But we accept "s" and "l" as exponent markers
   *   so, perhaps for radix > 10, the exponent, if any, has to use one of S s L l?  Not "l"!  And "s" originally meant "short".
   *
   * '@' 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
   */

  max_len = s7_int_digits_by_radix[radix];
  str = (char *)ur_str;

  if (*str == '+')
    str++;
  else
    {
      if (*str == '-')
	{
	  str++;
	  sign = -1;
	}
    }
  while (*str == '0') {str++;};

  ipart = str;
  while (digits[(int)(*str)] < radix) str++;
  int_len = str - ipart;

  if (*str == '.') str++;
  fpart = str;
  while (digits[(int)(*str)] < radix) str++;
  frac_len = str - fpart;

  if ((*str) && (exponent_table[(unsigned char)(*str)]))
    {
      int exp_negative = false;
      str++;
      if (*str == '+') 
	str++;
      else
	{
	  if (*str == '-')
	    {
	      str++;
	      exp_negative = true;
	    }
	}
      while ((dig = digits[(int)(*str++)]) < 10) /* exponent itself is always base 10 */
	exponent = dig + (exponent * 10);
      
      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 */
      if (exp_negative) 
	exponent = -exponent;

      /*           2e12341234123123123123213123123123 -> 0.0
       * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0
       * 1st zero: 2e123412341231231231231
       * then:     2e12341234123123123123123123 -> inf
       * then:     2e123412341231231231231231231231231231 -> 0.0
       *           2e-123412341231231231231 -> inf
       * but:      0e123412341231231231231231231231231231
       */
    }

#if WITH_GMP
  /* 9007199254740995.0 */

  if (int_len + frac_len >= max_len)
    {
      (*overflow) = true;
      return(0.0);
    }
#endif
      
  str = ipart;
  if ((int_len + exponent) > max_len)
    {
      /*  12341234.56789e12                   12341234567889999872.0              1.234123456789e+19
       * -1234567890123456789.0              -1234567890123456768.0              -1.2345678901235e+18
       *  12345678901234567890.0              12345678901234567168.0              1.2345678901235e+19
       *  123.456e30                          123456000000000012741097792995328.0 1.23456e+32
       *  12345678901234567890.0e12           12345678901234569054409354903552.0  1.2345678901235e+31
       *  1.234567890123456789012e30          1234567890123456849145940148224.0   1.2345678901235e+30
       *  1e20                                100000000000000000000.0             1e+20
       *  1234567890123456789.0               1234567890123456768.0               1.2345678901235e+18
       *  123.456e16                          1234560000000000000.0               1.23456e+18
       *  98765432101234567890987654321.0e-5  987654321012345728401408.0          9.8765432101235e+23
       *  98765432101234567890987654321.0e-10 9876543210123456512.0               9.8765432101235e+18
       *  0.00000000000000001234e20           1234.0
       *  0.000000000000000000000000001234e30 1234.0
       *  0.0000000000000000000000000000000000001234e40 1234.0
       *  0.000000000012345678909876543210e15 12345.678909877
       *  0e1000                              0.0
       */

      for (i = 0; i < max_len; i++)
	{
	  dig = digits[(int)(*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[(int)(*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 ipow) thinks it has to be too big, returns Nan,
			  *   then Nan * 0 -> Nan and the NaN progogates
			  */
	{
	  if (int_len <= max_len)
	    dval = int_part * ipow(radix, exponent);
	  else dval = int_part * ipow(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)
	{
	  int k, flen;
	  str = fpart;
	  
	  for (k = 0; (frac_len > 0) && (k < exponent); k += max_len)
	    {
	      if (frac_len > max_len) flen = max_len; else flen = frac_len;
	      frac_len -= max_len;

	      frac_part = 0;
	      for (i = 0; i < flen; i++)
		frac_part = digits[(int)(*str++)] + (frac_part * radix);

	      if (frac_part != 0)                                /* same pow->NaN problem as above can occur here */
		dval += frac_part * ipow(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)
	    {
	      int ilen;
	      /* str should be at the last digit we read */
	      ilen = int_len - max_len;                          /* we read these above */
	      if (ilen > max_len)
		ilen = max_len;

	      for (i = 0; i < ilen; i++)
		frac_part = digits[(int)(*str++)] + (frac_part * radix);

	      dval += frac_part * ipow(radix, exponent - ilen);
	    }
	}

      return(sign * dval);
    }

  /* int_len + exponent <= max_len */

  if (int_len <= max_len)
    {
      char *iend;
      int int_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.
       */

      int_exponent = exponent;
      if (int_len > 0)
	{
	  iend = (char *)(str + int_len - 1);
	  while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;}

	  while (str <= iend)
	    int_part = digits[(int)(*str++)] + (int_part * radix);
	}
      if (int_exponent != 0)
	dval = int_part * ipow(radix, int_exponent);
      else dval = (s7_Double)int_part;
    }
  else
    {
      int len, flen;
      long long int fpart = 0;

      /* 98765432101234567890987654321.0e-20    987654321.012346  
       * 98765432101234567890987654321.0e-29    0.98765432101235
       * 98765432101234567890987654321.0e-30    0.098765432101235
       * 98765432101234567890987654321.0e-28    9.8765432101235
       */

      len = int_len + exponent;
      for (i = 0; i < len; i++)
	int_part = digits[(int)(*str++)] + (int_part * radix);
      
      flen = -exponent;
      if (flen > max_len)
	flen = max_len;

      for (i = 0; i < flen; i++)
	fpart = digits[(int)(*str++)] + (fpart * radix);

      if (len <= 0)
	dval = int_part + fpart * ipow(radix, len - flen);
      else dval = int_part + fpart * ipow(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 */
	  char *fend;
	  
	  fend = (char *)(str + frac_len - 1);
	  while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */
	  
	  while (str <= fend)
	    frac_part = digits[(int)(*str++)] + (frac_part * radix);
	  dval += frac_part * ipow(radix, exponent - frac_len);
	  
	  /* fprintf(stderr, "frac: %lld, exp: (%d %d) %.20f, val: %.20f\n", frac_part, exponent, frac_len, ipow(radix, exponent - frac_len), dval); 
	   * 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) ; but not 60e-2
	   * #t
	   *
	   * to fix the 0.60 case, we need to ignore trailing post-dot zeros.
	   */
	}
      else
	{
	  if (exponent <= 0)
	    {
	      for (i = 0; i < max_len; i++)
		frac_part = digits[(int)(*str++)] + (frac_part * radix);
	      
	      dval += frac_part * ipow(radix, exponent - max_len);
	    }
	  else
	    {
	      /* 1.0123456789876543210e1         10.12345678987654373771  
	       * 1.0123456789876543210e10        10123456789.87654304504394531250
	       * 0.000000010000000000000000e10   100.0
	       * 0.000000010000000000000000000000000000000000000e10 100.0
	       * 0.000000012222222222222222222222222222222222222e10 122.22222222222222
	       * 0.000000012222222222222222222222222222222222222e17 1222222222.222222
	       */
	      
	      int_part = 0;
	      for (i = 0; i < exponent; i++)
		int_part = digits[(int)(*str++)] + (int_part * radix);
	      
	      frac_len -= exponent;
	      if (frac_len > max_len)
		frac_len = max_len;
	      
	      for (i = 0; i < frac_len; i++)
		frac_part = digits[(int)(*str++)] + (frac_part * radix);
	      
	      dval += int_part + frac_part * ipow(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);
}


/* make symbol or number atom from string */

static s7_pointer make_atom(s7_scheme *sc, char *q, int radix, bool want_symbol, bool with_error) 
{
  #define ISDIGIT(Chr, Rad) (digits[(unsigned char)Chr] < Rad)

  char c, *p;
  bool has_dec_point1 = false;

  p = q;
  c = *p++; 
  
  /* a number starts with + - . or digit, but so does 1+ for example */
  
  switch (c)
    {
    case '#':
      return(make_sharp_constant(sc, p, UNNESTED_SHARP, radix, with_error)); /* make_sharp_constant expects the '#' to be removed */

    case '+':
    case '-':
      c = *p++; 
      if (c == '.') 
	{ 
	  has_dec_point1 = true; 
	  c = *p++; 
	} 
      if ((!c) || (!ISDIGIT(c, radix)))
	return((want_symbol) ? make_symbol(sc, q) : sc->F);
      break;

    case '.':
      has_dec_point1 = true; 
      c = *p++; 

      if ((!c) || (!ISDIGIT(c, radix)))
	return((want_symbol) ? make_symbol(sc, q) : sc->F); 
      break;

    case '0':        /* these two are always digits */
    case '1':
      break;

    default:
      if (!ISDIGIT(c, radix))
	return((want_symbol) ? make_symbol(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;
    int has_plus_or_minus = 0, current_radix;

#if (!WITH_GMP)
    bool overflow = false;
#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
	 */
	if (!ISDIGIT(c, current_radix))         /* moving this inside the switch statement was much slower */
	  {
	    current_radix = radix;
	    
	    switch (c)
	      {
		/* -------- decimal point -------- */
	      case '.':
		if (((has_dec_point1) ||
		     (slash1)) &&
		    (has_plus_or_minus == 0)) /* 1.. or 1/2. */
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		
		if (((has_dec_point2) ||
		     (slash2)) &&
		    (has_plus_or_minus != 0)) /* 1+1.. or 1+1/2. */
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		
		if ((!ISDIGIT(p[1], current_radix)) &&
		    (!ISDIGIT(p[-1], current_radix))) 
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		
		if (has_plus_or_minus == 0)
		  has_dec_point1 = true;
		else has_dec_point2 = true;
		continue;

		
		/* -------- exponent marker -------- */
	      case 'e': case 'E':
#if WITH_EXTRA_EXPONENT_MARKERS
	      case 's': case 'S':
	      case 'd': case 'D':
	      case 'f': case 'F':
	      case 'l': case 'L':
#endif
		if (current_radix > 10)
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		/* see note above */
		/* fall through -- if '@' used, radices>10 are ok */
		
#if WITH_AT_SIGN_AS_EXPONENT
	      case '@':
#endif
		current_radix = 10;
		
		if (((ex1) ||
		     (slash1)) &&
		    (has_plus_or_minus == 0)) /* ee */
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		
		if (((ex2) ||
		     (slash2)) &&
		    (has_plus_or_minus != 0)) /* 1+1.0ee */
		  return((want_symbol) ? make_symbol(sc, q) : sc->F); 
		
		if ((!ISDIGIT(p[-1], radix)) && /* was current_radix but that's always 10! */
		    (p[-1] != '.'))
		  return((want_symbol) ? make_symbol(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 (ISDIGIT(*p, current_radix))
		  continue;
		break;


		/* -------- internal + or - -------- */
	      case '+':
	      case '-':
		if (has_plus_or_minus != 0) /* already have the separator */
		  return((want_symbol) ? make_symbol(sc, q) : sc->F);
		
		if (c == '+') has_plus_or_minus = 1; else has_plus_or_minus = -1;
		plus = (char *)(p + 1);
		continue;
		
		/* ratio marker */
	      case '/':
		if ((has_plus_or_minus == 0) &&
		    ((ex1) ||
		     (slash1) ||
		     (has_dec_point1)))
		  return((want_symbol) ? make_symbol(sc, q) : sc->F);
		
		if ((has_plus_or_minus != 0) &&
		    ((ex2) ||
		     (slash2) ||
		     (has_dec_point2)))
		  return((want_symbol) ? make_symbol(sc, q) : sc->F);
		
		if (has_plus_or_minus == 0)
		  slash1 = (char *)(p + 1);
		else slash2 = (char *)(p + 1);
		
		if ((!ISDIGIT(p[1], current_radix)) ||
		    (!ISDIGIT(p[-1], current_radix)))
		  return((want_symbol) ? make_symbol(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(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(sc, q) : sc->F);

    if (has_i)
      {
#if (!WITH_GMP)
	s7_Double rl = 0.0, im = 0.0;
#else
	char e1 = 0, e2 = 0;
#endif
	s7_pointer result;
	int len;
	char ql1, pl1;
	
	len = safe_strlen(q);
	
	if (q[len - 1] != 'i')
	  return((want_symbol) ? make_symbol(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 */
	if ((q[len - 2] == '+') || (q[len - 2] == '-'))
	  q[len - 1] = '1';
	else q[len - 1] = '\0'; /* remove 'i' */
	
	(*((char *)(plus - 1))) = '\0';
	
	/* there is a slight inconsistency here:
	   1/0      -> nan.0
           1/0+0i   -> inf.0 (0/1+0i is 0.0)
	   #i1/0+0i -> inf.0
	   0/0      -> nan.0
	   0/0+0i   -> -nan.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, &overflow);
	  }
	else
	  {
	    if (slash1)
	      {
		/* here the overflow could be innocuous if it's in the denominator and the numerator is 0
		 *    0/100000000000000000000000000000000000000-0i
		 */
		s7_Int num, den;
		num = string_to_integer(q, radix, &overflow);
		den = string_to_integer(slash1, radix, &overflow);
		
		if ((num == 0) && (den != 0))
		  {
		    rl = 0.0;
		    overflow = false;
		  }
		else rl = (s7_Double)num / (s7_Double)den;
	      }
	    else rl = (s7_Double)string_to_integer(q, radix, &overflow);
	    if (overflow) return(real_NaN);
	  }
	if (rl == -0.0) rl = 0.0;
	
	if ((has_dec_point2) ||
	    (ex2))
	  im = string_to_double_with_radix(plus, radix, &overflow);
	else
	  {
	    if (slash2)
	      {
		/* same as above: 0-0/100000000000000000000000000000000000000i
		 */
		s7_Int num, den;
		num = string_to_integer(plus, radix, &overflow);
		den = string_to_integer(slash2, radix, &overflow);
		if ((num == 0) && (den != 0))
		  {
		    im = 0.0;
		    overflow = false;
		  }
		else im = (s7_Double)num / (s7_Double)den;
	      }
	    else im = (s7_Double)string_to_integer(plus, radix, &overflow);
	    if (overflow) return(real_NaN);
	  }
	if ((has_plus_or_minus == -1) && 
	    (im != 0.0))
	  im = -im;
	result = s7_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(sc, q) : sc->F);
	
#if (!WITH_GMP)
	result = make_real(sc, string_to_double_with_radix(q, radix, &overflow));
#else
	{
	  char old_e = 0;
	  if (ex1)
	    {
	      old_e = (*ex1);
#if WITH_AT_SIGN_AS_EXPONENT
	      (*ex1) = '@';
#else
	      (*ex1) = 'e';
#endif
	    }
	  result = string_to_either_real(sc, q, radix);
	  if (ex1)
	    (*ex1) = old_e;
	}
#endif
	return(result);
      }
    
    /* not real */
    if (slash1)
#if (!WITH_GMP)
      {
	s7_Int n, d;

	n = string_to_integer(q, radix, &overflow);
	d = string_to_integer(slash1, radix, &overflow);

	if ((n == 0) && (d != 0))                        /* 0/100000000000000000000000000000000000000 */
	  return(small_int(0));
	if ((d == 0) || (overflow))
	  return(real_NaN);
	/* 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(s7_make_ratio(sc, n, d));
      }
#else
    return(string_to_either_ratio(sc, q, slash1, radix));
#endif
    
    /* integer */
#if (!WITH_GMP)
    {
      s7_Int x;
      x = string_to_integer(q, radix, &overflow);
      if (overflow) 
	return(make_real(sc, (q[0] == '-') ? -INFINITY : INFINITY)); /* was NaN */
      return(make_integer(sc, x));
    }
#else
    return(string_to_either_integer(sc, q, radix));
#endif
  }
}


static s7_pointer s7_string_to_number(s7_scheme *sc, char *str, int radix)
{
  s7_pointer x;
  x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR);
  if (s7_is_number(x))  /* only needed because str might start with '#' and not be a number (#t for example) */
    return(x);
  return(sc->F);
}


static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
{
  #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 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3."

  s7_Int radix = 0;
  char *str;

  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), caller, args);
      return(wrong_type_argument(sc, caller, small_int(1), car(args), T_STRING));
    }
  str = (char *)string_value(car(args));
  if ((!str) || (!(*str)))
    return(sc->F);

  if (is_pair(cdr(args)))
    {
      s7_pointer rad;
      rad = cadr(args);
      if (!s7_is_integer(rad))
	{
	  CHECK_METHOD(sc, rad, caller, args);
	  return(wrong_type_argument(sc, caller, small_int(2), rad, T_INTEGER));
	}

      radix = s7_integer(rad);
      if ((radix < 2) ||              /* what about negative int as base (Knuth), reals such as phi, and some complex like -1+i */
	  (radix > 16))               /* the only problem here is printing the number; perhaps put each digit in "()" in base 10: (123)(0)(34) */
	return(out_of_range(sc, caller, small_int(2), rad, "should be between 2 and 16"));
    }
  else radix = 10;

  switch (str[0])
    {
    case 'n':
      if (safe_strcmp(str, "nan.0") == 0)
	return(real_NaN);
      break;

    case 'i':
      if (safe_strcmp(str, "inf.0") == 0)
	return(make_real(sc, INFINITY));
      break;

    case '-':
      if ((str[1] == 'i') && (safe_strcmp((const char *)(str + 1), "inf.0") == 0))
	 return(make_real(sc, -INFINITY));
       break;

    case '+':
      if ((str[1] == 'i') && (safe_strcmp((const char *)(str + 1), "inf.0") == 0))
	 return(make_real(sc, INFINITY));
       break;
    }

  return(s7_string_to_number(sc, str, radix));
}


static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args)
{
  return(g_string_to_number_1(sc, args, sc->STRING_TO_NUMBER));
}


static bool numbers_are_eqv(s7_pointer a, s7_pointer b)
{
  if (type(a) != type(b)) /* (eqv? 1 1.0) -> #f! */
    return(false);

  switch (type(a))
    {
    case T_INTEGER:
      return((integer(a) == integer(b)));
  
    case T_RATIO:
      return((numerator(a) == numerator(b)) &&
	     (denominator(a) == denominator(b)));

    case T_REAL:
      if (is_NaN(real(a))) 
	return(false);
      return(real(a) == real(b));
  
    default:
      if ((is_NaN(real_part(a))) ||
	  (is_NaN(imag_part(a))))
	return(false);
      return((real_part(a) == real_part(b)) &&
	     (imag_part(a) == imag_part(b)));
    }
  
  return(false);
}


#if (!WITH_GMP)
static s7_pointer abs_direct;
static s7_pointer g_abs_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = c_call(car(args))(sc, cdar(args));
  if (real(x) < 0)
    {
      if (is_simple_real(x))
	return(s7_remake_real(sc, x, -real(x)));
      return(make_real(sc, -real(x)));
    }
  return(x);
}

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"

  s7_pointer x;
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) < 0)
	return(make_integer(sc, -integer(x)));
      return(x);

    case T_RATIO:
      if (numerator(x) < 0)
	return(s7_make_ratio(sc, -numerator(x), denominator(x)));
      return(x);

    case T_REAL:
      if (real(x) < 0.0)
	return(make_real(sc, -real(x)));
      return(x);

    default:
      CHECK_METHOD(sc, x, sc->ABS, args);
      return(simple_wrong_type_argument(sc, sc->ABS, x, T_REAL));
    }
}


static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
{
  #define H_magnitude "(magnitude z) returns the magnitude of z"
  s7_pointer x;
  x = car(args);

  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) < 0)
	return(make_integer(sc, -integer(x)));
      return(x);

    case T_RATIO:
      if (numerator(x) < 0)
	return(s7_make_ratio(sc, -numerator(x), denominator(x)));
      return(x);

    case T_REAL:
      if (real(x) < 0.0)
	return(make_real(sc, -real(x)));
      return(x);

    case T_COMPLEX:
      return(make_real(sc, hypot(imag_part(x), real_part(x))));

    default:
      CHECK_METHOD(sc, x, sc->MAGNITUDE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->MAGNITUDE, x, A_NUMBER));
    }
}


static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
{
  #define H_angle "(angle z) returns the angle of z"
  s7_pointer x;
  /* (angle inf+infi) -> 0.78539816339745 ? */

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) < 0)
	return(real_pi);
      return(small_int(0));

    case T_RATIO:
      if (numerator(x) < 0)
	return(real_pi);
      return(small_int(0));

    case T_REAL:
      if (is_NaN(real(x))) return(x);
      if (real(x) < 0.0)
	return(real_pi);
      return(real_zero);

    case T_COMPLEX:
      return(make_real(sc, atan2(imag_part(x), real_part(x))));

    default:
      CHECK_METHOD(sc, x, sc->ANGLE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ANGLE, x, A_NUMBER));
    }
}


static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
{
  #define H_rationalize "(rationalize x err) returns the ratio with lowest denominator within err of x"
  s7_Double err;
  s7_pointer x;

  if (is_not_null(cdr(args)))
    {
      s7_pointer ex;
      ex = cadr(args);
      if (!s7_is_real(ex))
	{
	  CHECK_METHOD(sc, ex, sc->RATIONALIZE, args);
	  return(wrong_type_argument(sc, sc->RATIONALIZE, small_int(2), ex, T_REAL));
	}
      err = s7_number_to_real(sc, ex);
      if (is_NaN(err))
	return(out_of_range(sc, sc->RATIONALIZE, small_int(2), cadr(args), "error term is NaN"));
      if (err < 0.0) err = -err;
    }
  else err = default_rationalize_error;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      {
	s7_Int a, b, pa;
	if (err < 1.0) return(x);
	a = s7_integer(x);
	if (a < 0) pa = -a; else pa = a;
	if (err >= pa) return(small_int(0));
	b = (s7_Int)err;
	pa -= b;
	if (a < 0)
	  return(make_integer(sc, -pa));
	return(make_integer(sc, pa));
      }

    case T_RATIO:
      if (err == 0.0)
	return(x);

    case T_REAL:
      {
	s7_Double rat;
	s7_Int numer = 0, denom = 1;

	rat = s7_number_to_real(sc, x);

	if ((is_NaN(rat)) || (is_inf(rat)))
	  return(wrong_type_argument_with_type(sc, sc->RATIONALIZE, small_int(1), x, A_NORMAL_REAL));

	if (err >= fabs(rat)) 
	  return(small_int(0));

	if ((rat > 9.2233720368548e+18) || (rat < -9.2233720368548e+18))
	  return(out_of_range(sc, sc->RATIONALIZE, small_int(1), x, "a real between most-negative-fixnum and most-positive-fixnum"));

	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(small_int(0));

	if (c_rationalize(rat, err, &numer, &denom))
	  return(s7_make_ratio(sc, numer, denom));

	return(sc->F);
      }

    default:
      CHECK_METHOD(sc, x, sc->RATIONALIZE, args);
      return(wrong_type_argument(sc, sc->RATIONALIZE, small_int(1), x, T_REAL));
    }
}


static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  s7_Double ang, mag;
  #define H_make_polar "(make-polar mag ang) returns a complex number with magnitude mag and angle ang"
  
  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(x) == 0) return(x);            /* (make-polar 0 1) -> 0 */
	  if (integer(y) == 0) return(x);            /* (make-polar 1 0) -> 1 */
	  mag = (s7_Double)integer(x);
	  ang = (s7_Double)integer(y);
	  break;

	case T_RATIO:
	  if (integer(x) == 0) return(x);
	  mag = (s7_Double)integer(x);
	  ang = (s7_Double)fraction(y);
	  break;

	case T_REAL:
	  ang = real(y);
	  if (ang == 0.0) return(x);
	  if (is_NaN(ang)) return(y);
	  if (is_inf(ang)) return(real_NaN);
	  if ((ang == M_PI) || (ang == -M_PI)) return(make_integer(sc, -integer(x)));
	  mag = (s7_Double)integer(x);
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->MAKE_POLAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(2), y, T_REAL));
	}
      break;

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) return(x);
	  mag = (s7_Double)fraction(x);
	  ang = (s7_Double)integer(y);
	  break;

	case T_RATIO:
	  mag = (s7_Double)fraction(x);
	  ang = (s7_Double)fraction(y);
	  break;

	case T_REAL:
	  ang = real(y);
	  if (ang == 0.0) return(x);
	  if (is_NaN(ang)) return(y);
	  if (is_inf(ang)) return(real_NaN);
	  if ((ang == M_PI) || (ang == -M_PI)) return(s7_make_ratio(sc, -numerator(x), denominator(x)));
	  mag = fraction(x);
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->MAKE_POLAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(2), y, T_REAL));
	}
      break;

    case T_REAL:
      mag = real(x);
      switch (type(y))
	{
	case T_INTEGER:
	  if (is_NaN(mag)) return(x);
	  if (integer(y) == 0) return(x);
	  ang = (s7_Double)integer(y);
	  break;

	case T_RATIO:
	  if (is_NaN(mag)) return(x);
	  ang = (s7_Double)fraction(y);
	  break;

	case T_REAL:
	  if (is_NaN(mag)) return(x);
	  ang = real(y);
	  if (ang == 0.0) return(x);
	  if (is_NaN(ang)) return(y);
	  if (is_inf(ang)) return(real_NaN);
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->MAKE_POLAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(2), y, T_REAL));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->MAKE_POLAR, args);
      return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(1), x, T_REAL));
    }

  return(s7_make_complex(sc, mag * cos(ang), mag * sin(ang)));

  /* since sin is inaccurate for large arguments, so is make-polar:
   *    (make-polar 1.0 1e40) -> -0.76267273202438+0.64678458842683i, not 8.218988919070239214448025364432557517335E-1-5.696334009536363273080341815735687231337E-1i
   */
}


static s7_pointer g_make_rectangular(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  #define H_make_rectangular "(make-rectangular x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
  
  x = car(args);
  y = cadr(args);

  switch (type(y))
    {
    case T_INTEGER:
      switch (type(x))
	{
	case T_INTEGER: 
	  if (integer(y) == 0) return(x); 
	  return(s7_make_complex(sc, (s7_Double)integer(x), (s7_Double)integer(y)));

	case T_RATIO:   
	  if (integer(y) == 0) return(x); 
	  return(s7_make_complex(sc, (s7_Double)fraction(x), (s7_Double)integer(y)));

	case T_REAL:    
	  if (integer(y) == 0) return(x); 
	  return(s7_make_complex(sc, real(x), (s7_Double)integer(y)));

	default:        
	  CHECK_METHOD(sc, x, sc->MAKE_RECTANGULAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(1), x, T_REAL));
	}
      
    case T_RATIO:
      switch (type(x))
	{
	case T_INTEGER: 
	  return(s7_make_complex(sc, (s7_Double)integer(x), (s7_Double)fraction(y)));

	case T_RATIO:   
	  return(s7_make_complex(sc, (s7_Double)fraction(x), (s7_Double)fraction(y)));

	case T_REAL:    
	  return(s7_make_complex(sc, real(x), (s7_Double)fraction(y)));

	default:        
	  CHECK_METHOD(sc, x, sc->MAKE_RECTANGULAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(1), x, T_REAL));
	}

    case T_REAL:
      switch (type(x))
	{
	case T_INTEGER: 
	  if (real(y) == 0.0) return(x); 
	  return(s7_make_complex(sc, (s7_Double)integer(x), real(y)));

	case T_RATIO:   
	  if (real(y) == 0.0) return(x); 
	  return(s7_make_complex(sc, (s7_Double)fraction(x), real(y)));

	case T_REAL:    
	  if (real(y) == 0.0) return(x); 
	  return(s7_make_complex(sc, real(x), real(y)));

	default:        
	  CHECK_METHOD(sc, x, sc->MAKE_RECTANGULAR, args);
	  return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(1), x, T_REAL));
	}

    default:
      CHECK_METHOD(sc, y, sc->MAKE_RECTANGULAR, args);
      return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(2), y, T_REAL));
    }
}


static s7_pointer g_exp(s7_scheme *sc, s7_pointer args)
{
  #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(1));                       /* (exp 0) -> 1 */
      return(make_real(sc, exp((s7_Double)(integer(x)))));

    case T_RATIO:
      return(make_real(sc, exp((s7_Double)fraction(x))));

    case T_REAL:
      return(make_real(sc, exp(real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, cexp(as_c_complex(x))));
      /* this is inaccurate for large arguments:
       *   (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i
       */
#else
      return(out_of_range(sc, sc->EXP, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->EXP, args);
      return(simple_wrong_type_argument_with_type(sc, sc->EXP, x, A_NUMBER));
    }
}

/* another possibility:
 * since (log (make-polar 1 .1)) = 0+0.1i and so on,
 *       (log (real-part (log 0)) .1) (currently = -inf-nani) = -inf+.1i
 * but   (log 0 .1) = inf-nani
 *
 * :(log (make-polar (exp 1) .1))
 *  1+0.1i
 */

#if __cplusplus
#define LOG_2 1.4426950408889634074
#else
#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */ 
#endif


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"
  s7_pointer x;
  
  x = car(args);

  if (!s7_is_number(x))
    {
      CHECK_METHOD(sc, x, sc->LOG, args);
      return(wrong_type_argument_with_type(sc, sc->LOG, small_int(1), x, A_NUMBER));
    }

  if (is_pair(cdr(args)))
    {
      s7_pointer y;

      y = cadr(args);
      if (!(s7_is_number(y)))
	{
	  CHECK_METHOD(sc, y, sc->LOG, args);
	  return(wrong_type_argument_with_type(sc, sc->LOG, small_int(2), y, A_NUMBER));
	}

      if (y == small_int(2))
	{
	  /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */
	  if (is_integer(x))
	    {
	      s7_Int ix;
	      ix = s7_integer(x);
	      if (ix > 0)
		{
		  s7_Double fx;
#if (__ANDROID__) || (MS_WINDOWS) || ((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4))))
		  /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */
		  fx = log((double)ix) / log(2.0);
#else
		  fx = log2((double)ix);
#endif
		  if ((ix & (ix - 1)) == 0)
		    return(make_integer(sc, (s7_Int)fx));
		  return(make_real(sc, fx));
		}
	    }
	  if ((s7_is_real(x)) &&
	      (s7_is_positive(x)))
	    return(make_real(sc, log(number_to_real(x)) * LOG_2));
	  return(s7_from_c_complex(sc, clog(s7_complex(x)) * LOG_2));
	}

      if ((x == small_int(1)) && (y == small_int(1)))  /* (log 1 1) -> 0 (this is NaN in the bignum case) */
	return(small_int(0));                          

      /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */
      if (s7_is_zero(y))
	{
	  if ((y == small_int(0)) &&
	      (x == small_int(1)))
	    return(y);
	  return(out_of_range(sc, sc->LOG, small_int(2), y, "can't be 0"));
	}

      if (s7_is_one(y))      /* this used to raise an error, but the bignum case is simpler if we return inf */
	{
	  if (s7_is_one(x))  /* but (log 1.0 1.0) -> 0.0 */
	    return(real_zero);
	  return(make_real(sc, INFINITY)); /* currently (log 1/0 1) is inf? */
	}

      if ((s7_is_real(x)) &&
	  (s7_is_real(y)) &&
	  (s7_is_positive(x)) &&
	  (s7_is_positive(y)))
	{
	  if ((s7_is_rational(x)) &&
	      (s7_is_rational(y)))
	    {
	      s7_Double res;
	      s7_Int ires;
	      res = log(number_to_real(x)) / log(number_to_real(y));
	      ires = (s7_Int)res;
	      if (res - ires == 0.0)
		return(make_integer(sc, ires));   /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */
	      return(make_real(sc, res));         /* perhaps use rationalize here? (log 2 8) -> 1/3 */
	    }
	  return(make_real(sc, log(number_to_real(x)) / log(number_to_real(y))));
	}
      return(s7_from_c_complex(sc, clog(s7_complex(x)) / clog(s7_complex(y))));
    }
  
  if (s7_is_real(x))
    {
      if (s7_is_positive(x))
	return(make_real(sc, log(number_to_real(x))));
      return(s7_make_complex(sc, log(-number_to_real(x)), M_PI));
    }

  return(s7_from_c_complex(sc, clog(s7_complex(x))));
}


static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
{
  #define H_sin "(sin z) returns sin(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_REAL:
      return(make_real(sc, sin(real(x))));

    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                      /* (sin 0) -> 0 */
      return(make_real(sc, sin((s7_Double)integer(x))));
      
    case T_RATIO:
      return(make_real(sc, sin((s7_Double)(fraction(x)))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, csin(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->SIN, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->SIN, args);
      return(simple_wrong_type_argument_with_type(sc, sc->SIN, x, A_NUMBER));
    }

  /* sin is totally inaccurate over about 1e18.  There's a way to get true results,
   *   but it involves fancy "range reduction" techniques. 
   *   This means that lots of things are inaccurate:
   * (sin (remainder 1e22 (* 2 pi)))
   * -0.57876806033477
   * but it should be -8.522008497671888065747423101326159661908E-1
   * ---
   * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !!
   *   it should be 5.263007914620499494429139986095833592117E0
   */
}

s7_pointer s7_sin(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_REAL:
      return(make_real(sc, sin(real(x))));

    case T_INTEGER:
      return(make_real(sc, sin((s7_Double)integer(x))));
      
    case T_RATIO:
      return(make_real(sc, sin((s7_Double)(fraction(x)))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, csin(as_c_complex(x))));
#endif

    default:
      return(simple_wrong_type_argument_with_type(sc, sc->SIN, x, A_NUMBER));
    }
}


static s7_pointer g_cos(s7_scheme *sc, s7_pointer args)
{
  #define H_cos "(cos z) returns cos(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_REAL:
      return(make_real(sc, cos(real(x))));

    case T_INTEGER:
      if (integer(x) == 0) return(small_int(1));                     /* (cos 0) -> 1 */
      return(make_real(sc, cos((s7_Double)integer(x))));
      
    case T_RATIO:
      return(make_real(sc, cos((s7_Double)(fraction(x)))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, ccos(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->COS, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->COS, args);
      return(simple_wrong_type_argument_with_type(sc, sc->COS, x, A_NUMBER));
    }
}

s7_pointer s7_cos(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_REAL:
      return(make_real(sc, cos(real(x))));

    case T_INTEGER:
      return(make_real(sc, cos((s7_Double)integer(x))));
      
    case T_RATIO:
      return(make_real(sc, cos((s7_Double)(fraction(x)))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, ccos(as_c_complex(x))));
#endif

    default:
      return(simple_wrong_type_argument_with_type(sc, sc->COS, x, A_NUMBER));
    }
}


static s7_pointer g_tan(s7_scheme *sc, s7_pointer args)
{
  #define H_tan "(tan z) returns tan(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_REAL:
      return(make_real(sc, tan(real(x))));
      
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                      /* (tan 0) -> 0 */
      return(make_real(sc, tan((s7_Double)(integer(x)))));

    case T_RATIO:
      return(make_real(sc, tan((s7_Double)(fraction(x)))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      if (imag_part(x) > 350.0)
	return(s7_make_complex(sc, 0.0, 1.0));
      if (imag_part(x) < -350.0)
	return(s7_make_complex(sc, 0.0, -1.0));
      return(s7_from_c_complex(sc, ctan(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->TAN, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->TAN, args);
      return(simple_wrong_type_argument_with_type(sc, sc->TAN, x, A_NUMBER));
    }
}


static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
{
  #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x"
  s7_pointer n;

  n = car(args);
  switch (type(n))
    {
    case T_INTEGER:
      if (integer(n) == 0) return(small_int(0));                    /* (asin 0) -> 0 */

      /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex
       */

    case T_REAL:
    case T_RATIO:
      {
	s7_Double x, absx, recip;
	s7_Complex result;
	x = number_to_real(n);
	absx = fabs(x);
	if (absx <= 1.0)
	  return(make_real(sc, asin(x)));
      
	/* otherwise use maxima code: */
	recip = 1.0 / absx;
	result = (M_PI / 2.0) - (_Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))));
	if (x < 0.0)
	  return(s7_from_c_complex(sc, -result));
	return(s7_from_c_complex(sc, result));
      }

    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(n)) > 1.0e7) ||
	  (fabs(imag_part(n)) > 1.0e7))
	{
	  s7_Complex sq1mz, sq1pz, z;
	  z = as_c_complex(n);
	  sq1mz = csqrt(1.0 - z);
	  sq1pz = csqrt(1.0 + z);
	  return(s7_make_complex(sc, 
				 atan(real_part(n) / creal(sq1mz * sq1pz)),
				 asinh(cimag(sq1pz * conj(sq1mz)))));
	}
      return(s7_from_c_complex(sc, casin(as_c_complex(n))));
#else
      return(out_of_range(sc, sc->ASIN, small_int(1), n, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, n, sc->ASIN, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ASIN, n, A_NUMBER));
    }
}


static s7_pointer g_acos(s7_scheme *sc, s7_pointer args)
{
  #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
  s7_pointer n;

  n = car(args);
  switch (type(n))
    {
    case T_INTEGER:
      if (integer(n) == 1) return(small_int(0));

    case T_REAL:
    case T_RATIO:
      {
	s7_Double x, absx, recip;
	s7_Complex result;
	x = number_to_real(n);
	absx = fabs(x);
	if (absx <= 1.0)
	  return(make_real(sc, acos(x)));
      
	/* else follow maxima again: */
	recip = 1.0 / absx;
	if (x > 0.0)
	  result = _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
	else result = M_PI - _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
	return(s7_from_c_complex(sc, result));
      }

    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(n)) > 1.0e7) ||
	  (fabs(imag_part(n)) > 1.0e7))
	{
	  s7_Complex sq1mz, sq1pz, z;
	  z = as_c_complex(n);
	  sq1mz = csqrt(1.0 - z);
	  sq1pz = csqrt(1.0 + z);
	  return(s7_make_complex(sc, 
				 2.0 * atan(creal(sq1mz) / creal(sq1pz)),
				 asinh(cimag(sq1mz * conj(sq1pz)))));
	}
      return(s7_from_c_complex(sc, cacos(s7_complex(n))));
#else
      return(out_of_range(sc, sc->ACOS, small_int(1), n, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, n, sc->ACOS, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ACOS, n, A_NUMBER));
    }
}


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)"
  s7_pointer x, y;

  /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */

  x = car(args);
  if (!is_pair(cdr(args)))
    {
      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == 0) return(small_int(0));                /* (atan 0) -> 0 */
	  
	case T_REAL:
	case T_RATIO:
	  return(make_real(sc, atan(number_to_real(x))));

	case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
	  return(s7_from_c_complex(sc, catan(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->ATAN, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

	default:
	  CHECK_METHOD(sc, x, sc->ATAN, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->ATAN, x, A_NUMBER));
	}
    }

  if (!s7_is_real(x))
    {
      CHECK_METHOD(sc, x, sc->ATAN, args);
      return(wrong_type_argument(sc, sc->ATAN, small_int(1), x, T_REAL));
    }
  y = cadr(args);
  if (!s7_is_real(y))
    {
      CHECK_METHOD(sc, y, sc->ATAN, args);
      return(wrong_type_argument(sc, sc->ATAN, small_int(2), y, T_REAL));
    }
  return(make_real(sc, atan2(number_to_real(x), number_to_real(y))));
}  


static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args)
{
  #define H_sinh "(sinh z) returns sinh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                    /* (sinh 0) -> 0 */

    case T_REAL:
    case T_RATIO:
      return(make_real(sc, sinh(number_to_real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, csinh(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->SINH, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->SINH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->SINH, x, A_NUMBER));
    }
}


static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args)
{
  #define H_cosh "(cosh z) returns cosh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(1));                   /* (cosh 0) -> 1 */

    case T_REAL:
    case T_RATIO:
      /* this is not completely correct when optimization kicks in.
       * :(define (hi) (do ((i 0 (+ i 1))) ((= i 1)) (display (cosh i))))
       * hi
       * :(hi)
       * 1.0()
       * :(cosh 0)
       * 1
       */
      return(make_real(sc, cosh(number_to_real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, ccosh(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->COSH, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->COSH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->COSH, x, A_NUMBER));
    }
}


static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args)
{
  #define H_tanh "(tanh z) returns tanh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                   /* (tanh 0) -> 0 */

    case T_REAL:
    case T_RATIO:
      return(make_real(sc, tanh(number_to_real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      if (real_part(x) > 350.0)
	return(real_one);               /* closer than 0.0 which is what ctanh is about to return! */
      if (real_part(x) < -350.0)
	return(make_real(sc, -1.0));              /* closer than -0.0 which is what ctanh is about to return! */
      return(s7_from_c_complex(sc, ctanh(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->TANH, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->TANH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->TANH, x, A_NUMBER));
    }
}


static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args)
{
  #define H_asinh "(asinh z) returns asinh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));

    case T_REAL:
    case T_RATIO:
      return(make_real(sc, asinh(number_to_real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, casinh(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->ASINH, small_int(1), x, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->ASINH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ASINH, x, A_NUMBER));
    }
}


static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args)
{
  #define H_acosh "(acosh z) returns acosh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 1) return(small_int(0));

    case T_REAL:
    case T_RATIO:
      if (number_to_real(x) >= 1.0)
	return(make_real(sc, acosh(number_to_real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, cacosh(s7_complex(x)))); /* not as_c_complex because x might not be complex */
#else
      /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
      return(out_of_range(sc, sc->ACOSH, small_int(1), x, "a number >= 1.0 (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->ACOSH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ACOSH, x, A_NUMBER));
    }
}


static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args)
{
  #define H_atanh "(atanh z) returns atanh(z)"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                    /* (atanh 0) -> 0 */

    case T_REAL:
    case T_RATIO:
      if (fabs(number_to_real(x)) < 1.0)
	return(make_real(sc, atanh(number_to_real(x))));

      /* 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
       */
    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, catanh(s7_complex(x))));
#else
      return(out_of_range(sc, sc->ATANH, small_int(1), x, "a number between -1.0 and 1.0 (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, x, sc->ATANH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ATANH, x, A_NUMBER));
    }
}


static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args)
{
  #define H_sqrt "(sqrt z) returns the square root of z"
  s7_pointer n;
  s7_Double sqx;

  n = car(args);
  switch (type(n))
    {
    case T_INTEGER:
      if (integer(n) >= 0)
	{
	  s7_Int ix;
	  sqx = sqrt((s7_Double)integer(n));
	  ix = (s7_Int)sqx;
	  if ((ix * ix) == integer(n))
	    return(make_integer(sc, ix));
	  return(make_real(sc, sqx));
	  /* Mark Weaver notes that 
	   *     (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t
	   * but (* 94906265 94906265) -> 9007199136250225 -- oops
	   * at least we return a real here, not an incorrect integer and
	   *     (sqrt 9007199136250225) -> 94906265
	   */
	}
      sqx = (s7_Double)integer(n); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */
      return(s7_make_complex(sc, 0.0, sqrt((s7_Double)(-sqx))));
      break;

    case T_RATIO:
      sqx = fraction(n);
      if (sqx > 0.0) /* else it's complex, so it can't be a ratio */
	{
	  s7_Int nm = 0, dn = 1;
	  if (c_rationalize(sqx, 1.0e-16, &nm, &dn)) /* 1e-16 so that (sqrt 1/1099511627776) returns 1/1048576 */
	    {
	      if ((nm * nm == numerator(n)) &&
		  (dn * dn == denominator(n)))
		return(s7_make_ratio(sc, nm, dn));
	    }
	  return(make_real(sc, sqrt(sqx)));
	}
      return(s7_make_complex(sc, 0.0, sqrt(-sqx)));
      break;

    case T_REAL:
      if (is_NaN(real(n)))
	return(real_NaN);
      if (real(n) >= 0.0)
	return(make_real(sc, sqrt(real(n))));
      return(s7_make_complex(sc, 0.0, sqrt(-real(n))));
      break;

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, csqrt(as_c_complex(n))));
      break;
#else
      return(out_of_range(sc, sc->SQRT, small_int(1), n, "a real number (no complex numbers in this version of s7)"));
#endif

    default:
      CHECK_METHOD(sc, n, sc->SQRT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->SQRT, n, A_NUMBER));
    }
}


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;
    x *= x;
  } while (n);
  return(value);
}


static const long long int nth_roots[63] = {
  S7_LLONG_MAX, S7_LLONG_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 const long int_nth_roots[31] = {
  S7_LONG_MAX, S7_LONG_MAX, 46340, 1290, 215, 73, 35, 21, 14, 10, 8, 7, 5, 5, 4, 4, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2};

static bool int_pow_ok(s7_Int x, s7_Int y)
{
  if (s7_int_bits > 31)
    return((y < 63) &&
	   (nth_roots[y] >= s7_Int_abs(x)));
  return((y < 31) &&
	 (int_nth_roots[y] >= s7_Int_abs(x)));
}


static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
{
  #define H_expt "(expt z1 z2) returns z1^z2"
  s7_pointer n, pw;
  
  n = car(args);
  if (!s7_is_number(n))
    {
      CHECK_METHOD(sc, n, sc->EXPT, args);
      return(wrong_type_argument_with_type(sc, sc->EXPT, small_int(1), n, A_NUMBER));
    }
  pw = cadr(args);
  if (!s7_is_number(pw))
    {
      CHECK_METHOD(sc, pw, sc->EXPT, args);
      return(wrong_type_argument_with_type(sc, sc->EXPT, small_int(2), pw, A_NUMBER));
    }
  /* this provides more than 2 args to expt:
   *  if (is_not_null(cddr(args)))
   *    return(g_expt(sc, list_2(sc, car(args), g_expt(sc, cdr(args)))));
   *
   * but it's unusual in scheme to process args in reverse order, and the
   * syntax by itself is ambiguous (does (expt 2 2 3) = 256 or 64?)
   */

  if (s7_is_zero(n))
    {
      if (s7_is_zero(pw))
	{
	  if ((s7_is_integer(n)) && (s7_is_integer(pw)))       /* (expt 0 0) -> 1 */
	    return(small_int(1));
	  return(real_zero);                                   /* (expt 0.0 0) -> 0.0 */
	}

      if (s7_is_real(pw))
	{
	  if (s7_is_negative(pw))                              /* (expt 0 -1) */
	    return(division_by_zero_error(sc, sc->EXPT, args));  
	  /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */

	  if ((!s7_is_rational(pw)) &&                         /* (expt 0 most-positive-fixnum) */
	      (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) */
	    return(division_by_zero_error(sc, sc->EXPT, args));  
	}

      if ((s7_is_integer(n)) && (s7_is_integer(pw)))           /* pw != 0, (expt 0 2312) */
	return(small_int(0));
      return(real_zero);                                       /* (expt 0.0 123123) */
    }

  if (s7_is_one(pw))
    {
      if (s7_is_integer(pw))
	return(n);
      if (is_rational(n))
	return(make_real(sc, number_to_real(n)));
      return(n);
    }
  
  if (type(pw) == T_INTEGER)
    {
      s7_Int y;
      y = integer(pw);
      if (y == 0)
	{
	  if (is_rational(n))                                 /* (expt 3 0) */
	    return(small_int(1));
	  if ((is_NaN(s7_real_part(n))) ||                    /* (expt 1/0 0) -> NaN */
	      (is_NaN(s7_imag_part(n))))                      /* (expt (make-rectangular 0 1/0) 0) -> NaN */
	    return(n);                                        
	  return(real_one);                                   /* (expt 3.0 0) */
	}

      switch (type(n))
	{
	case T_INTEGER:
	  {
	    s7_Int x;
	    x = s7_integer(n);
	    if (x == 1)                                       /* (expt 1 y) */
	      return(n);
	    
	    if (x == -1)
	      {
		if (y == S7_LLONG_MIN)                        /* (expt -1 most-negative-fixnum) */
		  return(small_int(1));
		
		if (s7_Int_abs(y) & 1)                        /* (expt -1 odd-int) */
		  return(n);
		return(small_int(1));                         /* (expt -1 even-int) */
	      }
	    
	    if (y == S7_LLONG_MIN)                            /* (expt x most-negative-fixnum) */
	      return(small_int(0));                      
	    if (x == S7_LLONG_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(s7_make_ratio(sc, 1, int_to_int(x, -y)));
	      }
	  }
	  break;

	case T_RATIO:
	  {
	    s7_Int nm, dn;
	    
	    nm = numerator(n);
	    dn = denominator(n);
	    
	    if (y == S7_LLONG_MIN)
	      {
		if (s7_Int_abs(nm) > dn)
		  return(small_int(0));              /* (expt 4/3 most-negative-fixnum) -> 0? */
		return(make_real(sc, 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(s7_make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y)));
		return(s7_make_ratio(sc, int_to_int(dn, -y), int_to_int(nm, -y)));
	      }
	  }
	  break;
	  /* occasionally int^rat can be int 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_LLONG_MIN)
		return(real_one);
		
	      if (s7_Int_abs(y) & 1)
		return(n);
	      return(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, np;
	      yp = (y > 0);
	      np = (s7_imag_part(n) > 0.0);
	      switch (s7_Int_abs(y) % 4)
		{
		case 0: return(real_one);
		case 1: return(s7_make_complex(sc, 0.0, (yp == np) ? 1.0 : -1.0));
		case 2: return(make_real(sc, -1.0));
		case 3: return(s7_make_complex(sc, 0.0, (yp == np) ? -1.0 : 1.0));
		}
	    }
#else
	  return(out_of_range(sc, sc->EXPT, small_int(2), n, "a real number (no complex numbers in this version of s7)"));
#endif
	  break;
	}
    }

  if ((s7_is_real(n)) &&
      (s7_is_real(pw)))
    {
      s7_Double x, y;

      if ((type(pw) == T_RATIO) &&
	  (numerator(pw) == 1))
	{
	  if (denominator(pw) == 2)
	    return(g_sqrt(sc, args));
	  if (denominator(pw) == 3)
	    return(make_real(sc, cbrt(number_to_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 = number_to_real(n);
      y = number_to_real(pw);

      if (is_NaN(x)) return(n);
      if (is_NaN(y)) return(pw);
      if (y == 0.0) return(real_one);

      if ((x > 0.0) ||
	  ((y - floor(y)) < 1.0e-16))
	return(make_real(sc, pow(x, y)));
    }
  
  /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ? 
   * (expt 0+i 1+1/0i) = 0.0 ??
   */
  return(s7_from_c_complex(sc, cpow(s7_complex(n), s7_complex(pw))));
}


static s7_Int c_lcm(s7_Int a, s7_Int b)
{
  if ((a == 0) || (b == 0)) return(0);
  if (a < 0) a = -a;
  if (b < 0) b = -b;
  return((a / c_gcd(a, b)) * b);
}


static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
{
  #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
  s7_Int n = 1, d = 0;
  bool rats = false;
  s7_pointer x;

  if (!is_pair(args))
    return(small_int(1));

  if (!is_pair(cdr(args)))
    {
      if (!is_rational(car(args)))
	{
	  CHECK_METHOD(sc, car(args), sc->LCM, args);
	  return(wrong_type_argument_with_type(sc, sc->LCM, small_int(1), car(args), A_RATIONAL));
	}
      return(g_abs(sc, args));
    }

  for (x = args; is_not_null(x); x = cdr(x)) 
    if (!is_rational(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->LCM, args);
	return(wrong_type_argument_n_with_type(sc, sc->LCM, position_of(x, args), car(x), A_RATIONAL));
      }
    else rats = ((rats) || (type(car(x)) == T_RATIO));

  if (!rats)
    {
      for (x = args; is_not_null(x); x = cdr(x)) 
	{
	  n = c_lcm(n, integer(car(x)));
	  if (n < 0) return(simple_out_of_range(sc, sc->LCM, args, "result is too large"));
	  if (n == 0)
	    return(small_int(0));
	}
      return(make_integer(sc, n));
    }

  /* from A Jaffer */
  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      n = c_lcm(n, s7_numerator(car(x)));
      if (n < 0) return(simple_out_of_range(sc, sc->LCM, args, "result is too large"));
      if (n == 0)
	return(small_int(0));
      d = c_gcd(d, s7_denominator(car(x)));
    }
  return(s7_make_ratio(sc, n, d));
}


static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
{
  #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
  bool rats = false;
  s7_Int n = 0, d = 1;
  s7_pointer x;

  if (!is_pair(args))
    return(small_int(0));

  if (!is_pair(cdr(args)))
    {
      if (!is_rational(car(args)))
	{
	  CHECK_METHOD(sc, car(args), sc->GCD, args);
	  return(wrong_type_argument_with_type(sc, sc->GCD, small_int(1), car(args), A_RATIONAL));
	}
      return(g_abs(sc, args));
    }

  for (x = args; is_not_null(x); x = cdr(x)) 
    if (!is_rational(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->GCD, args);
	return(wrong_type_argument_n_with_type(sc, sc->GCD, position_of(x, args), car(x), A_RATIONAL));
      }
    else rats = ((rats) || (type(car(x)) == T_RATIO));
  
  if (!rats)
    {
      for (x = args; is_not_null(x); x = cdr(x)) 
	{
	  n = c_gcd(n, integer(car(x)));
	  if (n < 0) return(simple_out_of_range(sc, sc->GCD, args, "intermediate result is too large"));
	  if (n == 1) return(small_int(1));
	}
      return(make_integer(sc, n));
    }

  /* from A Jaffer */
  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      n = c_gcd(n, s7_numerator(car(x)));
      if (n < 0) return(simple_out_of_range(sc, sc->GCD, args, "intermediate result is too large"));
      d = c_lcm(d, s7_denominator(car(x)));
      if (d < 0) return(simple_out_of_range(sc, sc->GCD, args, "intermediate result is too large"));
    }
  return(s7_make_ratio(sc, n, d));
}


static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_Double xf)   /* can't use "truncate" -- it's in unistd.h */
{
  if ((xf > S7_LLONG_MAX) ||
      (xf < S7_LLONG_MIN))
    return(simple_out_of_range(sc, caller, make_real(sc, xf), "too large to express as an integer"));

  if (xf > 0.0)
    return(make_integer(sc, (s7_Int)floor(xf)));
  return(make_integer(sc, (s7_Int)ceil(xf)));
}



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 (quo x1 x2) (truncate (/ x1 x2))) ; slib 
   */  
  s7_pointer x, y;
  s7_Int d1, d2, n1, n2;

  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  if ((integer(y) == -1) && (integer(x) == S7_LLONG_MIN))   /* (quotient most-negative-fixnum -1) */
	    return(simple_out_of_range(sc, sc->QUOTIENT, args, "too large to express as an integer"));	    
	  return(make_integer(sc, integer(x) / integer(y)));

	case T_RATIO:
	  n1 = integer(x);
	  d1 = 1;
	  n2 = numerator(y);
	  d2 = denominator(y);
	  goto RATIO_QUO_RATIO;

	case T_REAL:
	  if (real(y) == 0.0) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->QUOTIENT, small_int(2), y, A_NORMAL_REAL));
	  return(s7_truncate(sc, sc->QUOTIENT, (s7_Double)integer(x) / real(y)));

	default:    
	  CHECK_METHOD(sc, y, sc->QUOTIENT, args);    
	  return(wrong_type_argument(sc, sc->QUOTIENT, small_int(2), y, T_REAL));
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = integer(y);
	  d2 = 1;
	  goto RATIO_QUO_RATIO;

	case T_RATIO:
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = numerator(y);
	  d2 = denominator(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 ((integer_length(n1) + integer_length(d2) >= s7_int_bits) ||
	      (integer_length(n2) + integer_length(d1) >= s7_int_bits))
	    return(s7_truncate(sc, sc->QUOTIENT, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
	  /* this can lose:
	   *   (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1
	   *   (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0
	   */
	  return(make_integer(sc, (n1 * d2) / (n2 * d1)));  /* (quotient 922337203685477580 1/3) */

	case T_REAL:
	  if (real(y) == 0.0) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->QUOTIENT, small_int(2), y, A_NORMAL_REAL));
	  return(s7_truncate(sc, sc->QUOTIENT, (s7_Double)fraction(x) / real(y)));

	default:        
	  CHECK_METHOD(sc, y, sc->QUOTIENT, args);
	  return(wrong_type_argument(sc, sc->QUOTIENT, small_int(2), y, T_REAL));
	}

    case T_REAL:
      if ((is_inf(real(x))) || (is_NaN(real(x))))
	return(wrong_type_argument_with_type(sc, sc->QUOTIENT, small_int(1), x, A_NORMAL_REAL));

      /* 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) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  return(s7_truncate(sc, sc->QUOTIENT, real(x) / (s7_Double)integer(y)));

	case T_RATIO:
	  return(s7_truncate(sc, sc->QUOTIENT, real(x) / (s7_Double)fraction(y)));

	case T_REAL:
	  if (real(y) == 0.0) 
	    return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->QUOTIENT, small_int(2), y, A_NORMAL_REAL));
	  return(s7_truncate(sc, sc->QUOTIENT, real(x) / real(y)));

	default:        
	  CHECK_METHOD(sc, y, sc->QUOTIENT, args);
	  return(wrong_type_argument(sc, sc->QUOTIENT, small_int(2), y, T_REAL));
	}

    default:
      CHECK_METHOD(sc, x, sc->QUOTIENT, args);
      return(wrong_type_argument(sc, sc->QUOTIENT, small_int(1), x, T_REAL));
    }
}


static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
  #define H_remainder "(remainder x1 x2) returns the integer remainder of x1 and x2; (remainder 10 3) = 1"
  /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib 
   */
  s7_pointer x, y;
  s7_Int quo, d1, d2, n1, n2;
  s7_Double pre_quo;

  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) 
	    return(division_by_zero_error(sc, sc->REMAINDER, args));
	  if ((integer(y) == 1) || (integer(y) == -1))
	    return(make_integer(sc, 0));
	  /* (remainder most-negative-fixnum -1) will segfault with arithmetic exception */
	  return(make_integer(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) 
	    return(division_by_zero_error(sc, sc->REMAINDER, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->REMAINDER, small_int(2), y, A_NORMAL_REAL));

	  pre_quo = (s7_Double)integer(x) / real(y);
	  if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
	    return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
	  if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);
	  return(make_real(sc, integer(x) - real(y) * quo));

	default:        
	  CHECK_METHOD(sc, y, sc->REMAINDER, args);
	  return(wrong_type_argument(sc, sc->REMAINDER, small_int(2), y, T_REAL));
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  n2 = integer(y);
	  if (n2 == 0) 
	    return(division_by_zero_error(sc, sc->REMAINDER, args));
	  n1 = numerator(x);
	  d1 = denominator(x);
	  d2 = 1;
	  goto RATIO_REM_RATIO;

	case T_RATIO:
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = numerator(y);
	  d2 = denominator(y);
	RATIO_REM_RATIO:
	  if (d1 == d2)
	    quo = (s7_Int)(n1 / n2);
	  else
	    {
	      if (n1 == n2)
		quo = (s7_Int)(d2 / d1);
	      else
		{
		  if ((integer_length(n1) + integer_length(d2) >= s7_int_bits) ||
		      (integer_length(n2) + integer_length(d1) >= s7_int_bits))
		    {
		      pre_quo = ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1);
		      if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
			return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
		      if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);
		    }
		  else quo = (n1 * d2) / (n2 * d1);
		}
	    }
	  if (quo == 0)
	    return(x);

	  if ((d1 == d2) &&
	      ((integer_length(n2) + integer_length(quo)) < s7_int_bits))
	    return(s7_make_ratio(sc, n1 - n2 * quo, d1));
      
	  if ((integer_length(n1) + integer_length(d2) < s7_int_bits) &&
	      (integer_length(d1) + integer_length(d2) < s7_int_bits) &&
	      (integer_length(n2) + integer_length(d1) + integer_length(quo) < s7_int_bits))
	    return(s7_make_ratio(sc, n1 * d2 - n2 * d1 * quo, d1 * d2));
	  return(simple_out_of_range(sc, sc->REMAINDER, args, "intermediate (a/b) is too large"));

	case T_REAL:
	  {
	    s7_Double frac;
	    if (real(y) == 0.0) 
	      return(division_by_zero_error(sc, sc->REMAINDER, args));
	    if ((is_inf(real(y))) || (is_NaN(real(y))))
	      return(wrong_type_argument_with_type(sc, sc->REMAINDER, small_int(2), y, A_NORMAL_REAL));
	    frac = fraction(x);
	    pre_quo = frac / real(y);
	    if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
	      return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
	    if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);
	    return(make_real(sc, frac - real(y) * quo));
	  }

	default:        
	  CHECK_METHOD(sc, y, sc->REMAINDER, args);
	  return(wrong_type_argument(sc, sc->REMAINDER, small_int(2), y, T_REAL));
	}

    case T_REAL:
      if ((is_inf(real(x))) || (is_NaN(real(x))))
	return(wrong_type_argument_with_type(sc, sc->REMAINDER, small_int(1), x, A_NORMAL_REAL));

      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) 
	    return(division_by_zero_error(sc, sc->REMAINDER, args));
	  pre_quo = real(x) / (s7_Double)integer(y);
	  if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
	    return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
	  if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);
	  return(make_real(sc, real(x) - integer(y) * quo));

	case T_RATIO:
	  {
	    /* bad cases here start around 1e16: (remainder 1e15 3/13) -> 0.0 with loss of digits earlier
	     *   would long double help?  
	     */
	    s7_Double frac;
	    frac = fraction(y);
	    pre_quo = real(x) / frac;
	    if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
	      return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
	    if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);
	    return(make_real(sc, real(x) - frac * quo));
	  }

	case T_REAL:
	  if (real(y) == 0.0) 
	    return(division_by_zero_error(sc, sc->REMAINDER, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->REMAINDER, small_int(2), y, A_NORMAL_REAL));

	  pre_quo = real(x) / real(y);
	  if ((pre_quo > S7_LLONG_MAX) || (pre_quo < S7_LLONG_MIN))
	    return(simple_out_of_range(sc, sc->REMAINDER, args, "too large to express as an integer"));
	  if (pre_quo > 0.0) quo = (s7_Int)floor(pre_quo); else quo = (s7_Int)ceil(pre_quo);

	  return(make_real(sc, real(x) - real(y) * quo));

	  /* see under sin -- this calculation is completely bogus if "a" is large
	   * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 -- should this return arithmetic-overflow?
	   *          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:        
	  CHECK_METHOD(sc, y, sc->REMAINDER, args);
	  return(wrong_type_argument(sc, sc->REMAINDER, small_int(2), y, T_REAL));
	}

    default:
      CHECK_METHOD(sc, x, sc->REMAINDER, args);
      return(wrong_type_argument(sc, sc->REMAINDER, small_int(1), x, T_REAL));
    }
}


#define REAL_TO_INT_LIMIT 9.2233727815085e+18
/* unfortunately, this limit is only a max in a sense:
 *    (ceiling 9223372036854770.9)  => 9223372036854770
 *    see s7test for more examples
 */

static s7_pointer g_floor(s7_scheme *sc, s7_pointer args)
{
  #define H_floor "(floor x) returns the integer closest to x toward -inf"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:   
      return(x);

    case T_RATIO: 
      {
	s7_Int val;
	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 */
	if (numerator(x) < 0) /* not "val" because it might be truncated to 0 */
	  return(make_integer(sc, val - 1));
	return(make_integer(sc, val));
      }

    case T_REAL:
      {
	s7_Double z;
	z = real(x);
	if (is_NaN(z))
	  return(simple_out_of_range(sc, sc->FLOOR, x, "argument is NaN"));
	if ((is_inf(z)) ||
	    (z > REAL_TO_INT_LIMIT) ||
	    (z < -REAL_TO_INT_LIMIT))
	  return(simple_out_of_range(sc, sc->FLOOR, x, "argument is too large"));
	return(make_integer(sc, (s7_Int)floor(real(x)))); 
      }

    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->FLOOR, args);
      return(simple_wrong_type_argument(sc, sc->FLOOR, x, T_REAL));
    }
  /* we can't assume things like floor return an integer because there might be methods in play,
   *   or C-side extensions like + for string-append.
   */
}


static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
{
  #define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:   
      return(x);

    case T_RATIO:
      {
	s7_Int val;
	val = numerator(x) / denominator(x);
	if (numerator(x) < 0)
	  return(make_integer(sc, val));
	return(make_integer(sc, val + 1));
      }

    case T_REAL:
      {
	s7_Double z;
	z = real(x);
	if (is_NaN(z))
	  return(simple_out_of_range(sc, sc->CEILING, x, "argument is NaN"));
	if ((is_inf(z)) ||
	    (z > REAL_TO_INT_LIMIT) ||
	    (z < -REAL_TO_INT_LIMIT))
	  return(simple_out_of_range(sc, sc->CEILING, x, "argument is too large"));
	return(make_integer(sc, (s7_Int)ceil(real(x)))); 
      }

    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->CEILING, args);
      return(simple_wrong_type_argument(sc, sc->CEILING, x, 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"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER: 
      return(x);

    case T_RATIO: 
      return(make_integer(sc, (s7_Int)(numerator(x) / denominator(x)))); /* C "/" already truncates */

    case T_REAL:
      {
	s7_Double z;
	z = real(x);
	if (is_NaN(z))
	  return(simple_out_of_range(sc, sc->TRUNCATE, x, "argument is NaN"));
	if (is_inf(z))
	  return(simple_out_of_range(sc, sc->TRUNCATE, x, "argument is infinite"));
	return(s7_truncate(sc, sc->TRUNCATE, real(x))); 
      }

    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->TRUNCATE, args);
      return(simple_wrong_type_argument(sc, sc->TRUNCATE, x, T_REAL));
    }
}


static s7_Double round_per_R5RS(s7_Double x) 
{
  s7_Double fl, ce, dfl, dce;

  fl = floor(x);
  ce = ceil(x);
  dfl = x - fl;
  dce = ce - x;
  
  if (dfl > dce) return(ce);
  if (dfl < dce) return(fl);
  if (fmod(fl, 2.0) == 0.0) return(fl);
  return(ce);
}


static s7_pointer g_round(s7_scheme *sc, s7_pointer args)
{
  #define H_round "(round x) returns the integer closest to x"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER: 
      return(x);

    case T_RATIO: 
      {
	s7_Int truncated, remains;
	long double frac;

	truncated = numerator(x) / denominator(x);
	remains = numerator(x) % denominator(x);
	frac = s7_fabsl((long double)remains / (long double)denominator(x));

	if ((frac > 0.5) ||
	    ((frac == 0.5) &&
	     (truncated % 2 != 0)))
	  {
	    if (numerator(x) < 0)
	      return(make_integer(sc, truncated - 1));
	    return(make_integer(sc, truncated + 1));
	  }
	return(make_integer(sc, truncated));
      }

    case T_REAL:
      {
	s7_Double z;
	z = real(x);
	if (is_NaN(z))
	  return(simple_out_of_range(sc, sc->ROUND, x, "argument is NaN"));
	if ((is_inf(z)) ||
	    (z > REAL_TO_INT_LIMIT) ||
	    (z < -REAL_TO_INT_LIMIT))
	  return(simple_out_of_range(sc, sc->ROUND, x, "argument is too large"));
	return(make_integer(sc, (s7_Int)round_per_R5RS(z)));
      }

    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->ROUND, args);
      return(simple_wrong_type_argument(sc, sc->ROUND, x, T_REAL));
    }
}


static s7_Int c_mod(s7_Int x, s7_Int y)
{
  s7_Int z;
  /* if (y == 0) return(x); */ /* else arithmetic exception, but we're checking for this elsewhere */
  z = x % y;
  if (((y < 0) && (z > 0)) ||
      ((y > 0) && (z < 0)))
    return(z + y);
  return(z);
}


/*
(define (exptmod a b n) ; from the net somewhere
  (cond ((zero? b) 1)
        ((even? b) (exptmod (modulo (* a a) n) (quotient b 2) n))
        (else (modulo (* a (exptmod (modulo (* a a) n) (quotient b 2) n)) n))))

(define (compare a b n) 
  (list (exptmod a b n) 
        (modulo (expt a b) n)))

;; using gmp
:(compare 4 20 7)
(2 2)
:(compare 4 20 3)
(1 1)
:(compare 117 30 11)
(1 1)
:(compare 1170 310 13)
(0 0)
:(compare 1178 31 13)
(5 5)
:(compare 1178 31 131211)
(59921 59921)
:(compare 117812 31 131211)
(85196 85196)
:(compare 117812 311 131211)
(91715 91715)
:(compare 117812 311 13121112334)
(4399226350 4399226350)

;; could this be built-into the non-gmp case?
*/

static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
{
  #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1.  The arguments can be real numbers."
  /* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib 
   * (mod x 0) = x according to "Concrete Mathematics"
   */
  s7_pointer x, y;
  s7_Double a, b;
  s7_Int n1, n2, d1, d2;

  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) 
	    return(x);
	  if ((integer(y) == 1) || (integer(y) == -1))
	    return(small_int(0));
	  /* (modulo most-negative-fixnum -1) will segfault with arithmetic exception */
	  return(make_integer(sc, c_mod(integer(x), integer(y))));

	case T_RATIO:
	  n1 = integer(x);
	  d1 = 1;
	  n2 = numerator(y);
	  d2 = denominator(y);
	  goto RATIO_MOD_RATIO;

	case T_REAL:
	  b = real(y);
	  if (b == 0.0) return(x);
	  if (is_NaN(b)) return(y);
	  if (is_inf(b)) return(real_NaN);
	  a = (s7_Double)integer(x);
	  return(make_real(sc, a - b * (s7_Int)floor(a / b)));

	default:
	  CHECK_METHOD(sc, y, sc->MODULO, args);
	  return(wrong_type_argument(sc, sc->MODULO, small_int(2), y, T_REAL));
	}

    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_LLONG_MIN)
	    return(simple_out_of_range(sc, sc->MODULO, y, "intermediate (a/b) is too large"));	
	  /* the problem here is that (modulo 3/2 most-negative-fixnum)
	   * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it.
	   */

	  d2 = 1;
	  goto RATIO_MOD_RATIO;

	case T_RATIO:
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = numerator(y); /* can't be 0 */
	  d2 = denominator(y);
	  if (d1 == d2)
	    return(s7_make_ratio(sc, c_mod(n1, n2), d1));

	RATIO_MOD_RATIO:

	  if ((n1 == n2) &&
	      (d1 > d2))
	    return(x);                 /* signs match so this should be ok */

	  if ((integer_length(n1) + integer_length(d2) < s7_int_bits) &&
	      (integer_length(n2) + integer_length(d1) < s7_int_bits) &&
	      (integer_length(d1) + integer_length(d2) < s7_int_bits))
	    {
	      s7_Int n1d2, n2d1, fl;
	      n1d2 = n1 * d2;
	      n2d1 = n2 * d1;
	      
	      if (n2d1 == 1)
		return(small_int(0));
	      
	      /* can't use "floor" here (int->float ruins everything) */
	      fl = (s7_Int)(n1d2 / n2d1);
	      if (((n1 < 0) && (n2 > 0)) ||
		  ((n1 > 0) && (n2 < 0)))
		fl -= 1;
	      
	      if (fl == 0)
		return(x);
	      
	      if (integer_length(n2d1) + integer_length(fl) < s7_int_bits)
		return(s7_make_ratio(sc, n1d2 - (n2d1 * fl), d1 * d2));
	    }

	  /* there are cases here we might want to catch:
	   *    (modulo 9223372036 1/9223372036) -> error, not 0?
	   *    (modulo 1 1/9223372036854775807) -> error, not 0?
	   */
	  return(simple_out_of_range(sc, sc->MODULO, x, "intermediate (a/b) is too large"));	
      
	case T_REAL:
	  b = real(y);
	  if (b == 0.0) return(x);
	  if (is_NaN(b)) return(y);
	  if (is_inf(b)) return(real_NaN);
	  a = fraction(x);
	  return(make_real(sc, a - b * (s7_Int)floor(a / b)));

	default:
	  CHECK_METHOD(sc, y, sc->MODULO, args);
	  return(wrong_type_argument(sc, sc->MODULO, small_int(2), y, T_REAL));
	}

    case T_REAL:
      a = real(x);

      switch (type(y))
	{
	case T_INTEGER:
	  if (is_NaN(a)) return(x);
	  if (is_inf(a)) return(real_NaN);
	  if (integer(y) == 0) return(x);
	  b = (s7_Double)integer(y);
	  return(make_real(sc, a - b * (s7_Int)floor(a / b)));	  

	case T_RATIO:
	  if (is_NaN(a)) return(x);
	  if (is_inf(a)) return(real_NaN);
	  b = fraction(y);
	  return(make_real(sc, a - b * (s7_Int)floor(a / b)));	  

	case T_REAL:
	  if (is_NaN(a)) return(x);
	  if (is_inf(a)) return(real_NaN);
	  b = real(y);
	  if (b == 0.0) return(x);
	  if (is_NaN(b)) return(y);
	  if (is_inf(b)) return(real_NaN);
	  return(make_real(sc, a - b * (s7_Int)floor(a / b)));

	default:
	  CHECK_METHOD(sc, y, sc->MODULO, args);
	  return(wrong_type_argument(sc, sc->MODULO, small_int(2), y, T_REAL));
	}

    default:
      CHECK_METHOD(sc, x, sc->MODULO, args);
      return(wrong_type_argument(sc, sc->MODULO, small_int(1), x, T_REAL));
    }
}


static s7_pointer mod_si;
static s7_pointer g_mod_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int y;

  x = finder(sc, car(args));
  y = integer(cadr(args));

  if (is_integer(x))
    {
      s7_Int z;
      /* here we know y is positive */
      z = integer(x) % y;
      if (z < 0)
	return(make_integer(sc, z + y));
      return(make_integer(sc, z));
    }
  
  if (is_real(x))
    {
      s7_Double a, b;
      a = real(x);
      if (is_NaN(a)) return(x);
      if (is_inf(a)) return(real_NaN);
      b = (s7_Double)y;
      return(make_real(sc, a - b * (s7_Int)floor(a / b)));	  
    }

  if (s7_is_ratio(x))
    return(g_modulo(sc, list_2(sc, x, cadr(args))));

  CHECK_METHOD(sc, x, sc->MODULO, args);
  return(wrong_type_argument(sc, sc->MODULO, small_int(1), x, T_REAL));
}

static s7_pointer mod_si_is_zero;
static s7_pointer g_mod_si_is_zero(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int y;

  /* car is (modulo symbol integer), cadr is 0 or not present (if zero?) */
  x = finder(sc, cadar(args));
  y = integer(caddar(args));

  if (is_integer(x))
    return(make_boolean(sc, (integer(x) % y) == 0));
  
  if (is_real(x))
    return(make_boolean(sc, (fmod(real(x), (s7_Double)y) == 0.0)));

  if (s7_is_ratio(x))
    return(sc->F);

  CHECK_METHOD(sc, x, sc->MODULO, args);
  return(wrong_type_argument(sc, sc->MODULO, small_int(1), x, T_REAL));
}
#endif
/* !WITH_GMP */


static int reduce_fraction(s7_Int *numer, s7_Int *denom)
{
  /* we're assuming in several places that we have a normal s7 rational after returning,
   *    so the denominator needs to be positive.
   */
  s7_Int divisor;

  if (*numer == 0)
    {
      *denom = 1;
      return(T_INTEGER);
    }
  if (*denom < 0)
    {
      *denom = -*denom;
      *numer = -*numer;
    }
  divisor = c_gcd(*numer, *denom);
  if (divisor != 1)
    {
      *numer /= divisor;
      *denom /= divisor;
    }
  if (*denom == 1)
    return(T_INTEGER);
  return(T_RATIO);
}



/* ---------------------------------------- add ---------------------------------------- */

static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
{
  #define H_add "(+ ...) adds its arguments"
  s7_pointer x, p;
  s7_Int num_a, den_a;
  s7_Double rl_a, im_a;

#if (!WITH_GMP)
  if (is_null(args))
    return(small_int(0));
#endif
    
  x = car(args);
  p = cdr(args);
  if (is_null(p))
    {
      if (!is_number(x))
	{
	  CHECK_METHOD(sc, x, sc->ADD, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->ADD, x, A_NUMBER));
	}
      return(x);
    }

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);

    ADD_INTEGERS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_add(sc, cons(sc, s7_Int_to_big_integer(sc, num_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  den_a = num_a + integer(x);
	  if (den_a < 0)
	    {
	      if ((num_a > 0) && (integer(x) > 0))
		{
		  rl_a = (s7_Double)num_a + (s7_Double)integer(x);
		  if (is_null(p)) return(make_real(sc, rl_a));
		  goto ADD_REALS;
		}
	    }
	  else
	    {
	      if ((num_a < 0) && (integer(x) < 0))
		{
		  rl_a = (s7_Double)num_a + (s7_Double)integer(x);
		  if (is_null(p)) return(make_real(sc, rl_a));

		  /* this is not ideal!  piano.scm has its own noise generator that wants integer
		   *    arithmetic to overflow as an integer.  Perhaps *safety*==0 would not check
		   *    anywhere?
		   */
		  goto ADD_REALS;
		}
	    }
	  if (is_null(p)) return(make_integer(sc, den_a));
	  num_a = den_a;
	  /* (+ 4611686018427387904 4611686018427387904) -> -9223372036854775808 
	   * (+ most-positive-fixnum most-positive-fixnum) -> -2
	   * (+ most-negative-fixnum most-negative-fixnum) -> 0
	   * can't check result - arg: (- 0 most-negative-fixnum) -> most-negative-fixnum
	   */
	  goto ADD_INTEGERS;
	  
	case T_RATIO:
	  den_a = denominator(x);
	  if ((integer_length(num_a) + integer_length(den_a) + integer_length(numerator(x))) >= s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, num_a + fraction(x)));
	      rl_a = (s7_Double)num_a + fraction(x);
	      goto ADD_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, numerator(x) + (num_a * den_a), den_a));
	  num_a = numerator(x) + (num_a * den_a);

	  /* overflow examples:
	   *   (+ 100000 1/142857142857140) -> -832205957599110323/28571428571428
	   *   (+ 4611686018427387904 3/4) -> 3/4
	   * see s7test for more
	   */
	  /* there's no point in reduce_fraction here -- it can be reduced! 
	   */
	  goto ADD_RATIOS;
	  
	case T_REAL:
	  if (is_null(p)) return(make_real(sc, num_a + real(x)));
	  rl_a = (s7_Double)num_a + real(x);
	  goto ADD_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, num_a + real_part(x), imag_part(x)));
	  rl_a = (s7_Double)num_a + real_part(x);
	  im_a = imag_part(x);
	  goto ADD_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->ADD, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p))); /* we may need copy_list(sc, p) throughout -- not sure about this */
	  return(wrong_type_argument_n_with_type(sc, sc->ADD, position_of(p, args) - 1, x, A_NUMBER)); /* p is 1 past the current arg */
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    ADD_RATIOS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (den_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_add(sc, cons(sc, s7_ratio_to_big_ratio(sc, num_a, den_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if ((integer_length(integer(x)) + integer_length(den_a) + integer_length(num_a)) >= s7_int_bits)
	    {
	      /* (+ 3/4 4611686018427387904) -> 3/4
	       * (+ 1/17179869184 1073741824) -> 1/17179869184
	       * (+ 1/8589934592 1073741824) -> -9223372036854775807/8589934592
	       */
	      if (is_null(p))
		return(make_real(sc, (s7_Double)integer(x) + ((long double)num_a / (long double)den_a)));
	      rl_a = (s7_Double)integer(x) + ((long double)num_a / (long double)den_a);
	      goto ADD_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, num_a + (den_a * integer(x)), den_a));
	  num_a += (den_a * integer(x));
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto ADD_INTEGERS;
	  goto ADD_RATIOS;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = den_a;
	    n1 = num_a;
	    d2 = denominator(x);
	    n2 = numerator(x);
	    if (d1 == d2)                                     /* the easy case -- if overflow here, it matches the int case */
	      {
		if (is_null(p))
		  return(s7_make_ratio(sc, n1 + n2, d1));
		num_a += n2;                  /* d1 can't be zero */
	      }
	    else
	      {
#if (!WITH_GMP)
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (is_null(p))
			  return(make_real(sc, ((long double)n1 / (long double)d1) + ((long double)n2 / (long double)d2)));
			rl_a = ((long double)n1 / (long double)d1) + ((long double)n2 / (long double)d2);
			/* this can lose:
			 *   (+ 1 1/9223372036854775807 -1) -> 0.0 not 1/9223372036854775807
			 */
			goto ADD_REALS;
		      }
		  }
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, n1 * d2 + n2 * d1, d1 * d2));
		num_a = n1 * d2 + n2 * d1;
		den_a = d1 * d2;
	      }
	    /* (+ 1/100 99/100 (- most-positive-fixnum 2)) should not be converted to real
	     */
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto ADD_INTEGERS;
	  goto ADD_RATIOS;
	  }

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, ((long double)num_a / (long double)den_a) + real(x)));
	  rl_a = ((long double)num_a / (long double)den_a) + real(x);
	  goto ADD_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, ((long double)num_a / (long double)den_a) + real_part(x), imag_part(x)));
	  rl_a = ((long double)num_a / (long double)den_a) + real_part(x);
	  im_a = imag_part(x);
	  goto ADD_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->ADD, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->ADD, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_REAL:
      rl_a = real(x);

    ADD_REALS:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(make_real(sc, rl_a + integer(x)));
	  rl_a += (s7_Double)integer(x);
	  goto ADD_REALS;

	case T_RATIO:
	  if (is_null(p)) return(make_real(sc, rl_a + fraction(x)));
	  rl_a += (s7_Double)fraction(x);
	  goto ADD_REALS;

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, rl_a + real(x)));
	  rl_a += real(x);
	  goto ADD_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a + real_part(x), imag_part(x)));
	  rl_a += real_part(x);
	  im_a = imag_part(x);
	  goto ADD_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->ADD, cons(sc, make_real(sc, rl_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->ADD, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_COMPLEX:
      rl_a = real_part(x);
      im_a = imag_part(x);

    ADD_COMPLEX:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a + integer(x), im_a));
	  rl_a += (s7_Double)integer(x);
	  goto ADD_COMPLEX;

	case T_RATIO:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a + fraction(x), im_a));
	  rl_a += (s7_Double)fraction(x);
	  goto ADD_COMPLEX;

	case T_REAL:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a + real(x), im_a));
	  rl_a += real(x);
	  goto ADD_COMPLEX;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a + real_part(x), im_a + imag_part(x)));
	  rl_a += real_part(x);
	  im_a += imag_part(x);
	  if (im_a == 0.0)
	    goto ADD_REALS;
	  goto ADD_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->ADD, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->ADD, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
}



static s7_pointer add_1, add_2, add_1s, add_s1, add_cs1, add_si, add_si_i, add_is, add_sf, add_fs, add_2_temp, add_s_temp, add_temp_s, add_s_direct;

static s7_pointer add_ratios(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  s7_Int d1, d2, n1, n2;
  d1 = number_to_denominator(x);
  n1 = number_to_numerator(x);
  d2 = number_to_denominator(y);
  n2 = number_to_numerator(y);

  if (d1 == d2)                                     /* the easy case -- if overflow here, it matches the int case */
    return(s7_make_ratio(sc, n1 + n2, d1));

  if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
      (n1 > s7_int_max) || (n2 > s7_int_max) ||
      (n1 < s7_int_min) || (n2 < s7_int_min))
    {
      int d1bits, d2bits;
      d1bits = integer_length(d1);
      d2bits = integer_length(d2);
      if (((d1bits + d2bits) > s7_int_bits) ||
	  ((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
	  ((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
	return(make_real(sc, ((long double)n1 / (long double)d1) + ((long double)n2 / (long double)d2)));
    }
  return(s7_make_ratio(sc, n1 * d2 + n2 * d1, d1 * d2));
}


static s7_pointer g_add_1(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_number(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), car(args), A_NUMBER));
    }
  return(car(args));
}

static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  x = car(args);
  y = cadr(args);

  if (type(x) == type(y))
    {
      if (type(x) == T_REAL)
	return(make_real(sc, real(x) + real(y)));
      else
	{
	  switch (type(x))
	    {
	    case T_INTEGER: return(make_integer(sc, integer(x) + integer(y)));
	    case T_RATIO:   return(add_ratios(sc, x, y));
	    case T_REAL:    return(make_real(sc, real(x) + real(y)));
	    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
	    default: 
	      if (!is_number(x))
		{
		  CHECK_METHOD(sc, x, sc->ADD, args);
		  return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
		}
	      CHECK_METHOD(sc, y, sc->ADD, args);	  
	      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), y, A_NUMBER));
	    }
	}
    }

  switch (type(x))
    {
    case T_INTEGER: 
      switch (type(y))
	{
	case T_INTEGER: return(make_integer(sc, integer(x) + integer(y)));
	case T_RATIO:   return(add_ratios(sc, x, y));
	case T_REAL:    return(make_real(sc, integer(x) + real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, integer(x) + real_part(y), imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->ADD, args);	  
	  return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), y, A_NUMBER));
	}
      
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	case T_RATIO:   return(add_ratios(sc, x, y));
	case T_REAL:    return(make_real(sc, fraction(x) + real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, fraction(x) + real_part(y), imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->ADD, args);	  
	  return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), y, A_NUMBER));
	}
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(make_real(sc, real(x) + integer(y)));
	case T_RATIO:   return(make_real(sc, real(x) + fraction(y)));
	case T_REAL:    return(make_real(sc, real(x) + real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, real(x) + real_part(y), imag_part(y)));
	default:       
	  CHECK_METHOD(sc, y, sc->ADD, args);	  
	  return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), y, A_NUMBER));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER: return(s7_make_complex(sc, real_part(x) + integer(y), imag_part(x)));
	case T_RATIO:   return(s7_make_complex(sc, real_part(x) + fraction(y), imag_part(x)));
	case T_REAL:    return(s7_make_complex(sc, real_part(x) + real(y), imag_part(x)));
	case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->ADD, args);	  
	  return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), y, A_NUMBER));
	}

    default:
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_s1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;

  x = car(args);
  if (type(x) == T_INTEGER)
    return(make_integer(sc, integer(x) + 1));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) + 1));
    case T_RATIO:   return(add_ratios(sc, x, small_int(1)));
    case T_REAL:    return(make_real(sc, real(x) + 1.0));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, list_2(sc, x, small_int(1)));
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_cs1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = finder(sc, car(args));

  if (is_integer(x))
    return(make_integer(sc, integer(x) + 1));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) + 1));
    case T_RATIO:   return(add_ratios(sc, x, small_int(1)));
    case T_REAL:    return(make_real(sc, real(x) + 1.0));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, list_2(sc, x, small_int(1)));
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_1s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;

  x = cadr(args);
  if (is_integer(x))
    return(make_integer(sc, integer(x) + 1));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) + 1));
    case T_RATIO:   return(add_ratios(sc, x, small_int(1)));
    case T_REAL:    return(make_real(sc, real(x) + 1.0));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, list_2(sc, x, small_int(2)));
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int n;

  x = finder(sc, car(args));
  n = integer(cadr(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) + n));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) + n));
    case T_RATIO:   return(add_ratios(sc, x, cadr(args)));
    case T_REAL:    return(make_real(sc, real(x) + n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_is(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int n;

  x = finder(sc, cadr(args));
  n = integer(car(args));
  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) + n));
    case T_RATIO:   return(add_ratios(sc, x, cadr(args)));
    case T_REAL:    return(make_real(sc, real(x) + n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_sf(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double n;

  x = finder(sc, car(args));
  n = real(cadr(args));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) + n));
    case T_RATIO:   return(make_real(sc, fraction(x) + n));
    case T_REAL:    return(make_real(sc, real(x) + n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_add_fs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double n;

  x = finder(sc, cadr(args));
  n = real(car(args));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) + n));
    case T_RATIO:   return(make_real(sc, fraction(x) + n));
    case T_REAL:    return(make_real(sc, real(x) + n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->ADD, args);
      return(wrong_type_argument_with_type(sc, sc->ADD, small_int(2), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer add_f_sf;
static s7_pointer g_add_f_sf(s7_scheme *sc, s7_pointer args)
{
  /* (+ x (* s y)) */
  s7_pointer vargs, s;
  s7_Double x, y;

  x = real(car(args));
  vargs = cdadr(args);
  s = finder(sc, car(vargs));
  y = real(cadr(vargs));

  if (type(s) == T_REAL)
    return(make_real(sc, x + (real(s) * y)));

  switch (type(s))
    {
    case T_INTEGER: return(make_real(sc, x + (integer(s) * y)));
    case T_RATIO:   return(make_real(sc, x + (fraction(s) * y)));
    case T_REAL:    return(make_real(sc, x + real(s) * y));
    case T_COMPLEX: return(s7_make_complex(sc, x + (real_part(s) * y), imag_part(s) * y));
    default:        
      CHECK_METHOD(sc, s, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), s, A_NUMBER));
    }
  return(s);
}


static s7_pointer add_f_sqr;
static s7_pointer g_add_f_sqr(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double y;

  y = real(car(args));
  x = finder(sc, cadr(cadr(args)));
  if (type(x) == T_REAL)
    return(make_real(sc, y + (real(x) * real(x))));

  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, y + (integer(x) * integer(x))));
    case T_RATIO:   return(s7_make_real(sc, y + (fraction(x) * fraction(x))));
    case T_REAL:    return(make_real(sc, y + (real(x) * real(x))));
    case T_COMPLEX: return(s7_make_complex(sc, y + real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MULTIPLY, list_2(sc, x, x));
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
    }
  return(x);
}


static s7_pointer add_ss_1ss;
s7_pointer g_add_ss_1ss(s7_scheme *sc, s7_pointer args);
s7_pointer g_add_ss_1ss(s7_scheme *sc, s7_pointer args)
{
  /* (+ (* s1 s2) (* (- 1.0 s1) s3)) */
  s7_pointer s1, s2, s3;
  s1 = finder(sc, cadr(car(args)));
  s2 = finder(sc, ecdr(args)); /* caddr(car(args))) */
  s3 = finder(sc, fcdr(args)); /* caddr(cadr(args))) */

  if ((type(s1) == T_REAL) &&
      (type(s2) == T_REAL) &&
      (type(s3) == T_REAL))
    return(make_real(sc, (real(s1) * real(s2))  + ((1.0 - real(s1)) * real(s3))));

  if ((is_real(s1)) &&
      (is_real(s2)) &&
      (is_real(s3)))
    return(make_real(sc, (s7_number_to_real(sc, s1) * s7_number_to_real(sc, s2))  + ((1.0 - s7_number_to_real(sc, s1)) * s7_number_to_real(sc, s3))));

  {
    s7_Double r1, r2, r3, rs1, i1, i2, i3, is1;
    r1 = s7_real_part(s1);
    rs1 = 1.0 - r1;
    r2 = s7_real_part(s2);
    r3 = s7_real_part(s3);
    i1 = s7_imag_part(s1);
    is1 = -i1;
    i2 = s7_imag_part(s2);
    i3 = s7_imag_part(s3);
    return(s7_make_complex(sc, 
			   (r1 * r2 - i1 * i2) + (rs1 * r3 - is1 * i3),
			   (r1 * i2 + r2 * i1) + (rs1 * i3 + r3 * is1)));
  }
  /* (let () 
   *   (define (hi a b c) (+ (* a b) (* (- 1.0 a) c))) 
   *   (define (hi1 a b c) (+ (* b a) (* c (- 1 a)))) 
   *   (define (ho a b c) (list (hi a b c) (hi1 a b c)))
   *   (ho 1.4 2.5+i 3.1)) 
   */
}


static s7_pointer g_add_2_temp(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1;
  arg1 = car(args);
  return(s7_remake_real(sc, arg1, real(arg1) + real(cadr(args))));
}


static s7_pointer g_a_s_t(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2, s7_pointer args)
{
  s7_Double y;
  y = real(arg2);
  switch (type(arg1))
    {
    case T_INTEGER: return(s7_remake_real(sc, arg2, integer(arg1) + y));
    case T_RATIO:   return(s7_remake_real(sc, arg2, fraction(arg1) + y));
    case T_REAL:    return(s7_remake_real(sc, arg2, real(arg1) + y));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(arg1) + y, imag_part(arg1)));
    default:       
      CHECK_METHOD(sc, arg1, sc->MULTIPLY, args); 
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), arg1, A_NUMBER));
    }
}


static s7_pointer g_add_s_temp(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;

  arg1 = car(args);
  arg2 = cadr(args);
  if (is_simple_real(arg1))
    return(s7_remake_real(sc, arg2, real(arg1) + real(arg2)));
  
  return(g_a_s_t(sc, arg1, arg2, args));
}


static s7_pointer add_3_temp;
static s7_pointer g_add_3_temp(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1;
  arg1 = car(args);
  return(s7_remake_real(sc, arg1, real(arg1) + real(cadr(args)) + real(caddr(args))));
}


static s7_pointer g_add_s_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;

  arg1 = finder(sc, car(args));
  arg2 = c_call(cadr(args))(sc, cdadr(args));
  if (is_simple_real(arg1))
    return(s7_remake_real(sc, arg2, real(arg1) + real(arg2)));
  
  return(g_a_s_t(sc, arg1, arg2, args));
}


static s7_pointer g_add_temp_s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;

  arg1 = car(args);
  arg2 = cadr(args);
  if (is_simple_real(arg2))
    return(s7_remake_real(sc, arg1, real(arg1) + real(arg2)));
  
  return(g_a_s_t(sc, arg2, arg1, args));
}

static s7_pointer g_add_si_i(s7_scheme *sc, s7_pointer args)
{
  /* (+ (* x n) k) */
  s7_pointer x;
  s7_Int k, n;
  
  x = finder(sc, cadar(args));
  n = integer(caddar(args));
  k = integer(cadr(args));
  if (is_integer(x)) return(make_integer(sc, k + integer(x) * n));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, k + integer(x) * n));
    case T_RATIO:   return(s7_make_ratio(sc, k * denominator(x) + numerator(x) * n, denominator(x)));
    case T_REAL:    return(make_real(sc, k + real(x) * n));
    case T_COMPLEX: return(s7_make_complex(sc, k + real_part(x) * n, imag_part(x) * n));
    default:        return(wrong_type_argument_with_type(sc, sc->ADD, small_int(1), x, A_NUMBER));
    }
  return(x);
}



/* (let () (define (hi a) (+ a 1)) ((apply let '((x 32)) (list (procedure-source hi))) 12))
 */



/* ---------------------------------------- subtract ---------------------------------------- */

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 argument is given"
  s7_pointer x, p;
  s7_Int num_a, den_a;
  s7_Double rl_a, im_a;

  x = car(args);
  p = cdr(args);

#if (!WITH_GMP)
  if (is_null(p))
    {
      if (!is_number(x))
	{
	  CHECK_METHOD(sc, x, sc->MINUS, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->MINUS, x, A_NUMBER));
	}
      return(s7_negate(sc, x));
    }
#endif

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);

    SUBTRACT_INTEGERS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_subtract(sc, cons(sc, s7_Int_to_big_integer(sc, num_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  den_a = num_a - integer(x);
	  if (den_a < 0)
	    {
	      if ((num_a > 0) && (integer(x) < 0))
		{
		  rl_a = (s7_Double)num_a - (s7_Double)integer(x);
		  if (is_null(p)) return(make_real(sc, rl_a));
		  goto SUBTRACT_REALS;
		}
	      /* (- most-positive-fixnum most-negative-fixnum) -> -1 (1.8446744073709551615E19)
	       */
	    }
	  else
	    {
	      if ((num_a < 0) && (integer(x) > 0))
		{
		  rl_a = (s7_Double)num_a - (s7_Double)integer(x);
		  if (is_null(p)) return(make_real(sc, rl_a));
		  goto SUBTRACT_REALS;
		}
	      /* (- most-negative-fixnum most-positive-fixnum) -> 1 (-1.8446744073709551615E19)
	       */
	    }
	  if (is_null(p)) return(make_integer(sc, den_a));
	  num_a = den_a;
	  goto SUBTRACT_INTEGERS;
	  
	case T_RATIO:
	  den_a = denominator(x);
	  if ((integer_length(num_a) + integer_length(den_a) + integer_length(numerator(x))) > s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, num_a - fraction(x)));
	      rl_a = (s7_Double)num_a - fraction(x);
	      goto SUBTRACT_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, (num_a * denominator(x)) - numerator(x), denominator(x)));
	  den_a = denominator(x);
	  num_a = (num_a * denominator(x)) - numerator(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto SUBTRACT_INTEGERS;
	  goto SUBTRACT_RATIOS;
	  
	case T_REAL:
	  if (is_null(p)) return(make_real(sc, num_a - real(x)));
	  rl_a = (s7_Double)num_a - real(x);
	  goto SUBTRACT_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, num_a - real_part(x), -imag_part(x)));
	  rl_a = (s7_Double)num_a - real_part(x);
	  im_a = -imag_part(x);
	  goto SUBTRACT_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MINUS, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MINUS, position_of(p, args) - 1, x, A_NUMBER)); /* p is 1 past the current arg */
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    SUBTRACT_RATIOS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (den_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_subtract(sc, cons(sc, s7_ratio_to_big_ratio(sc, num_a, den_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if ((integer_length(integer(x)) + integer_length(num_a) + integer_length(den_a)) > s7_int_bits) 
	    {
	      if (is_null(p))
		return(make_real(sc, ((long double)num_a / (long double)den_a) - integer(x)));
	      rl_a = ((long double)num_a / (long double)den_a) - integer(x);
	      goto SUBTRACT_REALS;
	    }

	  if (is_null(p)) return(s7_make_ratio(sc, num_a - (den_a * integer(x)), den_a));
	  num_a -= (den_a * integer(x));
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto SUBTRACT_INTEGERS;
	  goto SUBTRACT_RATIOS;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = den_a;
	    n1 = num_a;
	    d2 = denominator(x);
	    n2 = numerator(x);
	    if (d1 == d2)                                     /* the easy case -- if overflow here, it matches the int case */
	      {
		if (is_null(p))
		  return(s7_make_ratio(sc, n1 - n2, d1));
		num_a -= n2;                  /* d1 can't be zero */
	      }
	    else
	      {
#if (!WITH_GMP)
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (is_null(p))
			  return(make_real(sc, ((long double)n1 / (long double)d1) - ((long double)n2 / (long double)d2)));
			rl_a = ((long double)n1 / (long double)d1) - ((long double)n2 / (long double)d2);
			goto SUBTRACT_REALS;
		      }
		  }
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, n1 * d2 - n2 * d1, d1 * d2));
		num_a = n1 * d2 - n2 * d1;
		den_a = d1 * d2;
	      }
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto SUBTRACT_INTEGERS;
	  goto SUBTRACT_RATIOS;
	  }

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, ((long double)num_a / (long double)den_a) - real(x)));
	  rl_a = ((long double)num_a / (long double)den_a) - real(x);
	  goto SUBTRACT_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, ((long double)num_a / (long double)den_a) - real_part(x), -imag_part(x)));
	  rl_a = ((long double)num_a / (long double)den_a) - real_part(x);
	  im_a = -imag_part(x);
	  goto SUBTRACT_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MINUS, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MINUS, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_REAL:
      rl_a = real(x);

    SUBTRACT_REALS:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(make_real(sc, rl_a - integer(x)));
	  rl_a -= (s7_Double)integer(x);
	  goto SUBTRACT_REALS;

	case T_RATIO:
	  if (is_null(p)) return(make_real(sc, rl_a - fraction(x)));
	  rl_a -= (s7_Double)fraction(x);
	  goto SUBTRACT_REALS;

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, rl_a - real(x)));
	  rl_a -= real(x);
	  goto SUBTRACT_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a - real_part(x), -imag_part(x)));
	  rl_a -= real_part(x);
	  im_a = -imag_part(x);
	  goto SUBTRACT_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MINUS, cons(sc, make_real(sc, rl_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MINUS, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_COMPLEX:
      rl_a = real_part(x);
      im_a = imag_part(x);

    SUBTRACT_COMPLEX:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a - integer(x), im_a));
	  rl_a -= (s7_Double)integer(x);
	  goto SUBTRACT_COMPLEX;

	case T_RATIO:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a - fraction(x), im_a));
	  rl_a -= (s7_Double)fraction(x);
	  goto SUBTRACT_COMPLEX;

	case T_REAL:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a - real(x), im_a));
	  rl_a -= real(x);
	  goto SUBTRACT_COMPLEX;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a - real_part(x), im_a - imag_part(x)));
	  rl_a -= real_part(x);
	  im_a -= imag_part(x);
	  if (im_a == 0.0)
	    goto SUBTRACT_REALS;
	  goto SUBTRACT_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MINUS, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MINUS, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
}


static s7_pointer subtract_1, subtract_s1, subtract_cs1, subtract_2, subtract_csn, subtract_ran;

static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER: 
#if WITH_GMP
      if (integer(p) == S7_LLONG_MIN)
	return(big_negate(sc, list_1(sc, promote_number(sc, T_BIG_INTEGER, p))));
#endif	
      return(make_integer(sc, -integer(p)));
      
    case T_RATIO:
      return(s7_make_ratio(sc, -numerator(p), denominator(p)));
      
    case T_REAL:
      return(make_real(sc, -real(p)));
      
    case T_COMPLEX:
      return(s7_make_complex(sc, -real_part(p), -imag_part(p)));

    default:
      CHECK_METHOD(sc, p, sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), car(args), A_NUMBER));
    }
}

static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

  if (type(x) == type(y))
    {
      if (type(x) == T_REAL)
	return(make_real(sc, real(x) - real(y)));
      else
	{
	  switch (type(x))
	    {
	    case T_INTEGER: return(make_integer(sc, integer(x) - integer(y)));
	    case T_RATIO:   return(g_subtract(sc, args));
	    case T_REAL:    return(make_real(sc, real(x) - real(y)));
	    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
	    default: 
	      if (!is_number(x))
		{
		  CHECK_METHOD(sc, x, sc->MINUS, args);
		  return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
		}
	      CHECK_METHOD(sc, y, sc->MINUS, args);	  
	      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), y, A_NUMBER));
	    }
	}
    }

  switch (type(x))
    {
    case T_INTEGER: 
      switch (type(y))
	{
	case T_INTEGER: return(make_integer(sc, integer(x) - integer(y)));
	case T_RATIO:   return(g_subtract(sc, args));
	case T_REAL:    return(make_real(sc, integer(x) - real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, integer(x) - real_part(y), -imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MINUS, args);
	  return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), y, A_NUMBER));
	}
      
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	case T_RATIO:   return(g_subtract(sc, args));
	case T_REAL:    return(make_real(sc, fraction(x) - real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, fraction(x) - real_part(y), -imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MINUS, args);
	  return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), y, A_NUMBER));
	}
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(make_real(sc, real(x) - integer(y)));
	case T_RATIO:   return(make_real(sc, real(x) - fraction(y)));
	case T_REAL:    return(make_real(sc, real(x) - real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, real(x) - real_part(y), -imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MINUS, args);
	  return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), y, A_NUMBER));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER: return(s7_make_complex(sc, real_part(x) - integer(y), imag_part(x)));
	case T_RATIO:   return(s7_make_complex(sc, real_part(x) - fraction(y), imag_part(x)));
	case T_REAL:    return(s7_make_complex(sc, real_part(x) - real(y), imag_part(x)));
	case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MINUS, args);
	  return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), y, A_NUMBER));
	}

    default:
      CHECK_METHOD(sc, x, sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
  return(x);
}


static s7_pointer g_subtract_cs1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = finder(sc, car(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) - 1));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) - 1));
    case T_RATIO:   return(subtract_ratios(sc, x, small_int(1)));
    case T_REAL:    return(make_real(sc, real(x) - 1.0));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - 1.0, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MINUS, list_2(sc, x, small_int(1)));
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_subtract_s1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = car(args);
  /* this one seems to hit reals as often as integers */
  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) - 1));
    case T_RATIO:   return(subtract_ratios(sc, x, small_int(1)));
    case T_REAL:    return(make_real(sc, real(x) - 1.0));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - 1.0, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MINUS, list_2(sc, x, small_int(1)));
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_subtract_csn(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int n;

  x = finder(sc, car(args));
  n = s7_integer(cadr(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) - n));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) - n));
    case T_RATIO:   return(subtract_ratios(sc, x, cadr(args)));
    case T_REAL:    return(make_real(sc, real(x) - n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MINUS, list_2(sc, x, cadr(args)));
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static double next_random(s7_rng_t *r);
static s7_pointer g_subtract_ran(s7_scheme *sc, s7_pointer args)
{
  s7_Double x, y;
  x = real(cadr(args));
  y = real(cadr(car(args)));
  return(make_real(sc, (y * next_random(sc->default_rng)) - x));
}

static s7_pointer subtract_sf;
static s7_pointer g_subtract_sf(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double n;

  x = finder(sc, car(args));
  n = real(cadr(args));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) - n));
    case T_RATIO:   return(make_real(sc, fraction(x) - n));
    case T_REAL:    return(make_real(sc, real(x) - n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer subtract_fs;
static s7_pointer g_subtract_fs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double n;

  x = finder(sc, cadr(args));
  n = real(car(args));
  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, n - integer(x)));
    case T_RATIO:   return(make_real(sc, n - fraction(x)));
    case T_REAL:    return(make_real(sc, n - real(x)));
    case T_COMPLEX: return(s7_make_complex(sc, n - real_part(x), -imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(2), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer subtract_sf_f;
static s7_pointer g_subtract_sf_f(s7_scheme *sc, s7_pointer args)
{
  /* (- (* s y) x) */
  s7_pointer vargs, s;
  s7_Double x, y;

  x = real(cadr(args));
  vargs = cdar(args);
  s = finder(sc, car(vargs));
  y = real(cadr(vargs));

  if (type(s) == T_REAL)
    return(make_real(sc, (real(s) * y) - x));

  switch (type(s))
    {
    case T_INTEGER: return(make_real(sc, (integer(s) * y) - x));
    case T_RATIO:   return(make_real(sc, (fraction(s) * y) - x));
    case T_REAL:    return(make_real(sc, (real(s) * y) - x));
    case T_COMPLEX: return(s7_make_complex(sc, (real_part(s) * y) - x, imag_part(s) * y));
    default:        
      CHECK_METHOD(sc, s, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), s, A_NUMBER));
    }
  return(s);
}





/* ---------------------------------------- multiply ---------------------------------------- */

static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
{
  #define H_multiply "(* ...) multiplies its arguments"
  s7_pointer x, p;
  s7_Int num_a, den_a;
  s7_Double rl_a, im_a;

#if (!WITH_GMP)
  if (is_null(args))
    return(small_int(1));
#endif
    
  x = car(args);
  p = cdr(args);
  if (is_null(p))
    {
      if (!is_number(x))
	{
	  CHECK_METHOD(sc, x, sc->MULTIPLY, args);	  
	  return(simple_wrong_type_argument_with_type(sc, sc->MULTIPLY, x, A_NUMBER));
	}
      return(x);
    }

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);

    MULTIPLY_INTEGERS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_multiply(sc, cons(sc, s7_Int_to_big_integer(sc, num_a), p)));
#endif
      x = car(p);
      p = cdr(p);
      switch (type(x))
	{
	case T_INTEGER:
#if WITH_GMP
	  if ((integer(x) > S7_LONG_MAX) ||
	      (integer(x) < S7_LONG_MIN))
	    return(big_multiply(sc, cons(sc, s7_Int_to_big_integer(sc, num_a), cons(sc, x, p))));
#endif

	  /* perhaps put all the math-safety stuff on the *safety* switch?
	   *    (* 256 17179869184 4194304) -> 0 which is annoying
	   *    (* 134217728 137438953472) -> 0
	   */
	  if ((integer_length(num_a) + integer_length(integer(x))) >= s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, (s7_Double)num_a * (s7_Double)integer(x)));
	      rl_a = (s7_Double)num_a * (s7_Double)integer(x);
	      goto MULTIPLY_REALS;
	    }
	  if (is_null(p)) return(make_integer(sc, num_a * integer(x)));
	  num_a *= integer(x);
	  goto MULTIPLY_INTEGERS;

	case T_RATIO:
	  if ((integer_length(num_a) + integer_length(numerator(x))) >= s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, (s7_Double)num_a * fraction(x)));
	      rl_a = (s7_Double)num_a * fraction(x);
	      goto MULTIPLY_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, numerator(x) * num_a, denominator(x)));
	  den_a = denominator(x);
	  num_a *= numerator(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto MULTIPLY_INTEGERS;
	  goto MULTIPLY_RATIOS;
	  
	case T_REAL:
	  if (is_null(p)) return(make_real(sc, num_a * real(x)));
	  rl_a = num_a * real(x);
	  goto MULTIPLY_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, num_a * real_part(x), num_a * imag_part(x)));
	  rl_a = num_a * real_part(x);
	  im_a = num_a * imag_part(x);
	  goto MULTIPLY_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MULTIPLY, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MULTIPLY, position_of(p, args) - 1, x, A_NUMBER)); /* p is 1 past the current arg */
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    MULTIPLY_RATIOS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (den_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_multiply(sc, cons(sc, s7_ratio_to_big_ratio(sc, num_a, den_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  /* as in +, this can overflow:
	   *   (* 8 -9223372036854775807 8) -> 64
	   *   (* 3/4 -9223372036854775807 8) -> 6
	   *   (* 8 -9223372036854775808 8) -> 0
	   *   (* -1 9223372036854775806 8) -> 16
	   *   (* -9223372036854775808 8 1e+308) -> 0.0
	   */
	  if ((integer_length(num_a) + integer_length(integer(x))) >= s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, ((s7_Double)integer(x) / (s7_Double)den_a) * (s7_Double)num_a));
	      rl_a = ((s7_Double)integer(x) / (s7_Double)den_a) * (s7_Double)num_a;
	      goto MULTIPLY_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, num_a * integer(x), den_a));
	  num_a *= integer(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto MULTIPLY_INTEGERS;
	  goto MULTIPLY_RATIOS;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = den_a;
	    n1 = num_a;
	    d2 = denominator(x);
	    n2 = numerator(x);
#if (!WITH_GMP)
	    if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		(n1 > s7_int_max) || (n2 > s7_int_max) ||     /*    (* 1/524288 1/19073486328125) for example */
		(n1 < s7_int_min) || (n2 < s7_int_min))
	      {
		if ((integer_length(d1) + integer_length(d2) > s7_int_bits) ||
		    (integer_length(n1) + integer_length(n2) > s7_int_bits))
		  {
		    if (is_null(p))
		      return(make_real(sc, ((long double)n1 / (long double)d1) * ((long double)n2 / (long double)d2)));
		    rl_a = ((long double)n1 / (long double)d1) * ((long double)n2 / (long double)d2);
		    goto MULTIPLY_REALS;
		  }
	      }
#endif
	    if (is_null(p)) return(s7_make_ratio(sc, n1 * n2, d1 * d2));
	    num_a *= n2;
	    den_a *= d2;
	    if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	      goto MULTIPLY_INTEGERS;
	    goto MULTIPLY_RATIOS;
	  }

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, ((long double)num_a / (long double)den_a) * real(x)));
	  rl_a = ((long double)num_a / (long double)den_a) * real(x);
	  goto MULTIPLY_REALS;
	  
	case T_COMPLEX:
	  {
	    s7_Double frac;
	    frac = ((long double)num_a / (long double)den_a);
	    if (is_null(p)) return(s7_make_complex(sc, frac * real_part(x), frac * imag_part(x)));
	    rl_a = frac * real_part(x);
	    im_a = frac * imag_part(x);
	    goto MULTIPLY_COMPLEX;
	  }
	  
	default:
	  CHECK_METHOD(sc, x, sc->MULTIPLY, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MULTIPLY, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_REAL:
      rl_a = real(x);

    MULTIPLY_REALS:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(make_real(sc, rl_a * integer(x)));
	  rl_a *= integer(x);
	  goto MULTIPLY_REALS;

	case T_RATIO:
	  if (is_null(p)) return(make_real(sc, rl_a * fraction(x)));
	  rl_a *= (s7_Double)fraction(x);
	  goto MULTIPLY_REALS;

	case T_REAL:
	  if (is_null(p)) return(make_real(sc, rl_a * real(x)));
	  rl_a *= real(x);
	  goto MULTIPLY_REALS;
	  
	case T_COMPLEX:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a * real_part(x), rl_a * imag_part(x)));
	  im_a = rl_a * imag_part(x);
	  rl_a *= real_part(x);
	  goto MULTIPLY_COMPLEX;
	  
	default:
	  CHECK_METHOD(sc, x, sc->MULTIPLY, cons(sc, make_real(sc, rl_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MULTIPLY, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_COMPLEX:
      rl_a = real_part(x);
      im_a = imag_part(x);

    MULTIPLY_COMPLEX:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a * integer(x), im_a * integer(x)));
	  rl_a *= integer(x);
	  im_a *= integer(x);
	  goto MULTIPLY_COMPLEX;

	case T_RATIO:
	  {
	    s7_Double frac;
	    frac = fraction(x);
	    if (is_null(p)) return(s7_make_complex(sc, rl_a * frac, im_a * frac));
	    rl_a *= frac;
	    im_a *= frac;
	    goto MULTIPLY_COMPLEX;
	  }

	case T_REAL:
	  if (is_null(p)) return(s7_make_complex(sc, rl_a * real(x), im_a * real(x)));
	  rl_a *= real(x);
	  im_a *= real(x);
	  goto MULTIPLY_COMPLEX;
	  
	case T_COMPLEX:
	  {
	    s7_Double r1, r2, i1, i2;
	    r1 = rl_a;
	    i1 = im_a;
	    r2 = real_part(x);
	    i2 = imag_part(x);
	    if (is_null(p))
	      return(s7_make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
	    rl_a = r1 * r2 - i1 * i2;
	    im_a = r1 * i2 + r2 * i1;
	    if (im_a == 0.0)
	      goto MULTIPLY_REALS;
	    goto MULTIPLY_COMPLEX;
	  }

	default:
	  CHECK_METHOD(sc, x, sc->MULTIPLY, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->MULTIPLY, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
    }
}


static s7_pointer multiply_2, multiply_fs, multiply_sf, multiply_is, multiply_si;
static s7_pointer multiply_2_temp, multiply_3_temp, multiply_1_any, multiply_s_temp, multiply_temp_s, multiply_s_direct;
static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

  if (type(x) == type(y))
    {
      if (type(x) == T_REAL)
	return(make_real(sc, real(x) * real(y)));
      else
	{
	  switch (type(x))
	    {
	    case T_INTEGER: return(make_integer(sc, integer(x) * integer(y)));
	    case T_RATIO:   return(g_multiply(sc, args));
	    case T_REAL:    return(make_real(sc, real(x) * real(y)));
	    case T_COMPLEX: 
	      {
		s7_Double r1, r2, i1, i2;
		r1 = real_part(x);
		r2 = real_part(y);
		i1 = imag_part(x);
		i2 = imag_part(y);
		return(s7_make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
	      }
	    default: 
	      if (!is_number(x))
		{
		  CHECK_METHOD(sc, x, sc->MULTIPLY, args);
		  return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
		}
	      CHECK_METHOD(sc, y, sc->MULTIPLY, args);	  
	      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), y, A_NUMBER));
	    }
	}
    }

  switch (type(x))
    {
    case T_INTEGER: 
      switch (type(y))
	{
	case T_INTEGER: return(make_integer(sc, integer(x) * integer(y)));
	case T_RATIO:   return(g_multiply(sc, args));
	case T_REAL:    return(make_real(sc, integer(x) * real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, integer(x) * real_part(y), integer(x) * imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MULTIPLY, args);
	  return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), y, A_NUMBER));
	}
      
    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	case T_RATIO:    return(g_multiply(sc, args));
	case T_REAL:     return(make_real(sc, fraction(x) * real(y)));
	case T_COMPLEX:  
	  {
	    s7_Double frac;
	    frac = fraction(x);
	    return(s7_make_complex(sc, frac * real_part(y), frac * imag_part(y)));
	  }
	default:        
	  CHECK_METHOD(sc, y, sc->MULTIPLY, args);
	  return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), y, A_NUMBER));
	}
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: return(make_real(sc, real(x) * integer(y)));
	case T_RATIO:   return(make_real(sc, real(x) * fraction(y)));
	case T_REAL:    return(make_real(sc, real(x) * real(y)));
	case T_COMPLEX: return(s7_make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y)));
	default:        
	  CHECK_METHOD(sc, y, sc->MULTIPLY, args);
	  return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), y, A_NUMBER));
	}

    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER: return(s7_make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y)));
	case T_RATIO:   
	  {
	    s7_Double frac;
	    frac = fraction(y);
	    return(s7_make_complex(sc, real_part(x) * frac, imag_part(x) * frac));
	  }
	case T_REAL:    return(s7_make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y)));
	case T_COMPLEX:
	  {
	    s7_Double r1, r2, i1, i2;
	    r1 = real_part(x);
	    r2 = real_part(y);
	    i1 = imag_part(x);
	    i2 = imag_part(y);
	    return(s7_make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
	  }
	default:        
	  CHECK_METHOD(sc, y, sc->MULTIPLY, args);
	  return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), y, A_NUMBER));
	}

    default:
      CHECK_METHOD(sc, y, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));      
    }
  return(x);
}

s7_pointer s7_multiply_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  car(sc->T2_1) = x;
  car(sc->T2_2) = y;
  return(g_multiply_2(sc, sc->T2_1));
}


static s7_pointer g_multiply_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int n;

  x = finder(sc, car(args));
  n = integer(cadr(args));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) * n));
    case T_RATIO:   return(s7_make_ratio(sc, numerator(x) * n, denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
    default:        
      CHECK_METHOD(sc, x, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_multiply_is(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Int n;

  x = finder(sc, cadr(args));
  n = integer(car(args));

  switch (type(x))
    {
    case T_INTEGER: return(make_integer(sc, integer(x) * n));
    case T_RATIO:   return(s7_make_ratio(sc, numerator(x) * n, denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * n));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
    default:        
      CHECK_METHOD(sc, x, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_multiply_fs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double scl;

  scl = real(car(args));
  x = finder(sc, cadr(args));

  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) * scl));
    case T_RATIO:   return(make_real(sc, numerator(x) * scl / denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * scl));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * scl, imag_part(x) * scl));
    default:        
      CHECK_METHOD(sc, x, sc->MULTIPLY, args);
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer g_multiply_sf(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_Double scl;

  scl = real(cadr(args));
  x = finder(sc, car(args));

  switch (type(x))
    {
    case T_INTEGER: return(make_real(sc, integer(x) * scl));
    case T_RATIO:   return(make_real(sc, numerator(x) * scl / denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * scl));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * scl, imag_part(x) * scl));
    default:       
      CHECK_METHOD(sc, x, sc->MULTIPLY, args); 
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(2), x, A_NUMBER));
    }
  return(x);
}


static s7_pointer g_multiply_2_temp(s7_scheme *sc, s7_pointer args)
{
  /* not obvious that the free here saves any time -- conflicting stats in callgrind
   */
  s7_pointer arg1;
  arg1 = car(args);
  return(s7_remake_real(sc, arg1, real(arg1) * real(cadr(args))));
}


static s7_pointer g_multiply_3_temp(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1;
  arg1 = car(args);
  return(s7_remake_real(sc, arg1, real(arg1) * real(cadr(args)) * real(caddr(args))));
}


static s7_pointer g_m_s_t(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2, s7_pointer args)
{
  s7_Double y;
  y = real(arg2);
  switch (type(arg1))
    {
    case T_INTEGER: return(s7_remake_real(sc, arg2, integer(arg1) * y));
    case T_RATIO:   return(s7_remake_real(sc, arg2, numerator(arg1) * y / denominator(arg1)));
    case T_REAL:    return(s7_remake_real(sc, arg2, real(arg1) * y));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(arg1) * y, imag_part(arg1) * y));
    default:       
      CHECK_METHOD(sc, arg1, sc->MULTIPLY, args); 
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), arg1, A_NUMBER));
    }
}


s7_pointer g_multiply_s_direct(s7_scheme *sc, s7_pointer args);
s7_pointer g_multiply_s_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;

  arg1 = finder(sc, car(args));
  arg2 = c_call(cadr(args))(sc, cdadr(args));
  if (is_simple_real(arg1))
    return(s7_remake_real(sc, arg2, real(arg1) * real(arg2)));
  
  return(g_m_s_t(sc, arg1, arg2, args));
}


static s7_pointer g_multiply_s_temp(s7_scheme *sc, s7_pointer args)
{
  /* not obvious that the free here saves any time -- conflicting stats in callgrind
   */
  s7_pointer arg1, arg2;

  arg1 = car(args);
  arg2 = cadr(args);
  if (is_simple_real(arg1))
    return(s7_remake_real(sc, arg2, real(arg1) * real(arg2)));
  
  return(g_m_s_t(sc, arg1, arg2, args));
}


static s7_pointer g_multiply_1_any(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;
  s7_Double product;
  arg1 = car(args);
  product = real(arg1);
  for (arg2 = cdr(args); is_pair(arg2); arg2 = cdr(arg2))
    {
      if (type(car(arg2)) == T_REAL)
	product *= real(car(arg2));
      else
	{
	  arg2 = g_multiply(sc, arg2);
	  if (is_simple_real(arg2))
	    return(s7_remake_real(sc, arg1, product * real(arg2)));
	  real(arg1) = product;
	  return(g_m_s_t(sc, arg2, arg1, args));
	}
    }
  return(s7_remake_real(sc, arg1, product));
}


static s7_pointer g_multiply_temp_s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer arg1, arg2;

  arg1 = car(args);
  arg2 = cadr(args);
  if (is_simple_real(arg2))
    return(s7_remake_real(sc, arg1, real(arg1) * real(arg2)));
  
  return(g_m_s_t(sc, arg2, arg1, args));
}


#if (!WITH_GMP)
static s7_pointer sqr_ss;
static s7_pointer g_sqr_ss(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = finder(sc, car(args));

  switch (type(x))
    {
    case T_INTEGER: return(s7_make_integer(sc, integer(x) * integer(x)));
    case T_RATIO:   return(s7_make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x)));
    case T_REAL:    return(make_real(sc, real(x) * real(x)));
    case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
    default:        
      CHECK_METHOD(sc, x, sc->MULTIPLY, list_2(sc, x, x));
      return(wrong_type_argument_with_type(sc, sc->MULTIPLY, small_int(1), x, A_NUMBER));
    }
  return(x);
}

static s7_pointer mul_1ss;
static s7_pointer g_mul_1ss(s7_scheme *sc, s7_pointer args)
{
  /* (* (- 1.0 x) y) */
  s7_pointer x, y;

  x = finder(sc, caddr(car(args)));
  y = finder(sc, cadr(args));

  if ((type(x) == T_REAL) &&
      (type(y) == T_REAL))
    return(make_real(sc, real(y) * (1.0 - real(x))));

  if ((is_real(x)) &&
      (is_real(y)))
    return(make_real(sc, s7_number_to_real(sc, y) * (1.0 - s7_number_to_real(sc, x))));
  else
    {
      s7_Double r1, r2, i1, i2;
      r1 = 1.0 - s7_real_part(x);
      r2 = s7_real_part(y);
      i1 = -s7_imag_part(x);
      i2 = s7_imag_part(y);
      return(s7_make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
    }
}

static s7_pointer multiply_cs_cos;
static s7_pointer g_multiply_cs_cos(s7_scheme *sc, s7_pointer args)
{
  /* ([*] -2.0 r (cos x)) */
  s7_pointer r, x;
  
  r = finder(sc, cadr(args));
  x = finder(sc, cadr(caddr(args)));

  if ((type(r) == T_REAL) &&
      (type(x) == T_REAL))
    return(make_real(sc, real(car(args)) * real(r) * cos(real(x))));

  if ((is_real(r)) &&
      (is_real(x)))
    return(make_real(sc, real(car(args)) * s7_number_to_real(sc, r) * cos(s7_number_to_real(sc, x))));
  return(g_multiply(sc, list_3(sc, car(args), r, g_cos(sc, list_1(sc, x)))));
}
#endif




/* ---------------------------------------- divide ---------------------------------------- */

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"
  s7_pointer x, p;
  s7_Int num_a, den_a;
  s7_Double rl_a, im_a;

  x = car(args);
  p = cdr(args);
  if (is_null(p))
    {
      if (!is_number(x))
	{
	  CHECK_METHOD(sc, x, sc->DIVIDE, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->DIVIDE, x, A_NUMBER));
	}
      if (s7_is_zero(x))
	return(division_by_zero_error(sc, sc->DIVIDE, args));
      return(s7_invert(sc, x));
    }

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);
      if (num_a == 0)
	{
	  bool return_nan = false, return_real_zero = false;
	  for (; is_pair(p); p = cdr(p))
	    {
	      if (!is_number(car(p)))
		{
		  CHECK_METHOD(sc, car(p), sc->DIVIDE, args);
		  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args), car(p), A_NUMBER));
		}
	      if (s7_is_zero(car(p)))
		return(division_by_zero_error(sc, sc->DIVIDE, args));
	      if (type(car(p)) > T_RATIO)
		{
		  return_real_zero = true;		  
		  if (is_NaN(real(car(p))))
		    return_nan = true;
		}
	    }
	  if (return_nan)
	    return(real_NaN);
	  if (return_real_zero)
	    return(real_zero);
	  return(small_int(0));
	}

    DIVIDE_INTEGERS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_divide(sc, cons(sc, s7_Int_to_big_integer(sc, num_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == 0)
	    return(division_by_zero_error(sc, sc->DIVIDE, args));

	  /* to be consistent, I suppose we should search first for NaNs in the divisor list.
	   *   (* 0 0/0) is NaN, so (/ 1 0 0/0) should equal (/ 1 0/0) = NaN.  But the whole
	   *   thing is ridiculous.
	   */
	  if (is_null(p)) 
	    return(s7_make_ratio(sc, num_a, integer(x)));

	  den_a = integer(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto DIVIDE_INTEGERS;
	  goto DIVIDE_RATIOS;
	  
	case T_RATIO:
	  den_a = denominator(x);
	  if ((integer_length(num_a) + integer_length(den_a)) > s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, num_a * inverted_fraction(x)));
	      rl_a = (s7_Double)num_a * inverted_fraction(x);
	      goto DIVIDE_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, num_a * denominator(x), numerator(x)));
	  den_a = numerator(x);
	  num_a *= denominator(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto DIVIDE_INTEGERS;
	  goto DIVIDE_RATIOS;
	  
	case T_REAL:
	  rl_a = (s7_Double)num_a;
	  if (real(x) == 0.0)
	    return(division_by_zero_error(sc, sc->DIVIDE, args));
	  if (is_null(p)) return(make_real(sc, rl_a / real(x)));
	  rl_a /= real(x);
	  goto DIVIDE_REALS;
	  
	case T_COMPLEX:
	  {
	    s7_Double i2, r2, den;
	    rl_a = (s7_Double)num_a;
	    r2 = real_part(x);
	    i2 = imag_part(x);
	    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) 
	     */
	    if (is_null(p))
	      return(s7_make_complex(sc, rl_a * r2 * den, -(rl_a * i2 * den)));
	    im_a = -rl_a * i2 * den;
	    rl_a *= r2 * den;
	    goto DIVIDE_COMPLEX;
	  }

	default:
	  CHECK_METHOD(sc, x, sc->DIVIDE, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args) - 1, x, A_NUMBER)); /* p is 1 past the current arg */
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    DIVIDE_RATIOS:
#if WITH_GMP
      if ((num_a > S7_LONG_MAX) ||
	  (den_a > S7_LONG_MAX) ||
	  (num_a < S7_LONG_MIN))
	return(big_divide(sc, cons(sc, s7_ratio_to_big_ratio(sc, num_a, den_a), p)));
#endif
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == 0)
	    return(division_by_zero_error(sc, sc->DIVIDE, args));

	  if ((integer_length(integer(x)) + integer_length(den_a)) > s7_int_bits)
	    {
	      if (is_null(p))
		return(make_real(sc, (long double)num_a / ((long double)den_a * (s7_Double)integer(x))));
	      rl_a = (long double)num_a / ((long double)den_a * (s7_Double)integer(x));
	      goto DIVIDE_REALS;
	    }
	  if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a * integer(x)));
	  den_a *= integer(x);
	  if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	    goto DIVIDE_INTEGERS;
	  goto DIVIDE_RATIOS;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = den_a;
	    n1 = num_a;
	    d2 = denominator(x);
	    n2 = numerator(x);
	    if (d1 == d2)  
	      {
		if (is_null(p))
		  return(s7_make_ratio(sc, n1, n2));
		den_a = n2;
	      }
	    else
	      {
#if (!WITH_GMP)
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    if ((integer_length(d1) + integer_length(n2) > s7_int_bits) ||
			(integer_length(d2) + integer_length(n1) > s7_int_bits))
		      {
			s7_Double r1, r2;
			r1 = ((long double)num_a / (long double)den_a);
			r2 = inverted_fraction(x);
			if (is_null(p))
			  return(make_real(sc, r1 * r2));
			rl_a = r1 * r2;
			goto DIVIDE_REALS;
		      }
		  }
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, n1 * d2, d1 * n2));
		num_a *= d2;
		den_a *= n2;
	      }
	    if (reduce_fraction(&num_a, &den_a) == T_INTEGER)
	      goto DIVIDE_INTEGERS;
	    goto DIVIDE_RATIOS;
	  }

	case T_REAL:
	  {
	    s7_Double r1;
	    if (real(x) == 0.0)
	      return(division_by_zero_error(sc, sc->DIVIDE, args));
	    r1 = ((long double)num_a / (long double)den_a);
	    if (is_null(p)) return(make_real(sc, r1 / real(x)));
	    rl_a = r1 / real(x);
	    goto DIVIDE_REALS;
	  }
	  
	case T_COMPLEX:
	  {
	    s7_Double den, i2, r2;
	    rl_a = ((long double)num_a / (long double)den_a);
	    r2 = real_part(x);
	    i2 = imag_part(x);
	    den = 1.0 / (r2 * r2 + i2 * i2);
	    if (is_null(p))
	      return(s7_make_complex(sc, rl_a * r2 * den, -rl_a * i2 * den));
	    im_a = -rl_a * i2 * den;
	    rl_a *= r2 * den;
	    goto DIVIDE_COMPLEX;
	  }
	  
	default:
	  CHECK_METHOD(sc, x, sc->DIVIDE, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_REAL:
      rl_a = real(x);
      if (rl_a == 0)
	{
	  bool return_nan = false;
	  for (; is_pair(p); p = cdr(p))
	    {
	      if (!is_number(car(p)))
		{
		  CHECK_METHOD(sc, car(p), sc->DIVIDE, args);
		  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args), car(p), A_NUMBER));
		}
	      if (s7_is_zero(car(p)))
		return(division_by_zero_error(sc, sc->DIVIDE, args));
	      if ((type(car(p)) == T_REAL) && 
		  (is_NaN(real(car(p)))))
		return_nan = true;
	    }
	  if (return_nan)
	    return(real_NaN);
	  return(real_zero);
	}

    DIVIDE_REALS:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == 0)
	    return(division_by_zero_error(sc, sc->DIVIDE, args));
	  if (is_null(p)) return(make_real(sc, rl_a / integer(x)));
	  rl_a /= (s7_Double)integer(x);
	  goto DIVIDE_REALS;

	case T_RATIO:
	  if (is_null(p)) return(make_real(sc, rl_a * inverted_fraction(x)));
	  rl_a *= (s7_Double)inverted_fraction(x);
	  goto DIVIDE_REALS;

	case T_REAL:
	  if (real(x) == 0.0)
	    return(division_by_zero_error(sc, sc->DIVIDE, args));
	  if (is_null(p)) return(make_real(sc, rl_a / real(x)));
	  rl_a /= real(x);
	  goto DIVIDE_REALS;
	  
	case T_COMPLEX:
	  {
	    s7_Double den, r2, i2;
	    r2 = real_part(x);
	    i2 = imag_part(x);
	    den = 1.0 / (r2 * r2 + i2 * i2);
	    if (is_null(p))
	      return(s7_make_complex(sc, rl_a * r2 * den, -rl_a * i2 * den));
	    im_a = -rl_a * i2 * den;
	    rl_a *= r2 * den;
	    goto DIVIDE_COMPLEX;
	  }
	  
	default:
	  CHECK_METHOD(sc, x, sc->DIVIDE, cons(sc, make_real(sc, rl_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    case T_COMPLEX:
      rl_a = real_part(x);
      im_a = imag_part(x);

    DIVIDE_COMPLEX:
      x = car(p);
      p = cdr(p);

      switch (type(x))
	{
	case T_INTEGER:
	  {
	    s7_Double r1;
	    if (integer(x) == 0)
	      return(division_by_zero_error(sc, sc->DIVIDE, args));
	    r1 = 1.0 / (s7_Double)integer(x);
	    if (is_null(p)) return(s7_make_complex(sc, rl_a * r1, im_a * r1));
	    rl_a *= r1;
	    im_a *= r1;
	    goto DIVIDE_COMPLEX;
	  }

	case T_RATIO:
	  {
	    s7_Double frac;
	    frac = inverted_fraction(x);
	    if (is_null(p)) return(s7_make_complex(sc, rl_a * frac, im_a * frac));
	    rl_a *= frac;
	    im_a *= frac;
	    goto DIVIDE_COMPLEX;
	  }

	case T_REAL:
	  {
	    s7_Double r1;
	    if (real(x) == 0.0)
	      return(division_by_zero_error(sc, sc->DIVIDE, args));
	    r1 = 1.0 / real(x);
	    if (is_null(p)) return(s7_make_complex(sc, rl_a * r1, im_a * r1));
	    rl_a *= r1;
	    im_a *= r1;
	    goto DIVIDE_COMPLEX;
	  }

	case T_COMPLEX:
	  {
	    s7_Double r1, r2, i1, i2, den;
	    r1 = rl_a;
	    i1 = im_a;
	    r2 = real_part(x);
	    i2 = imag_part(x);
	    den = 1.0 / (r2 * r2 + i2 * i2);
	    if (is_null(p))
	      return(s7_make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den));
	    rl_a = (r1 * r2 + i1 * i2) * den;
	    im_a = (r2 * i1 - r1 * i2) * den;
	    goto DIVIDE_COMPLEX;
	  }
	  
	default:
	  CHECK_METHOD(sc, x, sc->DIVIDE, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)));
	  return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(p, args) - 1, x, A_NUMBER));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->DIVIDE, args);
      return(wrong_type_argument_with_type(sc, sc->DIVIDE, small_int(1), x, A_NUMBER));
    }
}


#if (!WITH_GMP)
static s7_pointer divide_1;
static s7_pointer g_divide_1(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_zero(cadr(args)))
    return(division_by_zero_error(sc, sc->DIVIDE, args));
  return(s7_invert(sc, cadr(args)));
}


static s7_pointer divide_1r;
static s7_pointer g_divide_1r(s7_scheme *sc, s7_pointer args)
{
  s7_Double rl;
  if (s7_is_real(cadr(args)))
    {
      rl = s7_number_to_real(sc, cadr(args));
      if (rl == 0.0)
	return(division_by_zero_error(sc, sc->DIVIDE, args));
      return(make_real(sc, 1.0 / rl));
    }
  return(g_divide(sc, args));
}
#endif




/* ---------------------------------------- max/min ---------------------------------------- */

static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
  #define H_max "(max ...) returns the maximum of its arguments"

  s7_pointer x, y, p;
  s7_Int num_a, num_b, den_a, den_b;

  x = car(args);
  p = cdr(args);
  
  switch (type(x))
    {
    case T_INTEGER:
    MAX_INTEGERS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER: 
	  if (integer(x) < integer(y)) x = y;
	  goto MAX_INTEGERS;

	case T_RATIO:
	  num_a = integer(x);
	  den_a = 1;
	  num_b = numerator(y);
	  den_b = denominator(y);
	  goto RATIO_MAX_RATIO;
	  
	case T_REAL:    
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real(car(p)))
		  {
		    CHECK_METHOD(sc, car(p), sc->MAX, args);
		    return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
		  }
	      return(y);
	    }
	  if (integer(x) < real(y)) 
	    {
	      x = y; 
	      goto MAX_REALS;
	    }
	  goto MAX_INTEGERS;

	default:        
	  CHECK_METHOD(sc, y, sc->MAX, args);
	  return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    MAX_RATIOS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER:
	  num_a = numerator(x);
	  den_a = denominator(x);
	  num_b = integer(y);
	  den_b = 1;
	  goto RATIO_MAX_RATIO;
	  
	case T_RATIO:
	  num_a = numerator(x);
	  den_a = denominator(x);
	  num_b = numerator(y);
	  den_b = denominator(y);
	  
	RATIO_MAX_RATIO:
	  /* there are tricky cases here where long ints outrun doubles:
	   *   (max 92233720368547758/9223372036854775807 92233720368547757/9223372036854775807)
	   * which should be 92233720368547758/9223372036854775807) but first the fraction gets reduced
	   * to 13176245766935394/1317624576693539401, so we fall into the double comparison, and
	   * there we should be comparing 
	   *    9.999999999999999992410584792601468961145E-3 and
	   *    9.999999999999999883990367544051025548645E-3
	   * but if using doubles we get 
	   *    0.010000000000000000208166817117 and
	   *    0.010000000000000000208166817117
	   * that is, we can't distinguish these two fractions once they're coerced to doubles.
	   *
	   * Even long doubles fail in innocuous-looking cases:
	   *     (min 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
	   *     (max 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
	   *
	   * Another consequence: outside gmp, we can't handle cases like
	   *    (max 9223372036854776/9223372036854775807 #i9223372036854775/9223372036854775000)
	   *    (max #i9223372036854776/9223372036854775807 9223372036854775/9223372036854775000)
	   * I guess if the user is using "inexact" numbers (#i...), he accepts their inexactness.
	   */
	  
	  if (den_a == den_b)
	    {
	      if (num_a < num_b)
		x = y;
	    }
	  else
	    {
	      if (num_a == num_b)
		{
		  if (((num_a >= 0) &&
		       (den_a > den_b)) ||
		      ((num_a < 0) &&
		       (den_a < den_b)))
		    x = y;
		}
	      else
		{
		  s7_Int vala, valb;
		  vala = num_a / den_a;
		  valb = num_b / den_b;
		  
		  if (!((vala > valb) ||
			((vala == valb) && (type(y) == T_INTEGER))))
		    {
		      if ((valb > vala) ||
			  ((vala == valb) && (type(x) == T_INTEGER)) ||
			  /* sigh -- both are ratios and the int parts are equal */
			  (((long double)(num_a % den_a) / (long double)den_a) <= ((long double)(num_b % den_b) / (long double)den_b)))
			x = y;
		    }
		}
	    }
	  if (type(x) == T_RATIO)
	    goto MAX_RATIOS;
	  goto MAX_INTEGERS;

	case T_REAL:
	  if (fraction(x) < real(y))
	    {
	      x = y;
	      goto MAX_REALS;
	    }
	  goto MAX_RATIOS;

	default:        
	  CHECK_METHOD(sc, y, sc->MAX, args);
	  return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x)))
	{
	  for (; is_not_null(p); p = cdr(p))
	    if (!is_real(car(p)))
	      {
		CHECK_METHOD(sc, car(p), sc->MAX, args);
		return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
	      }
	  return(x);
	}

    MAX_REALS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER: 
	  if (real(x) < integer(y))
	    {
	      x = y;
	      goto MAX_INTEGERS;
	    }
	  goto MAX_REALS;

	case T_RATIO:
	  if (real(x) < fraction(y))
	    {
	      x = y;
	      goto MAX_RATIOS;
	    }
	  goto MAX_REALS;

	case T_REAL:
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real(car(p)))
		  {
		    CHECK_METHOD(sc, car(p), sc->MAX, args);
		    return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args), car(p), T_REAL));
		  }
	      return(y);
	    }
	  if (real(x) < real(y)) x = y;
	  goto MAX_REALS;

	default:
	  CHECK_METHOD(sc, y, sc->MAX, args);
	  return(wrong_type_argument_n(sc, sc->MAX, position_of(p, args) - 1, y, T_REAL));
	}

    default:
      CHECK_METHOD(sc, x, sc->MAX, args);
      return(wrong_type_argument(sc, sc->MAX, small_int(1), x, T_REAL));
    }
}


static s7_pointer max_f2;
static s7_pointer g_max_f2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  x = car(args);
  y = cadr(args);
  if (is_simple_real(y))
    return((real(x) >= real(y)) ? x : y);
  if (is_real(y))
    return((real(x) >= s7_number_to_real(sc, y)) ? x : y);
  return(wrong_type_argument(sc, sc->MAX, small_int(2), y, T_REAL));
}


static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
  #define H_min "(min ...) returns the minimum of its arguments"

  s7_pointer x, y, p;
  s7_Int num_a, num_b, den_a, den_b;

  x = car(args);
  p = cdr(args);
  
  switch (type(x))
    {
    case T_INTEGER:
    MIN_INTEGERS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER: 
	  if (integer(x) > integer(y)) x = y;
	  goto MIN_INTEGERS;

	case T_RATIO:
	  num_a = integer(x);
	  den_a = 1;
	  num_b = numerator(y);
	  den_b = denominator(y);
	  goto RATIO_MIN_RATIO;
	  
	case T_REAL:    
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real(car(p)))
		  {
		    CHECK_METHOD(sc, car(p), sc->MIN, args);
		    return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
		  }
	      return(y);
	    }
	  if (integer(x) > real(y)) 
	    {
	      x = y; 
	      goto MIN_REALS;
	    }
	  goto MIN_INTEGERS;

	default:        
	  CHECK_METHOD(sc, y, sc->MIN, args);
	  return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    MIN_RATIOS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER:
	  num_a = numerator(x);
	  den_a = denominator(x);
	  num_b = integer(y);
	  den_b = 1;
	  goto RATIO_MIN_RATIO;
	  
	case T_RATIO:
	  num_a = numerator(x);
	  den_a = denominator(x);
	  num_b = numerator(y);
	  den_b = denominator(y);
	  
	RATIO_MIN_RATIO:
	    if (den_a == den_b)
	      {
		if (num_a > num_b)
		  x = y;
	      }
	    else
	      {
		if (num_a == num_b)
		  {
		    if (((num_a >= 0) &&
			 (den_a < den_b)) ||
			((num_a < 0) &&
			 (den_a > den_b)))
		      x = y;
		  }
		else
		  {
		    s7_Int vala, valb;
		    vala = num_a / den_a;
		    valb = num_b / den_b;

		    if (!((vala < valb) ||
			  ((vala == valb) && (type(x) == T_INTEGER))))
		      {
			if ((valb < vala) ||
			    ((vala == valb) && (type(y) == T_INTEGER)) ||
			    (((long double)(num_a % den_a) / (long double)den_a) >= ((long double)(num_b % den_b) / (long double)den_b)))
			  x = y;
		      }
		  }
	      }
	  if (type(x) == T_RATIO)
	    goto MIN_RATIOS;
	  goto MIN_INTEGERS;

	case T_REAL:
	  if (fraction(x) > real(y))
	    {
	      x = y;
	      goto MIN_REALS;
	    }
	  goto MIN_RATIOS;

	default:        
	  CHECK_METHOD(sc, y, sc->MIN, args);
	  return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x)))
	{
	  for (; is_not_null(p); p = cdr(p))
	    if (!is_real(car(p)))
	      {
		CHECK_METHOD(sc, car(p), sc->MIN, args);
		return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
	      }
	  return(x);
	}

    MIN_REALS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      
      switch (type(y))
	{
	case T_INTEGER: 
	  if (real(x) > integer(y))
	    {
	      x = y;
	      goto MIN_INTEGERS;
	    }
	  goto MIN_REALS;

	case T_RATIO:
	  if (real(x) > fraction(y))
	    {
	      x = y;
	      goto MIN_RATIOS;
	    }
	  goto MIN_REALS;

	case T_REAL:
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real(car(p)))
		  {
		    CHECK_METHOD(sc, car(p), sc->MIN, args);
		    return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args), car(p), T_REAL));
		  }
	      return(y);
	    }
	  if (real(x) > real(y)) x = y;
	  goto MIN_REALS;

	default:
	  CHECK_METHOD(sc, y, sc->MIN, args);
	  return(wrong_type_argument_n(sc, sc->MIN, position_of(p, args) - 1, y, T_REAL));
	}

    default:
      CHECK_METHOD(sc, x, sc->MIN, args);
      return(wrong_type_argument(sc, sc->MIN, small_int(1), x, T_REAL));
    }
}


static s7_pointer min_f2;
static s7_pointer g_min_f2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  x = car(args);
  y = cadr(args);
  if (is_simple_real(y))
    return((real(x) <= real(y)) ? x : y);
  if (is_real(y))
    return((real(x) <= s7_number_to_real(sc, y)) ? x : y);
  return(wrong_type_argument(sc, sc->MIN, small_int(2), y, T_REAL));
}




/* ---------------------------------------- = > < >= <= ---------------------------------------- */

static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_equal "(= z1 ...) returns #t if all its arguments are equal"
  s7_pointer x, p;
  s7_Int num_a, den_a;
  s7_Double rl_a, im_a;

  x = car(args);
  p = cdr(args);

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);
      while (true)
	{
	  x = car(p);
	  p = cdr(p);
	  switch (type(x))
	    {
	    case T_INTEGER: 
	      if (num_a != integer(x)) goto NOT_EQUAL; 
	      break;

	    case T_RATIO:   
	    case T_COMPLEX: 
	      goto NOT_EQUAL;                          
	      break;
	      
	    case T_REAL:    
	      if (num_a != real(x)) goto NOT_EQUAL;    
	      break;

	    default:
	      CHECK_METHOD(sc, x, sc->EQ, args);
	      return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(p, args) - 1, x, A_NUMBER));	      
	    }
	  if (is_null(p))
	    return(sc->T);
	}

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
      rl_a = 0.0;
      while (true)
	{
	  x = car(p);
	  p = cdr(p);
	  switch (type(x))
	    {
	    case T_INTEGER: 
	    case T_COMPLEX: 
	      goto NOT_EQUAL;
	      break;

	    case T_RATIO:   
	      if ((num_a != numerator(x)) || (den_a != denominator(x)))	goto NOT_EQUAL;
	      break;

	    case T_REAL:
	      if (rl_a == 0.0)
		rl_a = ((long double)num_a) / ((long double)den_a);
	      if (rl_a != real(x)) goto NOT_EQUAL;
	      break;

	    default:        
	      CHECK_METHOD(sc, x, sc->EQ, args);
	      return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(p, args) - 1, x, A_NUMBER));	      
	    }
	  if (is_null(p))
	    return(sc->T);
	}

    case T_REAL:
      rl_a = real(x);
      while (true)
	{
	  x = car(p);
	  p = cdr(p);
	  switch (type(x))
	    {
	    case T_INTEGER: 
	      if (rl_a != integer(x)) goto NOT_EQUAL; 
	      break;

	    case T_RATIO:
	      if (rl_a != fraction(x)) goto NOT_EQUAL;
	      break;
	      
	    case T_REAL:    
	      if (rl_a != real(x)) goto NOT_EQUAL;    
	      break;

	    case T_COMPLEX: 
	      goto NOT_EQUAL;                          
	      break;

	    default:
	      CHECK_METHOD(sc, x, sc->EQ, args);
	      return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(p, args) - 1, x, A_NUMBER));	      
	    }
	  if (is_null(p))
	    return(sc->T);
	}
      
    case T_COMPLEX:
      rl_a = real_part(x);
      im_a = imag_part(x);
      while (true)
	{
	  x = car(p);
	  p = cdr(p);
	  switch (type(x))
	    {
	    case T_INTEGER: 
	    case T_RATIO:
	    case T_REAL:
	      goto NOT_EQUAL;
	      break;

	    case T_COMPLEX: 
	      if ((rl_a != real_part(x)) || (im_a != imag_part(x)))
		goto NOT_EQUAL;
	      break;

	    default:
	      CHECK_METHOD(sc, x, sc->EQ, args);
	      return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(p, args) - 1, x, A_NUMBER));	      
	    }
	  if (is_null(p))
	    return(sc->T);
	}
      
    default:
      CHECK_METHOD(sc, x, sc->EQ, args);
      return(wrong_type_argument_with_type(sc, sc->EQ, small_int(1), x, A_NUMBER));
    }

 NOT_EQUAL:
  for (; is_pair(p); p = cdr(p))
    if (!s7_is_number(car(p)))
      {
	CHECK_METHOD(sc, car(p), sc->EQ, args);
	return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(p, args), car(p), A_NUMBER));
      }
  return(sc->F);
}




static s7_pointer equal_s_ic, equal_length_ic, equal_2;
static s7_pointer g_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int y;
  s7_pointer val;

  val = finder(sc, car(args));
  y = s7_integer(cadr(args));
  if (is_integer(val))
    return(make_boolean(sc, integer(val) == y));

  switch (type(val))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(val) == y));
      break;
      
    case T_RATIO:  
      return(sc->F);
      
    case T_REAL:    
      return(make_boolean(sc, real(val) == y));
      break;

    case T_COMPLEX:
      return(sc->F);

    default:
      CHECK_METHOD(sc, val, sc->EQ, args);
      return(wrong_type_argument_with_type(sc, sc->EQ, small_int(1), val, A_NUMBER));
    }
  return(sc->T);
}

static s7_Int object_length_to_int(s7_scheme *sc, s7_pointer obj);

static s7_pointer g_equal_length_ic(s7_scheme *sc, s7_pointer args)
{
  /* an experiment to avoid make_integer (and telescope opts)
   *   we get here with car=length expr, cadr=int
   */
  s7_Int ilen;
  s7_pointer val;
  
  val = finder(sc, cadar(args));
  ilen = s7_integer(cadr(args));

  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_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(make_boolean(sc, vector_length(val) == ilen));

    case T_STRING:
      return(make_boolean(sc, string_length(val) == ilen));

    case T_HASH_TABLE:
      return(make_boolean(sc, hash_table_length(val) == ilen));

    case T_C_OBJECT:
      return(make_boolean(sc, object_length_to_int(sc, val) == ilen));

    case T_ENVIRONMENT:
      return(make_boolean(sc, environment_length(sc, val) == ilen));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(val))
	return(make_boolean(sc, closure_length(sc, val) == ilen));

    default:
      /* here we've already lost because we've checked for the length above */
      return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, val, make_protected_string(sc, "a list, vector, string, or hash-table")));
    }
  return(sc->F);
}


static s7_pointer g_equal_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

#if (!MS_WINDOWS)
  if (type(x) == type(y))
    {
      if (is_integer(x))
	return(make_boolean(sc, integer(x) == integer(y)));
      switch (type(x))
	{
	case T_INTEGER: return(make_boolean(sc, integer(x) == integer(y)));
	case T_RATIO:   return(make_boolean(sc, (numerator(x) == numerator(y)) && (denominator(x) == denominator(y))));
	case T_REAL:    return(make_boolean(sc, real(x) == real(y)));
	case T_COMPLEX: return(make_boolean(sc, (real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))));
	}
    }
#endif

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER: return(make_boolean(sc, integer(x) == integer(y)));
	case T_RATIO:   return(sc->F);
	case T_REAL:    return(make_boolean(sc, integer(x) == real(y)));
	case T_COMPLEX: return(sc->F);
	default:        
	  CHECK_METHOD(sc, y, sc->EQ, args);
	  return(wrong_type_argument_with_type(sc, sc->EQ, small_int(2), y, A_NUMBER));	  
	}
      break;
      
    case T_RATIO:  
      switch (type(y))
	{
	case T_INTEGER: return(sc->F);
	case T_RATIO:   return(make_boolean(sc, (numerator(x) == numerator(y)) && (denominator(x) == denominator(y))));
	case T_REAL:    return(make_boolean(sc, fraction(x) == real(y)));            /* this could avoid the divide via numerator == denominator * x */
	case T_COMPLEX: return(sc->F);
	default:        
	  CHECK_METHOD(sc, y, sc->EQ, args);
	  return(wrong_type_argument_with_type(sc, sc->EQ, small_int(2), y, A_NUMBER));	  
	}
      break;
      
    case T_REAL:    
      switch (type(y))
	{
	case T_INTEGER: return(make_boolean(sc, real(x) == integer(y)));
	case T_RATIO:   return(make_boolean(sc, real(x) == fraction(y)));
	case T_REAL:    return(make_boolean(sc, real(x) == real(y)));
	case T_COMPLEX: return(sc->F);
	default:        
	  CHECK_METHOD(sc, y, sc->EQ, args);
	  return(wrong_type_argument_with_type(sc, sc->EQ, small_int(2), y, A_NUMBER));	  
	}
      break;
      
    case T_COMPLEX:
      switch (type(y))
	{
	case T_INTEGER:
	case T_RATIO:
	case T_REAL:
	  return(sc->F);

#if (!MS_WINDOWS)
	case T_COMPLEX: 
	  return(make_boolean(sc, (real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))));
#else
	case T_COMPLEX: 
	  if ((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))) return(sc->T); else return(sc->F);
#endif
	default:      
	  CHECK_METHOD(sc, y, sc->EQ, args);  
	  return(wrong_type_argument_with_type(sc, sc->EQ, small_int(2), y, A_NUMBER));	  
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->EQ, args);
      return(wrong_type_argument_with_type(sc, sc->EQ, small_int(1), x, A_NUMBER));
    }
  return(sc->F);
}


#if (!WITH_GMP)
static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
{
  #define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
  s7_pointer x, y, p;

  x = car(args);
  p = cdr(args);

  switch (type(x))
    {
    case T_INTEGER:
    INTEGER_LESS:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(x) >= integer(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LESS;

	case T_RATIO:
	  /* no gmp here, but this can overflow: (< 9223372036 1/9223372036), but conversion to real is also problematic
	   */
	  if ((integer(x) >= 0) && (numerator(y) < 0)) goto NOT_LESS;  /* (< 1 -1/2), ratio numerator can't be 0 */
	  if ((integer(x) <= 0) && (numerator(y) > 0))                 /* (< 0 1/2) */
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto RATIO_LESS;
	    }
	  if ((integer(x) < S7_LONG_MAX) && 
	      (integer(x) > S7_LONG_MIN) && 
	      (denominator(y) < S7_LONG_MAX) && 
	      (denominator(y) > S7_LONG_MIN))
	    {
	      if ((integer(x) * denominator(y)) >= numerator(y)) goto NOT_LESS;
	    }
	  else
	    {
	      if (integer(x) >= fraction(y)) goto NOT_LESS;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LESS;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LESS;
	  if (integer(x) >= real(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LESS;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LT, args);  
	  return(wrong_type_argument_n(sc, sc->LT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    RATIO_LESS:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if ((numerator(x) > 0) && (integer(y) <= 0)) goto NOT_LESS;
	  if ((numerator(x) < 0) && (integer(y) >= 0)) 
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto INTEGER_LESS;
	    }
	  if ((integer(y) < S7_LONG_MAX) && 
	      (integer(y) > S7_LONG_MIN) && 
	      (denominator(x) < S7_LONG_MAX) && 
	      (denominator(x) > S7_LONG_MIN))
	    {
	      if (numerator(x) >= (integer(y) * denominator(x))) goto NOT_LESS;
	    }
	  else
	    {
	      if (fraction(x) >= integer(y)) goto NOT_LESS;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LESS;

	case T_RATIO:
	  /* conversion to real and >= is not safe here (see comment under g_greater) */
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = denominator(x);
	    n1 = numerator(x);
	    d2 = denominator(y);
	    n2 = numerator(y);
	    if (d1 == d2)       
	      {
		if (n1 >= n2) goto NOT_LESS;
	      }
	    else
	      {
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (fraction(x) >= fraction(y)) goto NOT_LESS;
      
			/* (< 21053343141/6701487259 3587785776203/1142027682075) -> #f because even long doubles aren't enough here 
			 * (= 21053343141/6701487259 3587785776203/1142027682075) is #f because it checks the actual ints and
			 * (> 21053343141/6701487259 3587785776203/1142027682075) is #f just like the < case.
			 * similarly
			 * (min 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
			 * (max 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
			 *
			 * if we print the long double results as integers, both are -3958705157555305931
			 *    so there's not a lot I can do in the non-gmp case.
			 */
		      }
		    else 
		      {
			if ((n1 * d2) >= (n2 * d1)) goto NOT_LESS;
		      }
		  }
		else
		  {
		    if ((n1 * d2) >=  (n2 * d1)) goto NOT_LESS;
		  }
	      }
	  }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LESS;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LESS;
	  if (fraction(x) >= real(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LESS;
	  
	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LT, args);  
	  return(wrong_type_argument_n(sc, sc->LT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x))) goto NOT_LESS;

    REAL_LESS:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (real(x) >= integer(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LESS;

	case T_RATIO:
	  if (real(x) >= fraction(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LESS;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LESS;
	  if (real(x) >= real(y)) goto NOT_LESS;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LESS;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LT, args);  
	  return(wrong_type_argument_n(sc, sc->LT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->LT, args);  
      return(wrong_type_argument(sc, sc->LT, small_int(1), x, T_REAL));
    }

 NOT_LESS:
  for (; is_pair(p); p = cdr(p))
    if (!is_real(car(p)))
      {
	CHECK_METHOD(sc, car(p), sc->LT, args);  
	return(wrong_type_argument_n(sc, sc->LT, position_of(p, args), car(p), T_REAL));
      }
  return(sc->F);
}



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 increasing order"
  s7_pointer x, y, p;

  x = car(args);
  p = cdr(args);

  switch (type(x))
    {
    case T_INTEGER:
    INTEGER_LEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(x) > integer(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LEQ;

	case T_RATIO:
	  /* no gmp here, but this can overflow: (< 9223372036 1/9223372036), but conversion to real is also problematic
	   */
	  if ((integer(x) >= 0) && (numerator(y) < 0)) goto NOT_LEQ;  /* (< 1 -1/2), ratio numerator can't be 0 */
	  if ((integer(x) <= 0) && (numerator(y) > 0))                 /* (< 0 1/2) */
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto RATIO_LEQ;
	    }
	  if ((integer(x) < S7_LONG_MAX) && 
	      (integer(x) > S7_LONG_MIN) && 
	      (denominator(y) < S7_LONG_MAX) && 
	      (denominator(y) > S7_LONG_MIN))
	    {
	      if ((integer(x) * denominator(y)) > numerator(y)) goto NOT_LEQ;
	    }
	  else
	    {
	      if (integer(x) > fraction(y)) goto NOT_LEQ;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LEQ;
	  if (integer(x) > real(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LEQ;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LEQ, args);  
	  return(wrong_type_argument_n(sc, sc->LEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    RATIO_LEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if ((numerator(x) > 0) && (integer(y) <= 0)) goto NOT_LEQ;
	  if ((numerator(x) < 0) && (integer(y) >= 0)) 
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto INTEGER_LEQ;
	    }
	  if ((integer(y) < S7_LONG_MAX) && 
	      (integer(y) > S7_LONG_MIN) && 
	      (denominator(x) < S7_LONG_MAX) && 
	      (denominator(x) > S7_LONG_MIN))
	    {
	      if (numerator(x) > (integer(y) * denominator(x))) goto NOT_LEQ;
	    }
	  else
	    {
	      if (fraction(x) > integer(y)) goto NOT_LEQ;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LEQ;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = denominator(x);
	    n1 = numerator(x);
	    d2 = denominator(y);
	    n2 = numerator(y);
	    if (d1 == d2)       
	      {
		if (n1 > n2) goto NOT_LEQ;
	      }
	    else
	      {
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (fraction(x) > fraction(y)) goto NOT_LEQ;
		      }
		    else 
		      {
			if ((n1 * d2) > (n2 * d1)) goto NOT_LEQ;
		      }
		  }
		else
		  {
		    if ((n1 * d2) >  (n2 * d1)) goto NOT_LEQ;
		  }
	      }
	  }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LEQ;
	  if (fraction(x) > real(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LEQ;
	  
	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LEQ, args);  
	  return(wrong_type_argument_n(sc, sc->LEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x))) goto NOT_LEQ;

    REAL_LEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (real(x) > integer(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_LEQ;

	case T_RATIO:
	  if (real(x) > fraction(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_LEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_LEQ;
	  if (real(x) > real(y)) goto NOT_LEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_LEQ;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->LEQ, args);  
	  return(wrong_type_argument_n(sc, sc->LEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->LEQ, args);  
      return(wrong_type_argument(sc, sc->LEQ, small_int(1), x, T_REAL));
    }

 NOT_LEQ:
  for (; is_pair(p); p = cdr(p))
    if (!is_real(car(p)))
      {
	CHECK_METHOD(sc, car(p), sc->LEQ, args);  
	return(wrong_type_argument_n(sc, sc->LEQ, position_of(p, args), car(p), T_REAL));
      }
  return(sc->F);
}


static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
  s7_pointer x, y, p;

  x = car(args);
  p = cdr(args);

  switch (type(x))
    {
    case T_INTEGER:
    INTEGER_GREATER:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(x) <= integer(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GREATER;

	case T_RATIO:
	  /* no gmp here, but this can overflow: (< 9223372036 1/9223372036), but conversion to real is also problematic
	   */
	  if ((integer(x) <= 0) && (numerator(y) > 0)) goto NOT_GREATER; 
	  if ((integer(x) >= 0) && (numerator(y) < 0)) 
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto RATIO_GREATER;
	    }
	  if ((integer(x) < S7_LONG_MAX) && 
	      (integer(x) > S7_LONG_MIN) && 
	      (denominator(y) < S7_LONG_MAX) && 
	      (denominator(y) > S7_LONG_MIN))
	    {
	      if ((integer(x) * denominator(y)) <= numerator(y)) goto NOT_GREATER;
	    }
	  else
	    {
	      if (integer(x) <= fraction(y)) goto NOT_GREATER;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GREATER;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GREATER;
	  if (integer(x) <= real(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GREATER;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GT, args);  
	  return(wrong_type_argument_n(sc, sc->GT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    RATIO_GREATER:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if ((numerator(x) < 0) && (integer(y) >= 0)) goto NOT_GREATER;
	  if ((numerator(x) > 0) && (integer(y) <= 0))
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto INTEGER_GREATER;
	    }
	  if ((integer(y) < S7_LONG_MAX) && 
	      (integer(y) > S7_LONG_MIN) && 
	      (denominator(x) < S7_LONG_MAX) && 
	      (denominator(x) > S7_LONG_MIN))
	    {
	      if (numerator(x) <= (integer(y) * denominator(x))) goto NOT_GREATER;
	    }
	  else
	    {
	      if (fraction(x) <= integer(y)) goto NOT_GREATER;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GREATER;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = denominator(x);
	    n1 = numerator(x);
	    d2 = denominator(y);
	    n2 = numerator(y);
	    if (d1 == d2)       
	      {
		if (n1 <= n2) goto NOT_GREATER;
	      }
	    else
	      {
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (fraction(x) <= fraction(y)) goto NOT_GREATER;
      
			/* (< 21053343141/6701487259 3587785776203/1142027682075) -> #f because even long doubles aren't enough here 
			 * (= 21053343141/6701487259 3587785776203/1142027682075) is #f because it checks the actual ints and
			 * (> 21053343141/6701487259 3587785776203/1142027682075) is #f just like the < case.
			 * similarly
			 * (min 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
			 * (max 21053343141/6701487259 3587785776203/1142027682075) -> 3587785776203/1142027682075
			 *
			 * if we print the long double results as integers, both are -3958705157555305931
			 *    so there's not a lot I can do in the non-gmp case.
			 */
		      }
		    else 
		      {
			if ((n1 * d2) <= (n2 * d1)) goto NOT_GREATER;
		      }
		  }
		else
		  {
		    if ((n1 * d2) <=  (n2 * d1)) goto NOT_GREATER;
		  }
	      }
	  }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GREATER;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GREATER;
	  if (fraction(x) <= real(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GREATER;
	  
	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GT, args);  
	  return(wrong_type_argument_n(sc, sc->GT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x))) goto NOT_GREATER;

    REAL_GREATER:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (real(x) <= integer(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GREATER;

	case T_RATIO:
	  if (real(x) <= fraction(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GREATER;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GREATER;
	  if (real(x) <= real(y)) goto NOT_GREATER;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GREATER;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GT, args);  
	  return(wrong_type_argument_n(sc, sc->GT, position_of(p, args) - 1, y, T_REAL));
	}


    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->GT, args);  
      return(wrong_type_argument(sc, sc->GT, small_int(1), x, T_REAL));
    }

 NOT_GREATER:
  for (; is_pair(p); p = cdr(p))
    if (!is_real(car(p)))
      {
	CHECK_METHOD(sc, car(p), sc->GT, args);  
	return(wrong_type_argument_n(sc, sc->GT, position_of(p, args), car(p), T_REAL));
      }
  return(sc->F);
}


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 decreasing order"
  /* (>= 1+i 1+i) is an error which seems unfortunate
   */
  s7_pointer x, y, p;

  x = car(args);
  p = cdr(args);

  switch (type(x))
    {
    case T_INTEGER:
    INTEGER_GEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(x) < integer(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GEQ;

	case T_RATIO:
	  /* no gmp here, but this can overflow: (< 9223372036 1/9223372036), but conversion to real is also problematic
	   */
	  if ((integer(x) <= 0) && (numerator(y) > 0)) goto NOT_GEQ; 
	  if ((integer(x) >= 0) && (numerator(y) < 0)) 
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto RATIO_GEQ;
	    }
	  if ((integer(x) < S7_LONG_MAX) && 
	      (integer(x) > S7_LONG_MIN) && 
	      (denominator(y) < S7_LONG_MAX) && 
	      (denominator(y) > S7_LONG_MIN))
	    {
	      if ((integer(x) * denominator(y)) < numerator(y)) goto NOT_GEQ;
	    }
	  else
	    {
	      if (integer(x) < fraction(y)) goto NOT_GEQ;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GEQ;
	  if (integer(x) < real(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GEQ;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GEQ, args);  
	  return(wrong_type_argument_n(sc, sc->GEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_RATIO:
    RATIO_GEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if ((numerator(x) < 0) && (integer(y) >= 0)) goto NOT_GEQ;
	  if ((numerator(x) > 0) && (integer(y) <= 0))
	    {
	      if (is_null(p)) return(sc->T);
	      x = y;
	      goto INTEGER_GEQ;
	    }
	  if ((integer(y) < S7_LONG_MAX) && 
	      (integer(y) > S7_LONG_MIN) && 
	      (denominator(x) < S7_LONG_MAX) && 
	      (denominator(x) > S7_LONG_MIN))
	    {
	      if (numerator(x) < (integer(y) * denominator(x))) goto NOT_GEQ;
	    }
	  else
	    {
	      if (fraction(x) < integer(y)) goto NOT_GEQ;
	    }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GEQ;

	case T_RATIO:
	  {
	    s7_Int d1, d2, n1, n2;
	    d1 = denominator(x);
	    n1 = numerator(x);
	    d2 = denominator(y);
	    n2 = numerator(y);
	    if (d1 == d2)       
	      {
		if (n1 < n2) goto NOT_GEQ;
	      }
	    else
	      {
		if ((d1 > s7_int_max) || (d2 > s7_int_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int_max) || (n2 > s7_int_max) ||
		    (n1 < s7_int_min) || (n2 < s7_int_min))
		  {
		    int d1bits, d2bits;
		    d1bits = integer_length(d1);
		    d2bits = integer_length(d2);
		    if (((d1bits + d2bits) > s7_int_bits) ||
			((d1bits + integer_length(n2)) > (s7_int_bits - 1)) ||
			((d2bits + integer_length(n1)) > (s7_int_bits - 1)))
		      {
			if (fraction(x) < fraction(y)) goto NOT_GEQ;
		      }
		    else 
		      {
			if ((n1 * d2) < (n2 * d1)) goto NOT_GEQ;
		      }
		  }
		else
		  {
		    if ((n1 * d2) <  (n2 * d1)) goto NOT_GEQ;
		  }
	      }
	  }
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GEQ;
	  if (fraction(x) < real(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GEQ;
	  
	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GEQ, args);  
	  return(wrong_type_argument_n(sc, sc->GEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_REAL:
      if (is_NaN(real(x))) goto NOT_GEQ;

    REAL_GEQ:
      y = car(p);
      p = cdr(p);
      switch (type(y))
	{
	case T_INTEGER:
	  if (real(x) < integer(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto INTEGER_GEQ;

	case T_RATIO:
	  if (real(x) < fraction(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto RATIO_GEQ;

	case T_REAL:
	  if (is_NaN(real(y))) goto NOT_GEQ;
	  if (real(x) < real(y)) goto NOT_GEQ;
	  if (is_null(p)) return(sc->T);
	  x = y;
	  goto REAL_GEQ;

	case T_COMPLEX:
	default:
	  CHECK_METHOD(sc, y, sc->GEQ, args);  
	  return(wrong_type_argument_n(sc, sc->GEQ, position_of(p, args) - 1, y, T_REAL));
	}


    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->GEQ, args);  
      return(wrong_type_argument(sc, sc->GEQ, small_int(1), x, T_REAL));
    }

 NOT_GEQ:
  for (; is_pair(p); p = cdr(p))
    if (!is_real(car(p)))
      {
	CHECK_METHOD(sc, car(p), sc->GEQ, args);  
	return(wrong_type_argument_n(sc, sc->GEQ, position_of(p, args), car(p), T_REAL));
      }
  return(sc->F);

}


static s7_pointer less_s_ic, less_s0;
static s7_pointer g_less_s0(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = car(args);
  if (is_integer(x))
    return(make_boolean(sc, integer(x) < 0));
  if (is_real(x))
    return(make_boolean(sc, s7_is_negative(x)));
  return(wrong_type_argument(sc, sc->LT, small_int(1), x, T_REAL));
}

static s7_pointer g_less_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int y;
  s7_pointer x;
  
  x = car(args);
  y = integer(cadr(args));
  if (is_integer(x))
    return(make_boolean(sc, integer(x) < y));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) < y));
      break;
      
    case T_RATIO:  
      if ((y >= 0) && (numerator(x) < 0))
	return(sc->T);
      if ((y <= 0) && (numerator(x) > 0))
	return(sc->F);
      if ((y < S7_LONG_MAX) && 
	  (y > S7_LONG_MIN) && 
	  (denominator(x) < S7_LONG_MAX) && 
	  (denominator(x) > S7_LONG_MIN))
	return(make_boolean(sc, (numerator(x) < (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) < y));
      break;
      
    case T_REAL:    
      return(make_boolean(sc, real(x) < y));
      break;

    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->LT, args);
      return(wrong_type_argument(sc, sc->LT, small_int(1), x, T_REAL));
    }
  return(sc->T);
}

static s7_pointer less_length_ic;
static s7_pointer g_less_length_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int ilen;
  s7_pointer val;
  
  val = finder(sc, cadar(args));
  ilen = s7_integer(cadr(args));

  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_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(make_boolean(sc, vector_length(val) < ilen));

    case T_STRING:
      return(make_boolean(sc, string_length(val) < ilen));

    case T_HASH_TABLE:
      return(make_boolean(sc, hash_table_length(val) < ilen));

    case T_C_OBJECT:
      return(make_boolean(sc, object_length_to_int(sc, val) < ilen));

    case T_ENVIRONMENT:
      return(make_boolean(sc, environment_length(sc, val) < ilen));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(val))
	return(make_boolean(sc, closure_length(sc, val) < ilen));

    default:
      /* no check method here because we checked above */
      return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, val, make_protected_string(sc, "a list, vector, string, or hash-table")));
    }
  return(sc->F);
}

static s7_pointer less_2;
static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

#if (!MS_WINDOWS)
  if (type(x) == type(y))
    {
      switch (type(x))
	{
	case T_INTEGER: return(make_boolean(sc, integer(x) < integer(y)));
	case T_RATIO:   return(make_boolean(sc, fraction(x) < fraction(y)));
	case T_REAL:    return(make_boolean(sc, real(x) < real(y)));
	}
    }
#endif

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_boolean(sc, integer(x) < integer(y)));
	  break;
	  
	case T_RATIO: 
	  return(g_less(sc, args));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) < real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->LT, args);
	  return(wrong_type_argument(sc, sc->LT, small_int(2), y, T_REAL));	  
	}
      break;
      
    case T_RATIO:
      return(g_less(sc, args));
      break;
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: 
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) < integer(y)));
	  break;
	  
	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) < fraction(y)));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(x))) return(sc->F);
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, real(x) < real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->LT, args);
	  return(wrong_type_argument(sc, sc->LT, small_int(2), y, T_REAL));	  
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->LT, args);
      return(wrong_type_argument(sc, sc->LT, small_int(1), x, T_REAL));      
    }

  return(sc->T);
}

static s7_pointer leq_s_ic;
static s7_pointer g_leq_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int y;
  s7_pointer x;
  
  x = car(args);
  y = s7_integer(cadr(args));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) <= y));
      break;
      
    case T_RATIO:  
      if ((y >= 0) && (numerator(x) <= 0))
	return(sc->T);
      if ((y <= 0) && (numerator(x) > 0))
	return(sc->F);
      if ((y < S7_LONG_MAX) && 
	  (y > S7_LONG_MIN) && 
	  (denominator(x) < S7_LONG_MAX) && 
	  (denominator(x) > S7_LONG_MIN))
	return(make_boolean(sc, (numerator(x) <= (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) <= y));
      break;
      
    case T_REAL:    
      return(make_boolean(sc, real(x) <= y));
      break;

    default:
      CHECK_METHOD(sc, x, sc->LEQ, args);
      return(wrong_type_argument(sc, sc->LEQ, small_int(1), x, T_REAL));  
    }
  return(sc->T);
}

static s7_pointer leq_2;
static s7_pointer g_leq_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_boolean(sc, integer(x) <= integer(y)));
	  break;
	  
	case T_RATIO: 
	  return(g_less_or_equal(sc, args));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) <= real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->LEQ, args);
	  return(wrong_type_argument(sc, sc->LEQ, small_int(2), y, T_REAL));	  
	}
      break;
      
    case T_RATIO:
      return(g_less_or_equal(sc, args));
      break;
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: 
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) <= integer(y)));
	  break;
	  
	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) <= fraction(y)));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(x))) return(sc->F);
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, real(x) <= real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->LEQ, args);
	  return(wrong_type_argument(sc, sc->LEQ, small_int(2), y, T_REAL));	  
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->LEQ, args);
      return(wrong_type_argument(sc, sc->LEQ, small_int(1), x, T_REAL));
    }

  return(sc->T);
}

static s7_pointer greater_s_ic, greater_s_fc;
static s7_pointer g_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int y;
  s7_pointer x;
  
  x = car(args);
  y = s7_integer(cadr(args));
  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) > y));
      break;
      
    case T_RATIO:  
      if ((y < S7_LONG_MAX) && 
	  (y > S7_LONG_MIN) && 
	  (denominator(x) < S7_LONG_MAX) && 
	  (denominator(x) > S7_LONG_MIN))
	return(make_boolean(sc, (numerator(x) > (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) > y));
      break;
      
    case T_REAL:    
      return(make_boolean(sc, real(x) > y));
      break;

    default:
      CHECK_METHOD(sc, x, sc->GT, args);
      return(wrong_type_argument_with_type(sc, sc->GT, small_int(1), x, A_NUMBER));  
    }
  return(sc->T);
}

static s7_pointer g_greater_s_fc(s7_scheme *sc, s7_pointer args)
{
  s7_Double y;
  s7_pointer x;

  x = car(args);
  y = s7_real(cadr(args));

  if (type(x) == T_REAL)
    return(make_boolean(sc, real(x) > y));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) > y));
      break;
      
    case T_RATIO:  
      /* (> 9223372036854775807/9223372036854775806 1.0) */
      if ((y < S7_LONG_MAX) && 
	  (y > S7_LONG_MIN) && 
	  (denominator(x) < S7_LONG_MAX) && 
	  (denominator(x) > S7_LONG_MIN))
	return(make_boolean(sc, (numerator(x) > (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) > y));
      break;
      
    case T_REAL:    
      return(make_boolean(sc, real(x) > y));
      break;

    default:
      CHECK_METHOD(sc, x, sc->GT, args);
      return(wrong_type_argument_with_type(sc, sc->GT, small_int(1), x, A_NUMBER));  
    }
  return(sc->T);
}


static s7_pointer greater_2;
static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER: 
	  return(make_boolean(sc, integer(x) > integer(y)));

	case T_RATIO:   
	  return(g_greater(sc, args));

	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) > real(y)));
	  break;

	default:       
	  CHECK_METHOD(sc, y, sc->GT, args);
	  return(wrong_type_argument(sc, sc->GT, small_int(2), y, T_REAL));
	}
      break;
      
    case T_RATIO:
      return(g_greater(sc, args));
      break;
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: 
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) > integer(y)));
	  break;
	  
	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) > fraction(y)));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(x))) return(sc->F);
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, real(x) > real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->GT, args);
	  return(wrong_type_argument(sc, sc->GT, small_int(2), y, T_REAL));
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->GT, args);
      return(wrong_type_argument(sc, sc->GT, small_int(1), x, T_REAL));
    }

  return(sc->T);
}


static s7_pointer geq_2;
static s7_pointer g_geq_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;

  x = car(args);
  y = cadr(args);

#if (!MS_WINDOWS)
  if (type(x) == type(y))
    {
      if (is_integer(x))
	return(make_boolean(sc, integer(x) >= integer(y)));
      switch (type(x))
	{
	case T_INTEGER: return(make_boolean(sc, integer(x) >= integer(y)));
	case T_RATIO:   return(make_boolean(sc, fraction(x) >= fraction(y)));
	case T_REAL:    return(make_boolean(sc, real(x) >= real(y)));
	}
    }
#endif

  switch (type(x))
    {
    case T_INTEGER:
      switch (type(y))
	{
	case T_INTEGER:
	  return(make_boolean(sc, integer(x) >= integer(y)));
	  break;
	  
	case T_RATIO: 
	  return(g_greater_or_equal(sc, args));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) >= real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->GEQ, args);
	  return(wrong_type_argument(sc, sc->GEQ, small_int(2), y, T_REAL));	  
	}
      break;
      
    case T_RATIO:
      return(g_greater_or_equal(sc, args));
      break;
      
    case T_REAL:
      switch (type(y))
	{
	case T_INTEGER: 
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) >= integer(y)));
	  break;
	  
	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) >= fraction(y)));
	  break;
	  
	case T_REAL:
	  if (is_NaN(real(x))) return(sc->F);
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, real(x) >= real(y)));
	  break;

	default:
	  CHECK_METHOD(sc, y, sc->GEQ, args);
	  return(wrong_type_argument(sc, sc->GEQ, small_int(2), y, T_REAL));	  
	}
      break;

    default:
      CHECK_METHOD(sc, x, sc->GEQ, args);
      return(wrong_type_argument(sc, sc->GEQ, small_int(1), x, T_REAL));
    }

  return(sc->T);
}

static s7_pointer geq_length_ic;
static s7_pointer g_geq_length_ic(s7_scheme *sc, s7_pointer args)
{
  return(make_boolean(sc, is_false(sc, g_less_length_ic(sc, args))));
}


static s7_pointer geq_s_ic;
static s7_pointer g_geq_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int y;
  s7_pointer x;
  
  x = car(args);
  y = s7_integer(cadr(args));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) >= y));
      break;
      
    case T_RATIO:  
      if ((y >= 0) && (numerator(x) < 0))
	return(sc->F);
      if ((y <= 0) && (numerator(x) >= 0))
	return(sc->T);
      if ((y < S7_LONG_MAX) && 
	  (y > S7_LONG_MIN) && 
	  (denominator(x) < S7_LONG_MAX) && 
	  (denominator(x) > S7_LONG_MIN))
	return(make_boolean(sc, (numerator(x) >= (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) >= y));
      break;
      
    case T_REAL:    
      return(make_boolean(sc, real(x) >= y));
      break;

    default:
      CHECK_METHOD(sc, x, sc->GEQ, args);
      return(wrong_type_argument(sc, sc->GEQ, small_int(1), x, T_REAL));  
    }
  return(sc->T);
}
#endif
/* end (!WITH_GMP) */




/* ---------------------------------------- real-part imag-part ---------------------------------------- */

s7_Double s7_real_part(s7_pointer x)
{
  switch(type(x))
    {
    case T_INTEGER:     return((s7_Double)integer(x));
    case T_RATIO:       return(fraction(x));
    case T_REAL:        return(real(x));
    case T_COMPLEX:     return(real_part(x));
#if WITH_GMP
    case T_BIG_INTEGER: return((s7_Double)big_integer_to_s7_Int(big_integer(x)));
    case T_BIG_RATIO:   return((s7_Double)((long double)big_integer_to_s7_Int(mpq_numref(big_ratio(x))) / (long double)big_integer_to_s7_Int(mpq_denref(big_ratio(x)))));
    case T_BIG_REAL:    return((s7_Double)mpfr_get_d(big_real(x), GMP_RNDN));
    case T_BIG_COMPLEX: return((s7_Double)mpfr_get_d(mpc_realref(big_complex(x)), GMP_RNDN));
#endif
    }
  return(0.0);
}


s7_Double s7_imag_part(s7_pointer x)
{
  switch (type(x))
    {
    case T_COMPLEX:     return(imag_part(x));
#if WITH_GMP
    case T_BIG_COMPLEX: return((s7_Double)mpfr_get_d(mpc_imagref(big_complex(x)), GMP_RNDN));
#endif
    }
  return(0.0);
}


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"
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
    case T_RATIO:
    case T_REAL:
      return(p);

    case T_COMPLEX:
      return(make_real(sc, real_part(p)));

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
    case T_BIG_REAL:
      return(p);

    case T_BIG_COMPLEX:
      {
	s7_pointer x;
       
	NEW_CELL(sc, x);
	set_type(x, T_BIG_REAL);
	mpfr_init(big_real(x));
	mpc_real(big_real(x), big_complex(p), GMP_RNDN);
	
	return(x);
      }
#endif

    default:
      CHECK_METHOD(sc, p, sc->REAL_PART, args);
      return(simple_wrong_type_argument_with_type(sc, sc->REAL_PART, p, A_NUMBER));
    }
}


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"
  s7_pointer p;
  /* currently (imag-part nan.0) -> 0.0 ? it's true but maybe confusing */

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:   
    case T_RATIO:   
      return(small_int(0));

    case T_REAL:    
      return(real_zero);

    case T_COMPLEX: 
      return(make_real(sc, imag_part(p)));

#if WITH_GMP
    case T_BIG_INTEGER:   
    case T_BIG_RATIO:   
      return(small_int(0));

    case T_BIG_REAL:    
      return(real_zero);

    case T_BIG_COMPLEX:
      {
	s7_pointer x;
       
	NEW_CELL(sc, x);
	set_type(x, T_BIG_REAL);
	mpfr_init(big_real(x));
	mpc_imag(big_real(x), big_complex(p), GMP_RNDN);
	
	return(x);
      }
#endif

    default:       
      CHECK_METHOD(sc, p, sc->IMAG_PART, args);
      return(simple_wrong_type_argument_with_type(sc, sc->IMAG_PART, p, A_NUMBER));
    }
}



/* ---------------------------------------- numerator denominator ---------------------------------------- */

static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args)
{
  #define H_numerator "(numerator rat) returns the numerator of the rational number rat"
  s7_pointer x;

  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_big_integer(sc, mpq_numref(big_ratio(x))));
#endif

    case T_REAL:
    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->NUMERATOR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->NUMERATOR, x, A_RATIONAL));
    }
}


static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
{
  #define H_denominator "(denominator rat) returns the denominator of the rational number rat"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_RATIO:
      return(make_integer(sc, denominator(x)));
      
    case T_INTEGER:
      return(small_int(1));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(small_int(1));

    case T_BIG_RATIO:
      return(mpz_to_big_integer(sc, mpq_denref(big_ratio(x))));
#endif

    case T_REAL:
    case T_COMPLEX:
    default:
      CHECK_METHOD(sc, x, sc->DENOMINATOR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->DENOMINATOR, x, A_RATIONAL));
    }
}


/* ---------------------------------------- nan? infinite? ---------------------------------------- */

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"
  /* s7 thinks a NaN is a real. */
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(sc->F);
	  
    case T_REAL:
      return(make_boolean(sc, is_NaN(real(x))));
	  
    case T_COMPLEX:
      return(make_boolean(sc, (is_NaN(real_part(x))) || (is_NaN(imag_part(x)))));

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
      return(sc->F);

    case T_BIG_REAL:
      return(make_boolean(sc, is_NaN(s7_real_part(x))));

    case T_BIG_COMPLEX:
      return(make_boolean(sc, (is_NaN(s7_real_part(x))) || (is_NaN(s7_imag_part(x)))));
#endif

    default:
      CHECK_METHOD(sc, x, sc->NANP, args);
      return(sc->F);
    }
}


static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args) 
{
  #define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real"
  s7_pointer x;
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(sc->F);

    case T_REAL:
      return(make_boolean(sc, is_inf(real(x))));

    case T_COMPLEX:
      return(make_boolean(sc, (is_inf(real_part(x))) || (is_inf(imag_part(x)))));

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
      return(sc->F);

    case T_BIG_REAL:
      return(make_boolean(sc, mpfr_inf_p(big_real(x)) != 0));

    case T_BIG_COMPLEX:
      return(make_boolean(sc, 
			  (mpfr_inf_p(big_real(g_real_part(sc, args))) != 0) ||
			  (mpfr_inf_p(big_real(g_imag_part(sc, args))) != 0)));
#endif

    default:
      CHECK_METHOD(sc, x, sc->INFINITEP, args);
      return(sc->F);
    }
}




/* ---------------------------------------- number? complex? integer? 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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_number, sc->NUMBERP, args);
  /* return(make_boolean(sc, s7_is_number(car(args))));  */  /* we need the s7_* versions here for the GMP case */
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_integer, sc->INTEGERP, args);
  /* return(make_boolean(sc, s7_is_integer(car(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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_real, sc->REALP, args);
  /* return(make_boolean(sc, s7_is_real(car(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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_number, sc->COMPLEXP, args);
  /* return(make_boolean(sc, s7_is_number(car(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)"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_rational, sc->RATIONALP, args);
  /* return(make_boolean(sc, s7_is_rational(car(args)))); */

  /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t
   *  and similarly for exact? etc.
   */
}


/* ---------------------------------------- even? odd?---------------------------------------- */

static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args)
{
  #define H_is_even "(even? int) returns #t if the integer int is even"
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      return(make_boolean(sc, ((integer(p) & 1) == 0)));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(make_boolean(sc, mpz_even_p(big_integer(p))));
#endif

    default:
      CHECK_METHOD(sc, p, sc->EVENP, args);
      return(simple_wrong_type_argument(sc, sc->EVENP, p, T_INTEGER));
    }

  /* extension to gaussian integers: odd if a+b is odd? */
}


static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args)
{
  #define H_is_odd "(odd? int) returns #t if the integer int is odd"
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      return(make_boolean(sc, ((integer(p) & 1) == 1)));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(make_boolean(sc, mpz_odd_p(big_integer(p))));
#endif  

    default:
      CHECK_METHOD(sc, p, sc->ODDP, args);
      return(simple_wrong_type_argument(sc, sc->ODDP, p, T_INTEGER));
    }
}



/* ---------------------------------------- zero? positive? negative? ---------------------------------------- */

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"
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_INTEGER: 
      return(make_boolean(sc, integer(x) == 0));

    case T_REAL:    
      return(make_boolean(sc, real(x) == 0.0));

    case T_RATIO:
    case T_COMPLEX:
      /* ratios and complex numbers are already collapsed into integers and reals */
      return(sc->F);

#if WITH_GMP
    case T_BIG_INTEGER:
      return(make_boolean(sc, mpz_cmp_ui(big_integer(x), 0) == 0));

    case T_BIG_REAL:
      return(make_boolean(sc, mpfr_zero_p(big_real(x))));

    case T_BIG_RATIO:
    case T_BIG_COMPLEX:
      return(sc->F);
#endif

    default:
      CHECK_METHOD(sc, x, sc->ZEROP, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ZEROP, x, A_NUMBER));
    }
}


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)"
  s7_pointer x;
  
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER: 
      return(make_boolean(sc, integer(x) > 0));

    case T_RATIO:   
      return(make_boolean(sc, numerator(x) > 0));

    case T_REAL:    
      return(make_boolean(sc, real(x) > 0.0));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(make_boolean(sc, (mpz_cmp_ui(big_integer(x), 0) > 0)));

    case T_BIG_RATIO:
      return(make_boolean(sc, (mpq_cmp_ui(big_ratio(x), 0, 1) > 0)));

    case T_BIG_REAL:
      return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) > 0)));
#endif

    default:       
      CHECK_METHOD(sc, x, sc->POSITIVEP, args);
      return(simple_wrong_type_argument(sc, sc->POSITIVEP, x, T_REAL));
    }
}


#if (!WITH_GMP)
static s7_pointer is_negative_length;
static s7_pointer g_is_negative_length(s7_scheme *sc, s7_pointer args)
{
  s7_pointer val;
  val = finder(sc, cadar(args));

  switch (type(val))
    {
    case T_PAIR:
      return(make_boolean(sc, s7_list_length(sc, val) < 0));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
    case T_NIL:
    case T_STRING:
    case T_HASH_TABLE:
      return(sc->F);

    case T_ENVIRONMENT:
    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(val)) /* this is a special case */
	{
	  s7_pointer func;
	  func = find_method(sc, find_environment(sc, val), sc->LENGTH);
	  if (func != sc->UNDEFINED)
	    return(make_boolean(sc, s7_integer(s7_apply_function(sc, func, list_1(sc, val))) < 0));
	}
      return(sc->F);

    case T_C_OBJECT:
      return(make_boolean(sc, object_length_to_int(sc, val) < 0));

    default:
      return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, val, make_protected_string(sc, "a list, vector, string, or hash-table")));
    }
  return(sc->F);
}
#endif


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)"
  s7_pointer x;
  
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER: 
      return(make_boolean(sc, integer(x) < 0));

    case T_RATIO:   
      return(make_boolean(sc, numerator(x) < 0));

    case T_REAL:    
      return(make_boolean(sc, real(x) < 0.0));

#if WITH_GMP
    case T_BIG_INTEGER:
      return(make_boolean(sc, (mpz_cmp_ui(big_integer(x), 0) < 0)));

    case T_BIG_RATIO:
      return(make_boolean(sc, (mpq_cmp_ui(big_ratio(x), 0, 1) < 0)));

    case T_BIG_REAL:
      return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) < 0)));
#endif

    default:        
      CHECK_METHOD(sc, x, sc->NEGATIVEP, args);
      return(simple_wrong_type_argument(sc, sc->NEGATIVEP, x, T_REAL));
    }
}


#if (!WITH_GMP)
/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */

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"
  return(exact_to_inexact(sc, car(args)));
}


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"
  return(inexact_to_exact(sc, car(args), WITH_OVERFLOW_ERROR));
}

#endif
/* (!WITH_GMP) */


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)"
  s7_pointer x;
  
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(sc->T);

    case T_REAL:
    case T_COMPLEX:
      return(sc->F);

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
      return(sc->T);

    case T_BIG_REAL:
    case T_BIG_COMPLEX:
      return(sc->F);
#endif

    default:
      CHECK_METHOD(sc, x, sc->EXACTP, args);
      return(simple_wrong_type_argument_with_type(sc, sc->EXACTP, x, A_NUMBER));
    }
}


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)"
  s7_pointer x;
  
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
    case T_RATIO:
      return(sc->F);

    case T_REAL:
    case T_COMPLEX:
      return(sc->T);

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
      return(sc->F);

    case T_BIG_REAL:
    case T_BIG_COMPLEX:
      return(sc->T);
#endif

    default:
      CHECK_METHOD(sc, x, sc->INEXACTP, args);
      return(simple_wrong_type_argument_with_type(sc, sc->INEXACTP, x, A_NUMBER));
    }
}


bool s7_is_ulong(s7_pointer arg) 
{
  return(is_integer(arg));
}


unsigned long s7_ulong(s7_pointer p) 
{
  return(p->object.number.ul_value);
}


s7_pointer s7_make_ulong(s7_scheme *sc, unsigned long n) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_INTEGER);
  x->object.number.ul_value = n;
  return(x);
}


bool s7_is_ulong_long(s7_pointer arg) 
{
  return(is_integer(arg));
}


unsigned long long s7_ulong_long(s7_pointer p) 
{
  return(p->object.number.ull_value);
}


s7_pointer s7_make_ulong_long(s7_scheme *sc, unsigned long long n) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_INTEGER);
  x->object.number.ull_value = n;
  return(x);
}


/* ---------------------------------------- integer-length, integer-decode-float ---------------------------------------- */

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 (abs arg) 2))"
  s7_Int x;
  s7_pointer p;

  p = car(args);
  if (!s7_is_integer(p))
    {
      CHECK_METHOD(sc, p, sc->INTEGER_LENGTH, args);
      return(simple_wrong_type_argument(sc, sc->INTEGER_LENGTH, p, T_INTEGER));
    }

  x = s7_integer(p);
  if (x < 0)
    return(make_integer(sc, integer_length(-(x + 1))));
  return(make_integer(sc, integer_length(x)));
}


#if WITH_GMP
typedef struct decode_float_t {
  union {
    s7_Int integer_value;
    s7_Double real_value;
  } value;
} decode_float_t;
#endif

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)"

  s7_Int ix;
  s7_pointer x;
  x = car(args);

  /* frexp doesn't work in edge cases.  Since the double and long long int fields are equivalenced
   *   in the s7_num struct, we can get the actual bits of the double from the int.  The problem with doing this
   *   is that bignums don't use that struct.  Assume IEEE 754 and double = s7_Double.
   */

  switch (type(x))
    {
    case T_REAL:
      if (real(x) == 0.0)
	return(list_3(sc, small_int(0), small_int(0), small_int(1)));
      ix = integer(x);
      break;

#if WITH_GMP
    case T_BIG_REAL:
      {
	decode_float_t num;
	num.value.real_value = s7_number_to_real(sc, x);
	if ((is_NaN(num.value.real_value)) || (is_inf(num.value.real_value)))   /* (integer-decode-float (bignum "1e310")) */
	  return(simple_out_of_range(sc, sc->INTEGER_DECODE_FLOAT, x, "a real that s7_Double can handle"));
	ix = num.value.integer_value;
	break;
      }
#endif

    default:
      CHECK_METHOD(sc, x, sc->INTEGER_DECODE_FLOAT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->INTEGER_DECODE_FLOAT, x, make_protected_string(sc, "a non-rational real")));
    }

  return(list_3(sc,
		make_integer(sc, (s7_Int)((ix & 0xfffffffffffffLL) | 0x10000000000000LL)),
		make_integer(sc, (s7_Int)(((ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)),
		make_integer(sc, ((ix & 0x8000000000000000LL) != 0) ? -1 : 1)));
}


/* ---------------------------------------- logand, logior, logxor, lognot, logbit?, ash ---------------------------------------- */

static s7_pointer g_logior(s7_scheme *sc, s7_pointer args)
{
  #define H_logior "(logior int ...) returns the bitwise OR of its integer arguments (the bits that are on in any of the arguments)"
  s7_Int result = 0;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    if (!s7_is_integer(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->LOGIOR, args);
	return(wrong_type_argument_n(sc, sc->LOGIOR, position_of(x, args), car(x), T_INTEGER));
      }
    else result |= s7_integer(car(x));

  return(make_integer(sc, result));
}


static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args)
{
  #define H_logxor "(logxor int ...) returns the bitwise XOR of its integer arguments (the bits that are on in an odd number of the arguments)"
  s7_Int result = 0;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    if (!s7_is_integer(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->LOGXOR, args);
	return(wrong_type_argument_n(sc, sc->LOGXOR, position_of(x, args), car(x), T_INTEGER));
      }
    else result ^= s7_integer(car(x));

  return(make_integer(sc, result));
}


static s7_pointer g_logand(s7_scheme *sc, s7_pointer args)
{
  #define H_logand "(logand int ...) returns the bitwise AND of its integer arguments (the bits that are on in every argument)"
  s7_Int result = -1;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    if (!s7_is_integer(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->LOGAND, args);
	return(wrong_type_argument_n(sc, sc->LOGAND, position_of(x, args), car(x), T_INTEGER));
      }
    else result &= s7_integer(car(x));

  return(make_integer(sc, result));
}


static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args)
{
  #define H_lognot "(lognot num) returns the bitwise negation (the complement, the bits that are not on) in num: (lognot 0) -> -1"
  if (!s7_is_integer(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->LOGNOT, args);
      return(simple_wrong_type_argument(sc, sc->LOGNOT, car(args), T_INTEGER));
    }
  return(make_integer(sc, ~s7_integer(car(args))));
}


/* 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))))."

  s7_pointer x, y;
  s7_Int index;      /* index in gmp is mp_bitcnt which is an unsigned long int */

  x = car(args);
  y = cadr(args);

  if (!s7_is_integer(y))
    {
      CHECK_METHOD(sc, y, sc->LOGBITP, args);
      return(wrong_type_argument(sc, sc->LOGBITP, small_int(2), y, T_INTEGER));
    }
  index = s7_integer(y);
  if (index < 0)
    return(out_of_range(sc, sc->LOGBITP, small_int(2), y, "index must be non-negative"));

#if WITH_GMP
  if (type(x) == T_BIG_INTEGER)
    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.
   */

  if (!s7_is_integer(x))
    {
      CHECK_METHOD(sc, x, sc->LOGBITP, args);
      return(wrong_type_argument(sc, sc->LOGBITP, small_int(1), x, T_INTEGER));
    }
  /* all these long long ints are necessary, else C turns it into an int, gets confused about signs etc */
  return(make_boolean(sc, ((((long long int)(1LL << (long long int)index)) & (long long int)integer(x)) != 0)));
}


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"
  s7_Int arg1, arg2;
  s7_pointer x, y;

  x = car(args);
  if (!s7_is_integer(x))
    {
      CHECK_METHOD(sc, x, sc->ASH, args);
      return(wrong_type_argument(sc, sc->ASH, small_int(1), x, T_INTEGER));
    }
  y = cadr(args);
  if (!s7_is_integer(y))
    {
      CHECK_METHOD(sc, y, sc->ASH, args);
      return(wrong_type_argument(sc, sc->ASH, small_int(2), y, T_INTEGER));
    }
  arg1 = s7_integer(x);
  if (arg1 == 0) return(small_int(0));

  arg2 = s7_integer(y);
  if (arg2 >= s7_int_bits)
    return(out_of_range(sc, sc->ASH, small_int(2), cadr(args), "shift is too large"));

  if (arg2 < -s7_int_bits)
    {
      if (arg1 < 0)                      /* (ash -31 -100) */
	return(make_integer(sc, -1));
      return(small_int(0));
    }

  /* I can't see any point in protecting this:
   *    (ash 9223372036854775807 1) -> -2
   * but anyone using ash must know something about bits...
   */
  if (arg2 >= 0)
    return(make_integer(sc, arg1 << arg2));
  return(make_integer(sc, arg1 >> -arg2));
}


/* ---------------------------------------- random ---------------------------------------- */

/* 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
 *     (make-random-state seed) -> make a new state
 *     (make-random-state seed type) ??
 *   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 int rng_tag = 0;

#if WITH_GMP
static int big_rng_tag = 0;
#endif

static char *print_rng(s7_scheme *sc, void *val)
{
  char *buf;
  s7_rng_t *r = (s7_rng_t *)val;
  buf = (char *)malloc(64 * sizeof(char));
  snprintf(buf, 64, "#<rng %d %d>", (unsigned int)(r->ran_seed), (unsigned int)(r->ran_carry));
  return(buf);
}


static char *print_rng_readably(s7_scheme *sc, void *val)
{
  char *buf;
  s7_rng_t *r = (s7_rng_t *)val;
  buf = (char *)malloc(64 * sizeof(char));
  snprintf(buf, 64, "(make-random-state %d %d)", (unsigned int)(r->ran_seed), (unsigned int)(r->ran_carry));
  return(buf);
}


static void free_rng(void *val)
{
  free(val);
}


static bool equal_rng(void *val1, void *val2)
{
  s7_rng_t *r1 = (s7_rng_t *)val1;
  s7_rng_t *r2 = (s7_rng_t *)val2;

  return((val1 == val2) ||
	 ((r1->ran_seed == r2->ran_seed) &&
	  (r1->ran_carry == r2->ran_carry)));
}


s7_pointer s7_make_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_make_random_state "(make-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 (make-random-state 1234))) (random 1.0 seed))"

  s7_rng_t *r;

  if (!(s7_is_integer(car(args))))
    {
      CHECK_METHOD(sc, car(args), sc->MAKE_RANDOM_STATE, args);
      return(wrong_type_argument(sc, sc->MAKE_RANDOM_STATE, small_int(1), car(args), T_INTEGER));
    }
  if (is_null(cdr(args)))
    {
      r = (s7_rng_t *)calloc(1, sizeof(s7_rng_t));
      r->ran_seed = s7_integer(car(args));
      r->ran_carry = 1675393560;  /* should this be dependent on the seed? */
      return(s7_make_object(sc, rng_tag, (void *)r));
    }

  if (!(s7_is_integer(cadr(args))))
    {
      CHECK_METHOD(sc, cadr(args), sc->MAKE_RANDOM_STATE, args);
      return(wrong_type_argument(sc, sc->MAKE_RANDOM_STATE, small_int(2), cadr(args), T_INTEGER));
    }
  r = (s7_rng_t *)calloc(1, sizeof(s7_rng_t));
  r->ran_seed = s7_integer(car(args));
  r->ran_carry = s7_integer(cadr(args));
  return(s7_make_object(sc, rng_tag, (void *)r));
}


static s7_pointer copy_random_state(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_type(obj) == rng_tag)
    {
      s7_rng_t *r, *new_r;
      r = (s7_rng_t *)s7_object_value(obj);
      new_r = (s7_rng_t *)calloc(1, sizeof(s7_rng_t));
      new_r->ran_seed = r->ran_seed;
      new_r->ran_carry = r->ran_carry;
      return(s7_make_object(sc, rng_tag, (void *)new_r));
    }
  /* I can't find a way to copy a gmp random generator */
  return(sc->F);
}


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 make-random-state)."
  s7_pointer obj;
  obj = car(args);
  if (is_c_object(obj))
    {
      if (c_object_type(obj) == rng_tag) 
	return(sc->T);
#if WITH_GMP
      if (c_object_type(obj) == big_rng_tag)
	return(sc->T);
#endif      
    }
  CHECK_METHOD(sc, obj, sc->RANDOM_STATEP, args);
  return(sc->F);
}


static double next_random(s7_rng_t *r)
{
  /* 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) 
   */
  double result;
  unsigned long long int temp;
  #define RAN_MULT 2131995753UL

  temp = r->ran_seed * RAN_MULT + r->ran_carry;
  r->ran_seed = (temp & 0xffffffffUL);
  r->ran_carry = (temp >> 32);
  result = (double)((unsigned int)(r->ran_seed)) / 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?
   */

  /* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */
  return(result);
}


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 make-random-state to this list to continue a random number sequence from any point."

  s7_rng_t *r = NULL;
  s7_pointer obj;
  if (is_null(args))
    r = sc->default_rng;
  else
    {
      obj = car(args);
      if ((!is_c_object(obj)) ||
	  (c_object_type(obj) != rng_tag))
	{
	  CHECK_METHOD(sc, obj, sc->RANDOM_STATE_TO_LIST, args);
	  return(wrong_type_argument_with_type(sc, sc->RANDOM_STATE_TO_LIST, small_int(1), obj, 
					       make_protected_string(sc, "a random state as returned by make-random-state")));
	}
	r = (s7_rng_t *)s7_object_value(obj);
    }
  
  if (r)
    return(list_2(sc, 
		  make_integer(sc, r->ran_seed), 
		  make_integer(sc, r->ran_carry)));
  return(sc->F);
}


void s7_set_default_random_state(s7_scheme *sc, s7_Int seed, s7_Int carry)
{
  if (sc->default_rng) free(sc->default_rng);
  sc->default_rng = (s7_rng_t *)calloc(1, sizeof(s7_rng_t));
  (sc->default_rng)->ran_seed = (unsigned long long)seed;
  (sc->default_rng)->ran_carry = (unsigned long long)carry;
}


s7_Double s7_random(s7_scheme *sc, s7_pointer state)
{
  if (!state)
    return(next_random(sc->default_rng));
  return(next_random((s7_rng_t *)s7_object_value(state)));
}


static s7_pointer g_random(s7_scheme *sc, s7_pointer args)
{
  #define H_random "(random num (state #f)) returns a random number between 0 and num (0 if num=0)."
  s7_pointer num, state;
  s7_rng_t *r;

  if (is_not_null(cdr(args)))
    {
      state = cadr(args);
      if (!is_c_object(state))
	{
	  CHECK_METHOD(sc, state, sc->RANDOM, args);
	  return(wrong_type_argument_with_type(sc, sc->RANDOM, small_int(2), state, 
					       make_protected_string(sc, "a random state as returned by make-random-state")));
	}
      if (c_object_type(state) == rng_tag)
	r = (s7_rng_t *)s7_object_value(state);
      else
	{
#if WITH_GMP
	  if (c_object_type(state) == big_rng_tag)
	    return(big_random(sc, args));
#endif
	  return(wrong_type_argument_with_type(sc, sc->RANDOM, small_int(2), state, 
					       make_protected_string(sc, "a random state as returned by make-random-state")));
	}
    }
  else r = sc->default_rng;

  num = car(args);
  switch (type(num))
    {
    case T_INTEGER:
      return(make_integer(sc, (s7_Int)(integer(num) * next_random(r))));

    case T_RATIO:
      {
	s7_Double x, 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
	 */
	x = fraction(num);
	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 
		  {
		    long long int diff;
		    numer = numerator(num);
		    diff = S7_LLONG_MAX - denominator(num);
		    if (diff < 100)
		      return(s7_make_ratio(sc, numer, denominator(num)));
		    denom = denominator(num) + (s7_Int)floor(diff * next_random(r));
		    return(s7_make_ratio(sc, numer, denom));
		  }
	      }
	    return(s7_make_ratio(sc, numer, denominator(num)));
	  }
	if ((x < 1e-6) && (x > -1e-6))
	  error = 1e-18;
	else error = 1e-12;
	c_rationalize(x * next_random(r), error, &numer, &denom);
	return(s7_make_ratio(sc, numer, denom));
      }

    case T_REAL:
      return(make_real(sc, real(num) * next_random(r)));

    case T_COMPLEX:
      return(s7_make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r)));

    default:
      CHECK_METHOD(sc, num, sc->RANDOM, args);
      return(wrong_type_argument_with_type(sc, sc->RANDOM, small_int(1), num, A_NUMBER));
    }
  return(sc->F);
}


#if (!WITH_GMP)
static s7_pointer random_ic, random_rc;

static s7_pointer g_random_ic(s7_scheme *sc, s7_pointer args)
{
  return(make_integer(sc, (s7_Int)(integer(car(args)) * next_random(sc->default_rng))));
}

static s7_pointer g_random_rc(s7_scheme *sc, s7_pointer args)
{
  return(make_real(sc, real(car(args)) * next_random(sc->default_rng)));
}

static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 1)
    {
      if (s7_is_integer(cadr(expr)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(random_ic);
	}
      if ((is_real(cadr(expr))) &&
	  (!is_rational(cadr(expr))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(random_rc);
	}
    }
  return(f);
}
#endif




/* -------------------------------- characters -------------------------------- */

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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_TO_INTEGER, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_TO_INTEGER, car(args), T_CHARACTER));
    }
  return(small_int(character(car(args))));
}


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"
  s7_pointer x;
  s7_Int ind;                   /* not int here!  (integer->char (expt 2 32)) -> #\null */
  x = car(args);

  if (!s7_is_integer(x))
    {
      CHECK_METHOD(sc, x, sc->INTEGER_TO_CHAR, args);
      return(simple_wrong_type_argument(sc, sc->INTEGER_TO_CHAR, x, T_INTEGER));
    }
  ind = s7_integer(x);
  if ((ind < 0) || (ind >= NUM_CHARS))
    return(simple_wrong_type_argument_with_type(sc, sc->INTEGER_TO_CHAR, x, make_protected_string(sc, "an integer that can represent a character")));

  return(s7_make_character(sc, (unsigned char)ind));
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_UPCASE, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_UPCASE, car(args), T_CHARACTER));
    }

  return(s7_make_character(sc, upper_character(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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_DOWNCASE, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_DOWNCASE, car(args), T_CHARACTER));
    }
  return(s7_make_character(sc, lower_character(car(args))));
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_ALPHABETICP, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_ALPHABETICP, car(args), T_CHARACTER));
    }
  return(make_boolean(sc, alphabetic_p(car(args))));

  /* isalpha returns #t for (integer->char 226) and others in that range */
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_NUMERICP, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_NUMERICP, car(args), T_CHARACTER));
    }
  return(make_boolean(sc, numeric_p(car(args))));
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_WHITESPACEP, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_WHITESPACEP, car(args), T_CHARACTER));
    }
  return(make_boolean(sc, whitespace_p(car(args))));
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_UPPER_CASEP, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_UPPER_CASEP, car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_p(car(args))));
}


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"
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_LOWER_CASEP, args);
      return(simple_wrong_type_argument(sc, sc->CHAR_LOWER_CASEP, car(args), T_CHARACTER));
    }
  return(make_boolean(sc, lower_p(car(args))));
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_character, sc->CHARP, args);
}


s7_pointer s7_make_character(s7_scheme *sc, unsigned int c) 
{
  return(chars[c]);
}


bool s7_is_character(s7_pointer p) 
{ 
  return(type(p) == T_CHARACTER);
}


char s7_character(s7_pointer p)  
{ 
  return(character(p));
}


static int charcmp(unsigned char c1, unsigned char 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 s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x;
  unsigned char last_chr;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!s7_is_character(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_CHARACTER));
      }
  last_chr = character(car(args));
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (charcmp(last_chr, character(car(x))) != val)
	return(sc->F);
      last_chr = character(car(x));
    }
  return(sc->T);
}


static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x;
  unsigned char last_chr;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!s7_is_character(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_CHARACTER));
      }
  last_chr = character(car(args));
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (charcmp(last_chr, character(car(x))) == val)
	return(sc->F);
      last_chr = character(car(x));
    }
  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"

  s7_pointer x, y;
  bool result = true;
  
  y = car(args);
  if (!s7_is_character(y))
    {
      CHECK_METHOD(sc, y, sc->CHAR_EQ, args);
      return(wrong_type_argument_n(sc, sc->CHAR_EQ, 1, y, T_CHARACTER));
    }
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (car(x) != y)
	{
	  result = false;
	  if (!s7_is_character(car(x)))
	    {
	      CHECK_METHOD(sc, car(x), sc->CHAR_EQ, args);
	      return(wrong_type_argument_n(sc, sc->CHAR_EQ, position_of(x, args), car(x), T_CHARACTER));
	    }
	}
    }
  return((result) ? sc->T : sc->F);
}	


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"
  return(g_char_cmp(sc, args, -1, sc->CHAR_LT));
}	


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"
  return(g_char_cmp(sc, args, 1, sc->CHAR_GT));
}


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"
  return(g_char_cmp_not(sc, args, -1, sc->CHAR_GEQ));
}	


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"
  return(g_char_cmp_not(sc, args, 1, sc->CHAR_LEQ));
}


static s7_pointer char_equal_s_ic, char_equal_2;
static s7_pointer g_char_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_pointer c;
  c = finder(sc, car(args));
  if (c == cadr(args))
    return(sc->T);
  if (!s7_is_character(c))
    {
      CHECK_METHOD(sc, c, sc->CHAR_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_EQ, small_int(1), c, T_CHARACTER));
    }
  return(sc->F);
}

static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_EQ, small_int(1), car(args), T_CHARACTER));
    }
  if (car(args) == cadr(args))
    return(sc->T);
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_EQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(sc->F);
}


static s7_pointer char_less_s_ic, char_less_2;
static s7_pointer g_char_less_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_LT, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}

static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_LT, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_LT, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}


static s7_pointer char_greater_s_ic, char_greater_2;
static s7_pointer g_char_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_GT, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}

static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_GT, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_GT, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}


static s7_pointer char_geq_s_ic, char_geq_2;
static s7_pointer g_char_geq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_GEQ, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) >= character(cadr(args))));
}

static s7_pointer g_char_geq_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_GEQ, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_GEQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) >= character(cadr(args))));
}


static s7_pointer char_leq_s_ic, char_leq_2;
static s7_pointer g_char_leq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_LEQ, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) <= character(cadr(args))));
}

static s7_pointer g_char_leq_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_LEQ, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_LEQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, character(car(args)) <= character(cadr(args))));
}


static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x;
  unsigned char last_chr;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!s7_is_character(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_CHARACTER));
      }
  last_chr = upper_character(car(args));
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (charcmp(last_chr, upper_character(car(x))) != val)
	return(sc->F);
      last_chr = upper_character(car(x));
    }
  return(sc->T);
}


static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x;
  unsigned char last_chr;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!s7_is_character(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_CHARACTER));
      }
  last_chr = upper_character(car(args));
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (charcmp(last_chr, upper_character(car(x))) == val)
	return(sc->F);
      last_chr = upper_character(car(x));
    }
  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"
  return(g_char_cmp_ci(sc, args, 0, sc->CHAR_CI_EQ));
}


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"
  return(g_char_cmp_ci(sc, args, -1, sc->CHAR_CI_LT));
}	


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"
  return(g_char_cmp_ci(sc, args, 1, sc->CHAR_CI_GT));
}	


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"
  return(g_char_cmp_ci_not(sc, args, -1, sc->CHAR_CI_GEQ));
}


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"
  return(g_char_cmp_ci_not(sc, args, 1, sc->CHAR_CI_LEQ));
}


static s7_pointer char_ci_equal_s_ic, char_ci_equal_2;
static s7_pointer g_char_ci_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_EQ, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) == upper_character(cadr(args))));
}

static s7_pointer g_char_ci_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_EQ, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_CI_EQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_EQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) == upper_character(cadr(args))));
}


static s7_pointer char_ci_less_s_ic, char_ci_less_2;
static s7_pointer g_char_ci_less_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LT, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) < upper_character(cadr(args))));
}

static s7_pointer g_char_ci_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LT, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_CI_LT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LT, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) < upper_character(cadr(args))));
}


static s7_pointer char_ci_greater_s_ic, char_ci_greater_2;
static s7_pointer g_char_ci_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GT, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) > upper_character(cadr(args))));
}

static s7_pointer g_char_ci_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GT, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_CI_GT, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GT, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) > upper_character(cadr(args))));
}


static s7_pointer char_ci_geq_s_ic, char_ci_geq_2;
static s7_pointer g_char_ci_geq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GEQ, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) >= upper_character(cadr(args))));
}

static s7_pointer g_char_ci_geq_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GEQ, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_GEQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) >= upper_character(cadr(args))));
}


static s7_pointer char_ci_leq_s_ic, char_ci_leq_2;
static s7_pointer g_char_ci_leq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LEQ, small_int(1), car(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) <= upper_character(cadr(args))));
}

static s7_pointer g_char_ci_leq_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CHAR_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LEQ, small_int(1), car(args), T_CHARACTER));
    }
  if (!s7_is_character(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->CHAR_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->CHAR_CI_LEQ, small_int(2), cadr(args), T_CHARACTER));
    }
  return(make_boolean(sc, upper_character(car(args)) <= upper_character(cadr(args))));
}


/* non-standard, but extremely useful -- more so than all the *-ci stuff put together!
 */
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"
  const char *porig, *p, *pset;
  char c;
  s7_Int start = 0, pos, len; /* not "int" because start arg might be most-negative-fixnum */
  s7_pointer arg1, arg2;

  arg1 = car(args);
  arg2 = cadr(args);

  if (!is_string(arg2))
    return(wrong_type_argument(sc, sc->CHAR_POSITION, small_int(2), arg2, T_STRING));
  porig = string_value(arg2);

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3;
      arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(wrong_type_argument(sc, sc->CHAR_POSITION, small_int(3), arg3, T_INTEGER));

      start = s7_integer(arg3);
      if (start < 0)
	return(wrong_type_argument_with_type(sc, sc->CHAR_POSITION, small_int(3), arg3, A_NON_NEGATIVE_INTEGER));
    }

  len = string_length(arg2);
  if ((!porig) || (start >= len))
      return(sc->F);

  if (s7_is_character(arg1))
    {
      c = character(arg1);
      p = strchr((const char *)(porig + start), (int)c);
      if (p)
	return(make_integer(sc, p - porig));
      return(sc->F);
    }
  
  if (!is_string(arg1))
    return(wrong_type_argument(sc, sc->CHAR_POSITION, small_int(1), arg1, T_CHARACTER));

  if (string_length(arg1) == 0)
    return(sc->F);
  pset = string_value(arg1);

  pos = strcspn((const char *)(porig + start), (const char *)pset);
  if ((pos + start) < len)
    return(make_integer(sc, pos + start));

  return(sc->F);
}


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"
  const char *s1, *s2, *p2;
  s7_Int start = 0;
  s7_pointer s1p, s2p;

  s1p = car(args);
  s2p = cadr(args);

  if (!is_string(s1p))
    return(wrong_type_argument(sc, sc->STRING_POSITION, small_int(1), s1p, T_STRING));
  if (!is_string(s2p))
    return(wrong_type_argument(sc, sc->STRING_POSITION, small_int(2), s2p, T_STRING));

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3;
      arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(wrong_type_argument(sc, sc->STRING_POSITION, small_int(3), arg3, T_INTEGER));

      start = s7_integer(arg3);
      if (start < 0)
	return(wrong_type_argument_with_type(sc, sc->STRING_POSITION, small_int(3), arg3, A_NON_NEGATIVE_INTEGER));
    }
  
  if (string_length(s1p) == 0)
    return(sc->F);
  s1 = string_value(s1p);
  s2 = string_value(s2p);
  if (start >= string_length(s2p))
    return(sc->F);

  p2 = strstr((const char *)(s2 + start), s1);
  if (!p2) return(sc->F);
  return(make_integer(sc, p2 - s2));
}





/* -------------------------------- strings -------------------------------- */

s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, int len) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_STRING | T_SAFE_PROCEDURE); /* should this follow the malloc? */
  string_value(x) = (char *)malloc((len + 1) * sizeof(char)); 
  if (len != 0)                                             /* memcpy can segfault if string_value(x) is NULL */
    memcpy((void *)string_value(x), (void *)str, len + 1);
  else string_value(x)[0] = 0;
  string_length(x) = len;
  string_hash(x) = 0;
  string_needs_free(x) = true;
  add_string(sc, x);
  return(x);
}


static s7_pointer s7_make_terminated_string_with_length(s7_scheme *sc, const char *str, int len) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_STRING | T_SAFE_PROCEDURE); /* should this follow the malloc? */
  string_value(x) = (char *)malloc((len + 1) * sizeof(char)); 
  if (len != 0)                                             /* memcpy can segfault if string_value(x) is NULL */
    memcpy((void *)string_value(x), (void *)str, len);
  string_value(x)[len] = 0;
  string_length(x) = len;
  string_hash(x) = 0;
  string_needs_free(x) = true;
  add_string(sc, x);
  return(x);
}


static s7_pointer make_string_uncopied_with_length(s7_scheme *sc, char *str, int len) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_STRING | T_SAFE_PROCEDURE);
  string_value(x) = str;
  string_length(x) = len;
  string_hash(x) = 0;
  string_needs_free(x) = true;
  add_string(sc, x);
  return(x);
}


static s7_pointer make_protected_string(s7_scheme *sc, const char *str)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE);
  string_value(x) = (char *)str;
  string_length(x) = safe_strlen(str);
  string_hash(x) = 0;
  string_needs_free(x) = false;
  return(x);
}


static s7_pointer make_empty_string(s7_scheme *sc, int len, char fill) 
{
  /* a permanent nil_string object saved almost nothing */
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_STRING);
  
  if (fill == 0)
    string_value(x) = (char *)calloc((len + 1), sizeof(char));
  else
    {
      string_value(x) = (char *)malloc((len + 1) * sizeof(char));
      memset((void *)(string_value(x)), fill, len);
    }
  string_value(x)[len] = 0;
  string_hash(x) = 0;
  string_length(x) = len;
  string_needs_free(x) = true;
  add_string(sc, x);
  return(x);
}


s7_pointer s7_make_string(s7_scheme *sc, const char *str) 
{
  return(s7_make_string_with_length(sc, str, safe_strlen(str)));
}


static s7_pointer make_string_uncopied(s7_scheme *sc, char *str) 
{
  return(make_string_uncopied_with_length(sc, str, safe_strlen(str)));
}


static char *make_permanent_string(const char *str)
{
  char *x;
  int len;
  len = safe_strlen(str);
  x = (char *)calloc(len + 1, sizeof(char)); 
  memcpy((void *)x, (void *)str, len);
  return(x);
}


s7_pointer s7_make_permanent_string(const char *str) 
{
  /* for the symbol table which is never GC'd */
  s7_pointer x;
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  set_type(x, T_STRING | T_IMMUTABLE);
  if (str)
    {
      string_length(x) = safe_strlen(str);
      string_value(x) = (char *)calloc(string_length(x) + 1, sizeof(char)); 
      memcpy((void *)string_value(x), (void *)str, string_length(x)); 
    }
  else 
    {
      string_value(x) = NULL;
      string_length(x) = 0;
    }
  string_hash(x) = 0;
  string_needs_free(x) = false;
  return(x);
}


static s7_pointer make_temporary_string(s7_scheme *sc, const char *str, int len) 
{
  static s7_pointer tmp_str = NULL;
  static int tmp_str_size = -1;
  static char *tmp_str_chars = NULL;

  if (!tmp_str)
    {
      tmp_str = alloc_pointer();
      heap_location(tmp_str) = NOT_IN_HEAP;
      set_type(tmp_str, T_STRING | T_SAFE_PROCEDURE);
      string_hash(tmp_str) = 0;
      string_needs_free(tmp_str) = false;
    }
  if (len >= tmp_str_size)
    {
      if (len == 0)
	tmp_str_size = 8;
      else tmp_str_size = 2 * len;
      if (!tmp_str_chars)
	tmp_str_chars = (char *)malloc(tmp_str_size * sizeof(char));
      else tmp_str_chars = (char *)realloc(tmp_str_chars, tmp_str_size * sizeof(char));
      string_value(tmp_str) = tmp_str_chars;
    }

  string_length(tmp_str) = len;
  if (len > 0)
    memmove((void *)tmp_str_chars, (void *)str, len); /* not memcpy because str might be a temp string (i.e. tmp_str_chars -> itself) */
  tmp_str_chars[len] = 0;
  return(tmp_str);
}


bool s7_is_string(s7_pointer p)
{
  return(is_string(p));
}


const char *s7_string(s7_pointer p) 
{ 
  return(string_value(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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_string, sc->STRINGP, args);
}


#define MAX_STRING_LENGTH 1073741824

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)"
  s7_pointer n;
  s7_Int len;
  char fill = ' ';
  
  n = car(args);
  if (!s7_is_integer(n))
    {
      CHECK_METHOD(sc, n, sc->MAKE_STRING, args);
      return(wrong_type_argument(sc, sc->MAKE_STRING, small_int(1), n, T_INTEGER));
    }

  len = s7_integer(n);
  if (len < 0)
    return(out_of_range(sc, sc->MAKE_STRING, small_int(1), n, "a non-negative integer"));
  if (len > MAX_STRING_LENGTH)
    return(out_of_range(sc, sc->MAKE_STRING, small_int(1), n, "a reasonable integer!"));

  if (is_not_null(cdr(args))) 
    {
      if (!s7_is_character(cadr(args)))
	{
	  CHECK_METHOD(sc, cadr(args), sc->MAKE_STRING, args);
	  return(wrong_type_argument(sc, sc->MAKE_STRING, small_int(2), cadr(args), T_CHARACTER));
	}
      fill = s7_character(cadr(args));
    }
  return(make_empty_string(sc, (int)len, fill));
}


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"
  s7_pointer p;
  p = car(args);
  if (!is_string(p))
    {
      CHECK_METHOD(sc, p, sc->STRING_LENGTH, args);
      return(simple_wrong_type_argument(sc, sc->STRING_LENGTH, p, T_STRING));
    }
  return(make_integer(sc, string_length(p)));
}


unsigned int s7_string_length(s7_pointer str)
{
  return(string_length(str));
}


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(wrong_type_argument(sc, sc->STRING_REF, small_int(2), index, T_INTEGER));
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->STRING_REF, small_int(2), index, A_NON_NEGATIVE_INTEGER));
  if (ind >= string_length(strng))
    return(out_of_range(sc, sc->STRING_REF, small_int(2), index, "should be less than string length"));

  str = string_value(strng);
  return(s7_make_character(sc, ((unsigned char *)str)[ind]));
}


static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args)
{
  s7_pointer strng, index;
  char *str;
  s7_Int ind;

  #define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str"

  strng = car(args);
  if (!is_string(strng))
    {
      CHECK_METHOD(sc, strng, sc->STRING_REF, args);
      return(wrong_type_argument(sc, sc->STRING_REF, small_int(1), strng, T_STRING));
    }
  
  index = cadr(args);
  if (!s7_is_integer(index))
    return(wrong_type_argument(sc, sc->STRING_REF, small_int(2), index, T_INTEGER));
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->STRING_REF, small_int(2), index, A_NON_NEGATIVE_INTEGER));
  if (ind >= string_length(strng))
    return(out_of_range(sc, sc->STRING_REF, small_int(2), index, "should be less than string length"));

  str = string_value(strng);
  return(s7_make_character(sc, ((unsigned char *)str)[ind]));
}


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"
  
  s7_pointer x, c, index;
  char *str;
  s7_Int ind;

  x = car(args);
  if (!is_string(x))
    {
      CHECK_METHOD(sc, x, sc->STRING_SET, args);
      return(wrong_type_argument(sc, sc->STRING_SET, small_int(1), x, T_STRING));
    }

  index = cadr(args);
  if (!s7_is_integer(index))
    return(wrong_type_argument(sc, sc->STRING_SET, small_int(2), index, T_INTEGER));
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->STRING_SET, small_int(2), index, A_NON_NEGATIVE_INTEGER));
  if (ind >= string_length(x))
    return(out_of_range(sc, sc->STRING_SET, small_int(2), index, "should be less than string length"));
  str = string_value(x);

  c = caddr(args);
  if (!s7_is_character(c))
    {
      if ((is_bytevector(x)) &&
	  (s7_is_integer(c)))
	{
	  int ic;
	  ic = s7_integer(c);
	  if ((ic < 0) || (ic > 255))
	    return(wrong_type_argument_with_type(sc, sc->STRING_SET, small_int(3), c, AN_UNSIGNED_BYTE));
	  str[ind] = (char)ic;
	  return(c);
	}
      CHECK_METHOD(sc, c, sc->STRING_SET, args);
      return(wrong_type_argument(sc, sc->STRING_SET, small_int(3), c, T_CHARACTER));
    }

  str[ind] = (char)s7_character(c);
  return(c);
}

static s7_pointer string_set_ssa;
static s7_pointer g_string_set_ssa(s7_scheme *sc, s7_pointer args)
{
  /* a place-holder */
  car(sc->T3_3) = ((s7_function)fcdr(cddr(args)))(sc, caddr(args));
  car(sc->T3_1) = finder(sc, car(args));
  car(sc->T3_2) = finder(sc, cadr(args));
  return(g_string_set(sc, sc->T3_1));
}

static s7_pointer string_set_ssa_looped;
static s7_pointer g_string_set_ssa_looped(s7_scheme *sc, s7_pointer args)
{
  s7_pointer str, ind, expr, chr;
  s7_Int pos, end;
  s7_pointer stepper;
  s7_function func;
  char *str_val;

  /* incoming args: (0 str i (...)) */

  str = finder(sc, cadr(args));
  if (!is_string(str))
    return(NULL);

  stepper = car(args);
  ind = s7_slot(sc, caddr(args));
  if (slot_value(ind) != stepper)
    return(NULL);

  pos = numerator(stepper);
  end = denominator(stepper);
  if ((pos < 0) ||
      (end > string_length(str)))
    return(out_of_range(sc, sc->STRING_SET, small_int(2), ind, "should be less than the string length"));

  expr = cdddr(args);
  func = (s7_function)fcdr(expr);
  str_val = string_value(str);

  for (; pos < end; pos++)
    {
      numerator(stepper) = pos;
      chr = func(sc, car(expr));
      if (!s7_is_character(chr))
	return(wrong_type_argument(sc, sc->STRING_SET, small_int(3), chr, T_CHARACTER));
      str_val[pos] = s7_character(chr);
    }
  numerator(stepper) = end;
  return(args);
}


/* this does not give much of a speed up */
typedef struct {
  s7_pointer i_slot, j_slot, s0, s1;
  s7_Int s0_len, s1_len;
} strset_ex;

static void strset_ref(void *p)
{
  strset_ex *data = (strset_ex *)p;
  s7_Int i, j;
  i = s7_integer(slot_value(data->i_slot));
  j = s7_integer(slot_value(data->j_slot));
  if ((i >= 0) && (i < data->s0_len) &&
      (j >= 0) && (j < data->s1_len))
    string_value(data->s0)[i] = string_value(data->s1)[j];
}

static void strset_free(void *p)
{
  free(p);
}

static s7_ex *string_set_ex_parser(s7_scheme *sc, s7_pointer expr)
{
  if ((is_symbol(cadr(expr))) &&
      (is_symbol(caddr(expr))))
    {
      s7_pointer s0, iloc, val;
      s0 = finder(sc, cadr(expr));
      iloc = s7_local_slot(sc, caddr(expr));
      if ((iloc) &&
	  (is_integer(slot_value(iloc))) &&
	  (s7_is_string(s0)) &&
	  (!s7_local_slot(sc, cadr(expr))))
	{
	  val = cadddr(expr);
	  if ((is_pair(val)) &&
	      (car(val) == sc->STRING_REF) &&
	      (is_symbol(cadr(val))) &&
	      (is_symbol(caddr(val))))
	    {
	      s7_pointer s1, jloc;
	      s1 = finder(sc, cadr(val));
	      jloc = s7_local_slot(sc, caddr(val));
	      if ((jloc) &&
		  (is_integer(slot_value(jloc))) &&
		  (s7_is_string(s1)) &&
		  (!s7_local_slot(sc, cadr(val))))
		{
		  strset_ex *p;
		  s7_ex *e;
		  p = (strset_ex *)malloc(sizeof(strset_ex));
		  e = (s7_ex *)malloc(sizeof(s7_ex));
		  e->ex_free = strset_free;
		  e->ex_data = p;
		  p->s0 = s0;
		  p->s0_len = string_length(s0);
		  p->i_slot = iloc;
		  p->s1 = s1;
		  p->s1_len = string_length(s1);
		  p->j_slot = jloc;
		  e->ex_vf = strset_ref;
		  return(e);
		}
	    }
	}
    }
  return(NULL);
}


static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
  int len = 0;
  s7_pointer x, newstr;
  char *pos;
  
  if (is_null(args))
    return(s7_make_string_with_length(sc, "", 0));
  
  /* get length for new string */
  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      if (!is_string(car(x)))
	{
	  CHECK_METHOD(sc, car(x), sym, args);
	  return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_STRING));
	}
      len += string_length(car(x));
    }
  
  /* store the contents of the argument strings into the new string */
  newstr = make_empty_string(sc, len + 1, 0); 
  string_length(newstr) = len;
  for (pos = string_value(newstr), x = args; is_not_null(x); pos += string_length(car(x)), x = cdr(x)) 
    memcpy(pos, string_value(car(x)), string_length(car(x)));
  
  return(newstr);
}


static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args)
{
  #define H_string_append "(string-append str1 ...) appends all its string arguments into one string"
  return(g_string_append_1(sc, args, sc->STRING_APPEND));
}


static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args)
{
  #define H_string_copy "(string-copy str) returns a copy of its string argument"
  return(g_string_append_1(sc, args, sc->STRING_COPY));
}


static bool start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer start_and_end_args, int position, s7_Int *start, s7_Int *end)
{
  /* we assume that *start=0 and *end=length, that end is "exclusive"
   *   return true if the start/end points are not changed.
   */
  s7_pointer pstart, pend;
  s7_Int index;

  if (is_null(start_and_end_args))
    return(true);

  pstart = car(start_and_end_args);
  if (!s7_is_integer(pstart))
    {
      wrong_type_argument_n(sc, caller, position, pstart, T_INTEGER);
      return(true);
    }
      
  index = s7_integer(pstart);
  if ((index < 0) ||
      (index > *end)) /* *end == length here */
    {
      out_of_range(sc, caller, small_int(position), pstart, "should be between 0 and length");
      return(true);
    }
  *start = index;

  if (is_null(cdr(start_and_end_args)))
    return(index == 0);

  pend = cadr(start_and_end_args);
  if (!s7_is_integer(pend))
    {
      wrong_type_argument_n(sc, caller, position + 1, pend, T_INTEGER);
      return(true);
    }
  index = s7_integer(pend);
  if ((index < *start) ||
      (index > *end))
    {
      out_of_range(sc, caller, small_int(position + 1), pend, "should be between the start index and the length");
      return(true);
    }
  
  if (index == *end)
    return(*start == 0);
  *end = index;
  
  return(false);
}


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\""
  
  s7_pointer x, str;
  s7_Int start = 0, end;
  int len;
  char *s;
  
  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->SUBSTRING, args);
      return(wrong_type_argument(sc, sc->SUBSTRING, small_int(1), str, T_STRING));
    }

  end = string_length(str);
  start_and_end(sc, sc->SUBSTRING, cdr(args), 2, &start, &end);
  s = string_value(str);
  len = (int)(end - start);
  x = s7_make_string_with_length(sc, (char *)(s + start), len);
  string_value(x)[len] = 0;
  return(x);
}


static s7_pointer substring_to_temp;
static s7_pointer g_substring_to_temp(s7_scheme *sc, s7_pointer args)
{
  s7_pointer str;
  s7_Int start = 0, end;
  
  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->SUBSTRING, args);
      return(wrong_type_argument(sc, sc->SUBSTRING, small_int(1), str, T_STRING));
    }

  end = string_length(str);
  start_and_end(sc, sc->SUBSTRING, cdr(args), 2, &start, &end);

  return(make_temporary_string(sc, (const char *)(string_value(str) + start), (int)(end - start)));
}



/* (set! (substring...) ...)? -- might require allocation
 *   to implement substring_uncopied we'd need to make sure the lack of a trailing null can't confuse anyone
 *   this is also the case for read-line.
 *
 * (string=? (substring...) str) or reverse is very common 
 */


static use_write_t write_choice(s7_scheme *sc, s7_pointer arg)
{
  if (arg == sc->F) return(USE_DISPLAY);
  if (arg == sc->T) return(USE_WRITE);
  if (arg == sc->KEY_READABLE) return(USE_READABLE_WRITE);
  return(USE_WRITE_WRONG);
}

#define DONT_USE_DISPLAY(Choice) ((Choice == USE_DISPLAY) ? USE_WRITE : Choice)

static char *s7_object_to_c_string_1(s7_scheme *sc, s7_pointer obj, use_write_t use_write, int *nlen);

static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_object_to_string "(object->string obj (write #t)) returns a string representation of obj."
  use_write_t choice = USE_WRITE;
  char *str;

  if (is_not_null(cdr(args)))
    {
      choice = write_choice(sc, cadr(args));
      if (choice == USE_WRITE_WRONG)
	return(wrong_type_argument(sc, sc->OBJECT_TO_STRING, small_int(2), cadr(args), T_BOOLEAN));
    }
  /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean
   */
  str = s7_object_to_c_string_1(sc, car(args), choice, NULL);
  if (str)
    return(make_string_uncopied(sc, str));
  return(s7_make_string_with_length(sc, "", 0)); 
}


static int 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)))
   * also null or lack thereof does not say anything about the string end
   *   so we have to go by its length.
   */
  int i, len, len1, len2;
  char *str1, *str2;

  len1 = string_length(s1);
  len2 = string_length(s2);
  if (len1 > len2)
    len = len2;
  else len = len1;

  str1 = string_value(s1);
  str2 = string_value(s2);

  for (i = 0; i < len; i++)
    if ((unsigned char)(str1[i]) < (unsigned char )(str2[i]))
      return(-1);
    else
      {
	if ((unsigned char)(str1[i]) > (unsigned char)(str2[i]))
	  return(1);
      }

  if (len1 < len2) 
    return(-1);
  if (len1 > len2)
    return(1);
  return(0);
}


static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!is_string(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_STRING));
      }
  y = car(args);
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (scheme_strcmp(y, car(x)) != val)
	return(sc->F);
      y = car(x);
    }
  return(sc->T);
}


static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!is_string(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_STRING));
      }
  y = car(args);
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (scheme_strcmp(y, car(x)) == val)
	return(sc->F);
      y = car(x);
    }
  return(sc->T);
}


static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y)
{
  char *xstr, *ystr;
  unsigned int i, len;

  len = string_length(x);
  if (string_length(y) != len) 
    return(false);

  xstr = string_value(x);
  ystr = string_value(y);

  for (i = 0; i < len; i++)
    if (xstr[i] != ystr[i])
      return(false);
  return(true);
}


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"

  /* 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 x, y;
  unsigned int len;
  bool happy = true;
  char *ystr;
  
  y = car(args);
  if (!is_string(y))
    {
      CHECK_METHOD(sc, y, sc->STRING_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_EQ, small_int(1), y, T_STRING));
    }
  len = string_length(y);
  ystr = string_value(y);

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      if (y != car(x))
	{
	  if (!is_string(car(x)))
	    {
	      CHECK_METHOD(sc, x, sc->STRING_EQ, args);
	      return(wrong_type_argument_n(sc, sc->STRING_EQ, position_of(x, args), car(x), T_STRING));
	    }
	  if (happy)
	    {
	      if (string_length(car(x)) != len)
		happy = false;
	      else
		{
		  unsigned int k;
		  char *xstr;
		  xstr = string_value(car(x));
		  for (k = 0; k < len; k++)
		    if (ystr[k] != xstr[k])
		      {
			happy = false;
			break;
		      }
		}
	    }
	}
    }

  if (!happy)
    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"
  return(g_string_cmp(sc, args, -1, sc->STRING_LT));
}	


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"
  return(g_string_cmp(sc, args, 1, sc->STRING_GT));
}	


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"
  return(g_string_cmp_not(sc, args, -1, sc->STRING_GEQ));
}	


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"
  return(g_string_cmp_not(sc, args, 1, sc->STRING_LEQ));
}	


static s7_pointer string_equal_s_ic, string_equal_2;
static s7_pointer g_string_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_EQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}

static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_EQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_EQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}


static s7_pointer string_less_s_ic, string_less_2;
static s7_pointer g_string_less_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_LT, args);
      return(wrong_type_argument(sc, sc->STRING_LT, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
}

static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_LT, args);
      return(wrong_type_argument(sc, sc->STRING_LT, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_LT, args);
      return(wrong_type_argument(sc, sc->STRING_LT, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
}


static s7_pointer string_greater_s_ic, string_greater_2;
static s7_pointer g_string_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_GT, args);
      return(wrong_type_argument(sc, sc->STRING_GT, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
}

static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_GT, args);
      return(wrong_type_argument(sc, sc->STRING_GT, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_GT, args);
      return(wrong_type_argument(sc, sc->STRING_GT, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
}


static s7_pointer string_geq_s_ic, string_geq_2;
static s7_pointer g_string_geq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_GEQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) != -1));
}

static s7_pointer g_string_geq_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_GEQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_GEQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) != -1));
}


static s7_pointer string_leq_s_ic, string_leq_2;
static s7_pointer g_string_leq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_LEQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) != 1));
}

static s7_pointer g_string_leq_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_LEQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_LEQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) != 1));
}


static unsigned char uppers[256];
static void init_uppers(void)
{
  int i;
  for (i = 0; i < 256; i++)
    uppers[i] = (unsigned char)toupper(i);
}

static int 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).
   */
  int i, len, len1, len2;
  char *str1, *str2;

  len1 = string_length(s1);
  len2 = string_length(s2);
  if (len1 > len2)
    len = len2;
  else len = len1;

  str1 = string_value(s1);
  str2 = string_value(s2);

  for (i = 0; i < len; i++)
    if (uppers[(int)str1[i]] < uppers[(int)str2[i]])
      return(-1);
    else
      {
	if (uppers[(int)str1[i]] > uppers[(int)str2[i]])
	  return(1);
      }

  if (len1 < len2) 
    return(-1);
  if (len1 > len2)
    return(1);
  return(0);
}


static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2)
{
  /* same as scheme_strcmp -- watch out for unwanted sign! */
  int i, len, len2;
  char *str1, *str2;

  len = string_length(s1);
  len2 = string_length(s2);
  if (len != len2)
    return(false);

  str1 = string_value(s1);
  str2 = string_value(s2);

  for (i = 0; i < len; i++)
    if (uppers[(int)str1[i]] != uppers[(int)str2[i]])
      return(false);
  return(true);
}


static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!is_string(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_STRING));
      }
  y = car(args);
  if (val == 0)
    {
      for (x = cdr(args); is_not_null(x); x = cdr(x))
	if (!scheme_strequal_ci(y, car(x)))
	  return(sc->F);
    }
  else
    {
      for (x = cdr(args); is_not_null(x); x = cdr(x))
	{
	  if (scheme_strcasecmp(y, car(x)) != val)
	    return(sc->F);
	  y = car(x);
	}
    }
  return(sc->T);
}


static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;
  
  for (x = args; is_not_null(x); x = cdr(x))  
    if (!is_string(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_STRING));
      }
  y = car(args);
  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (scheme_strcasecmp(y, car(x)) == val)
	return(sc->F);
      y = car(x);
    }
  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"
  return(g_string_ci_cmp(sc, args, 0, sc->STRING_CI_EQ));
}	


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"
  return(g_string_ci_cmp(sc, args, -1, sc->STRING_CI_LT));
}	


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"
  return(g_string_ci_cmp(sc, args, 1, sc->STRING_CI_GT));
}	


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"
  return(g_string_ci_cmp_not(sc, args, -1, sc->STRING_CI_GEQ));
}	


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"
  return(g_string_ci_cmp_not(sc, args, 1, sc->STRING_CI_LEQ));
}	


static s7_pointer string_ci_equal_s_ic, string_ci_equal_2;
static s7_pointer g_string_ci_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_EQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strequal_ci(car(args), cadr(args))));
}

static s7_pointer g_string_ci_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_EQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_CI_EQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_EQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strequal_ci(car(args), cadr(args))));
}


static s7_pointer string_ci_less_s_ic, string_ci_less_2;
static s7_pointer g_string_ci_less_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_LT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LT, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) == -1));
}

static s7_pointer g_string_ci_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_LT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LT, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_CI_LT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LT, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) == -1));
}


static s7_pointer string_ci_greater_s_ic, string_ci_greater_2;
static s7_pointer g_string_ci_greater_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_GT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GT, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) == 1));
}

static s7_pointer g_string_ci_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_GT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GT, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_CI_GT, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GT, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) == 1));
}


static s7_pointer string_ci_geq_s_ic, string_ci_geq_2;
static s7_pointer g_string_ci_geq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GEQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) != -1));
}

static s7_pointer g_string_ci_geq_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GEQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_CI_GEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_GEQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) != -1));
}


static s7_pointer string_ci_leq_s_ic, string_ci_leq_2;
static s7_pointer g_string_ci_leq_s_ic(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LEQ, small_int(1), car(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) != 1));
}

static s7_pointer g_string_ci_leq_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->STRING_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LEQ, small_int(1), car(args), T_STRING));
    }
  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->STRING_CI_LEQ, args);
      return(wrong_type_argument(sc, sc->STRING_CI_LEQ, small_int(2), cadr(args), T_STRING));
    }
  return(make_boolean(sc, scheme_strcasecmp(car(args), cadr(args)) != 1));
}



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"
  s7_pointer x, chr;
  s7_Int start = 0, end;
  x = car(args);

  if (!is_string(x))
    {
      CHECK_METHOD(sc, x, sc->STRING_FILL, args);
      return(wrong_type_argument(sc, sc->STRING_FILL, small_int(1), x, T_STRING));
    }

  chr = cadr(args);
  if (!s7_is_character(chr))
    {
      CHECK_METHOD(sc, chr, sc->STRING_FILL, args);
      return(wrong_type_argument(sc, sc->STRING_FILL, small_int(2), chr, T_CHARACTER));
    }
  /* strlen and so on here is probably not right -- a scheme string has a length
   *   set when it is created, and (apparently) can contain an embedded 0, so its
   *   print length is not its length.
   *         char *str; char c; str = string_value(car(args)); c = character(cadr(args));
   *         int i, len = 0; if (str) len = safe_strlen(str); if (len > 0) for (i = 0; i < len; i++) str[i] = c; 
   */
  end = string_length(x);
  if (end == 0) return(chr);

  if (!is_null(cddr(args)))
    {
      start_and_end(sc, sc->STRING_FILL, cddr(args), 3, &start, &end);
      if (start == end) return(chr);
    }
  memset((void *)(string_value(x) + start), (int)character(chr), end - start);
  return(chr);
}


static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
  int i, len;
  s7_pointer x, newstr;
  
  /* get length for new string and check arg types */
  for (len = 0, x = args; is_not_null(x); len++, x = cdr(x)) 
    if (!s7_is_character(car(x)))
      {
	CHECK_METHOD(sc, car(x), sym, args);
	return(wrong_type_argument_n(sc, sym, len + 1, car(x), T_CHARACTER));
      }
  newstr = make_empty_string(sc, len, 0);
  for (i = 0, x = args; is_not_null(x); i++, x = cdr(x)) 
    string_value(newstr)[i] = character(car(x));
  
  return(newstr);
}


static s7_pointer g_string(s7_scheme *sc, s7_pointer args)
{
  #define H_string "(string chr...) appends all its character arguments into one string"
  if (is_null(args))                                /* (string) but not (string '()) */
    return(s7_make_string_with_length(sc, "", 0));
  return(g_string_1(sc, args, sc->STRING));
}


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)"
  if (is_null(car(args)))
    return(s7_make_string_with_length(sc, "", 0));
  
  if (!is_proper_list(sc, car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->LIST_TO_STRING, args);
      return(simple_wrong_type_argument_with_type(sc, sc->LIST_TO_STRING, car(args), make_protected_string(sc, "a (proper, non-circular) list of characters")));
    }
  return(g_string_1(sc, car(args), sc->LIST_TO_STRING));
}


static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, int len)
{
  int i;
  s7_pointer p;

  if (len == 0)
    return(sc->NIL);

  if (len < (sc->free_heap_top - sc->free_heap))
    {
      sc->w = s7_cons(sc, s7_make_character(sc, ((unsigned char)str[len - 1])), sc->NIL);
      for (i = len - 2; i >= 0; i--)
	sc->w = cons_unchecked(sc, s7_make_character(sc, ((unsigned char)str[i])), sc->w);
    }
  else
    {
      sc->w = sc->NIL;
      for (i = len - 1; i >= 0; i--)
	sc->w = cons(sc, s7_make_character(sc, ((unsigned char)str[i])), sc->w);
    }
  p = sc->w;
  sc->w = sc->NIL;
  return(p);
}


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)"
  s7_Int i, start = 0, end;
  s7_pointer p, str;

  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->STRING_TO_LIST, args);
      return(simple_wrong_type_argument(sc, sc->STRING_TO_LIST, str, T_STRING));
    }

  end = string_length(str);

  if (!is_null(cdr(args)))
    {
      start_and_end(sc, sc->STRING_TO_LIST, cdr(args), 2, &start, &end);
      if (start == end) return(sc->NIL);
    }
  else
    {
      if (end == 0) return(sc->NIL);
    }
  if ((start == 0) && (end == string_length(str)))
    return(s7_string_to_list(sc, string_value(str), string_length(str)));
  
  sc->w = sc->NIL;
  for (i = end - 1; i >= start; i--)
    sc->w = cons(sc, s7_make_character(sc, ((unsigned char)string_value(str)[i])), sc->w);

  p = sc->w;
  sc->w = sc->NIL;
  return(p);
}


/* -------------------------------- bytevectors -------------------------------- 
 *
 * these are just strings with the T_BYTEVECTOR bit set.
 */

static s7_pointer g_is_bytevector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_bytevector "(bytevector? obj) returns #t if obj is a bytevector"
  return(make_boolean(sc, is_string(car(args)) && is_bytevector(car(args))));
}


static s7_pointer g_to_bytevector(s7_scheme *sc, s7_pointer args)
{
  #define H_to_bytevector "(->bytevector obj) turns a string into a bytevector."
  if (!is_string(car(args)))
    return(wrong_type_argument(sc, sc->TO_BYTEVECTOR, small_int(1), car(args), T_STRING));
  set_bytevector(car(args));
  return(car(args));
}


static s7_pointer g_make_bytevector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_bytevector "(make-bytevector len (byte 0)) makes a bytevector of length len filled with byte."
  s7_pointer str;
  if (is_null(cdr(args)))
    {
      str = g_make_string(sc, args);
      memset((void *)(string_value(str)), 0, string_length(str));
    }
  else 
    {
      s7_pointer byte;
      s7_Int b;
      byte = cadr(args);
      if (!s7_is_integer(byte))
	return(wrong_type_argument(sc, sc->MAKE_BYTEVECTOR, small_int(2), byte, T_INTEGER));
      b = s7_integer(byte);
      if ((b < 0) || (b > 255))
	return(simple_wrong_type_argument_with_type(sc, sc->MAKE_BYTEVECTOR, byte, AN_UNSIGNED_BYTE));
      str = g_make_string(sc, list_2(sc, car(args), chars[b]));
    }
  set_bytevector(str);
  return(str);
}


static s7_pointer g_bytevector(s7_scheme *sc, s7_pointer args)
{
  #define H_bytevector "(bytevector ...) returns a bytevector whose elements are the arguments"
  s7_Int i, len;
  s7_pointer vec, x;
  
  len = s7_list_length(sc, args);
  vec = make_empty_string(sc, len, 0);

  for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) 
    {
      s7_pointer byte;
      s7_Int b;
      byte = car(x);
      if (!s7_is_integer(byte))
	return(wrong_type_argument(sc, sc->BYTEVECTOR, make_integer(sc, i), byte, T_INTEGER));
      b = s7_integer(byte);
      if ((b < 0) || (b > 255))
	return(simple_wrong_type_argument_with_type(sc, sc->BYTEVECTOR, byte, AN_UNSIGNED_BYTE));
      string_value(vec)[i] = (unsigned char)b;
    }
  set_bytevector(vec);
  return(vec);
}



   


/* -------------------------------- ports -------------------------------- 
 *
 * originally nil served as stdin and friends, but that made it impossible to catch an error
 *   like (read-line (current-output-port)) when the latter was stdout.  So we now have
 *   the built-in constant ports *stdin*, *stdout*, and *stderr*.  Some way is needed to
 *   refer to these directly so that (read-line *stdin*) for example can insist on reading
 *   from the terminal, or whatever stdin is.
 */

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."
  s7_pointer x;

  x = car(args);
  if ((is_input_port(x)) || (is_output_port(x)))
    return(make_boolean(sc, port_is_closed(x)));

  CHECK_METHOD(sc, x, sc->PORT_CLOSEDP, args);
  return(simple_wrong_type_argument_with_type(sc, sc->PORT_CLOSEDP, x, make_protected_string(sc, "a port")));      
}


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"
  s7_pointer x;

  if (is_null(args))
    x = sc->input_port;
  else x = car(args);

  if ((!(is_input_port(x))) ||
      (port_is_closed(x)))
    {
      CHECK_METHOD(sc, x, sc->PORT_LINE_NUMBER, args);
      return(simple_wrong_type_argument_with_type(sc, sc->PORT_LINE_NUMBER, x, AN_INPUT_PORT));
    }
  return(make_integer(sc, port_line_number(x)));
}


const char *s7_port_filename(s7_pointer x)
{
  if (((is_input_port(x)) || 
       (is_output_port(x))) &&
      (!port_is_closed(x)))
    return(port_filename(x));
  return(NULL);
}


static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args)
{
  #define H_port_filename "(port-filename file-port) returns the filename associated with port"
  s7_pointer x;

  if (is_null(args))
    x = sc->input_port;
  else x = car(args);

  if (((is_input_port(x)) ||
       (is_output_port(x))) &&
      (!port_is_closed(x)))
    {
      if (port_filename(x))
	return(make_protected_string(sc, port_filename(x)));
      return(s7_make_string_with_length(sc, "", 0));   
      /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
    }
  CHECK_METHOD(sc, x, sc->PORT_FILENAME, args);
  return(simple_wrong_type_argument_with_type(sc, sc->PORT_FILENAME, x, AN_OPEN_PORT));
}


bool s7_is_input_port(s7_scheme *sc, 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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_input_port, sc->INPUT_PORTP, args);
}


bool s7_is_output_port(s7_scheme *sc, 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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_output_port, sc->OUTPUT_PORTP, args);
}


s7_pointer s7_current_input_port(s7_scheme *sc)
{
  return(sc->input_port);
}


static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_current_input_port "(current-input-port) returns the current input port"
  return(sc->input_port);
}


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"
  s7_pointer old_port, port;

  old_port = sc->input_port;
  port = car(args);
  if ((is_input_port(port)) &&
      (!port_is_closed(port)))
    sc->input_port = port;
  else return(s7_wrong_type_arg_error(sc, "set-current-input-port", 0, port, "an open input port"));

  return(old_port);
}


s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port;
  old_port = sc->input_port;
  sc->input_port = port;
  return(old_port);
}


s7_pointer s7_current_output_port(s7_scheme *sc)
{
  return(sc->output_port);
}


s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port;
  old_port = sc->output_port;
  sc->output_port = port;
  return(old_port);
}


static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_current_output_port "(current-output-port) returns the current output port"
  return(sc->output_port);
}


static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
  s7_pointer old_port, port;

  old_port = sc->output_port;
  port = car(args);
  if ((is_output_port(port)) &&
      (!port_is_closed(port)))
    sc->output_port = port;
  else return(s7_wrong_type_arg_error(sc, "set-current-output-port", 0, port, "an open output port"));

  return(old_port);
}


s7_pointer s7_current_error_port(s7_scheme *sc)
{
  return(sc->error_port);
}


s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port)
{
  s7_pointer old_port;
  old_port = sc->error_port;
  sc->error_port = port;
  return(old_port);
}


static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer args)
{
  #define H_current_error_port "(current-error-port) returns the current error port"
  return(sc->error_port);
}


static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port"
  s7_pointer old_port, port;

  old_port = sc->error_port;
  port = car(args);
  if ((is_output_port(port)) &&
      (!port_is_closed(port)))
    sc->error_port = port;
  else return(s7_wrong_type_arg_error(sc, "set-current-error-port", 0, port, "an open output port"));

  return(old_port);
}


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"
  if (is_not_null(args))
    {
      s7_pointer pt = car(args);
      if (!is_input_port(pt))
	{
	  CHECK_METHOD(sc, pt, sc->CHAR_READYP, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->CHAR_READYP, pt, AN_INPUT_PORT));
	}
      if (port_is_closed(pt))
	return(simple_wrong_type_argument_with_type(sc, sc->CHAR_READYP, pt, AN_OPEN_PORT));

      if (is_function_port(pt))
	return((*(port_input_function(pt)))(sc, S7_IS_CHAR_READY, pt));
      return(make_boolean(sc, is_string_port(pt)));
    }
  return(make_boolean(sc, (is_input_port(sc->input_port)) && (is_string_port(sc->input_port))));
}      


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"
  s7_pointer p;
  p = car(args);
  if (p == sc->EOF_OBJECT) return(sc->T);
  CHECK_METHOD(sc, p, sc->EOF_OBJECTP, args);
  return(sc->F);
}


static int 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, int c, s7_pointer port);
static void closed_port_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port);
static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port);

void s7_close_input_port(s7_scheme *sc, s7_pointer p)
{
  if ((is_immutable(p)) ||
      ((is_input_port(p)) && (port_is_closed(p))))
    return;

  if (port_filename(p))
    {
      free(port_filename(p));
      port_filename(p) = NULL;
    }
  
  if ((is_file_port(p)) &&
      (port_file(p)))
    {
      fclose(port_file(p));
      port_file(p) = NULL;
    }

  if (port_needs_free(p))
    {
      if (port_string(p))
	{
	  free(port_string(p));
	  port_string(p) = NULL;
	  port_string_length(p) = 0;
	}
      port_needs_free(p) = false;
    }

  /* if input string, someone else is dealing with GC */
  port_read_character(p) = closed_port_read_char;
  port_read_line(p) = closed_port_read_line;
  port_write_character(p) = closed_port_write_char;
  port_write_string(p) = closed_port_write_string;
  port_display(p) = closed_port_display;
  port_is_closed(p) = true;
}


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"
  s7_pointer pt;

  pt = car(args);
  if (!is_input_port(pt))
    {
      CHECK_METHOD(sc, pt, sc->CLOSE_INPUT_PORT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->CLOSE_INPUT_PORT, pt, AN_INPUT_PORT));
    }
  if (!is_immutable(pt))
    s7_close_input_port(sc, pt);

  return(sc->UNSPECIFIED);
}


void s7_flush_output_port(s7_scheme *sc, s7_pointer p)
{
  if ((!is_output_port(p)) || 
      (is_function_port(p)) ||   /* function ports are not buffered, so flush not needed */
      (port_is_closed(p)))
    return;

  if ((is_file_port(p)) &&
      (port_file(p)))
    {
      if (port_position(p) > 0)
	fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p));
      port_position(p) = 0;
      fflush(port_file(p));
    }
  else
    {
      if ((is_string_port(p)) && 
	  (port_string(p)))
	{
	  port_string_point(p) = 0;
	  port_string(p)[0] = '\0';
	  /* does this need to be cleared throughout? */
	}
    }
}


static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_flush_output_port "(flush-output-port port) flushes the port"
  s7_pointer pt;
  
  if (is_null(args))
    pt = sc->output_port;
  else pt = car(args);

  if (!is_output_port(pt))
    {
      CHECK_METHOD(sc, pt, sc->FLUSH_OUTPUT_PORT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->FLUSH_OUTPUT_PORT, pt, AN_OUTPUT_PORT));
    }
  s7_flush_output_port(sc, pt);
  return(sc->UNSPECIFIED);
}


void s7_close_output_port(s7_scheme *sc, s7_pointer p)
{
  if ((is_immutable(p)) ||
      ((is_output_port(p)) && (port_is_closed(p))))
    return;
  
  if (port_filename(p))
    {
      free(port_filename(p));
      port_filename(p) = NULL;
    }
  
  if (is_file_port(p))
    {
      if (port_file(p))
	{
	  if (port_position(p) > 0)
	    fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p));
	  port_position(p) = 0;
	  free(port_data(p));
	  fflush(port_file(p));
	  fclose(port_file(p));
	  port_file(p) = NULL;
	}
    }
  else
    {
      if ((is_string_port(p)) && 
	  (port_string(p)))
	{
	  free(port_string(p));
	  port_string(p) = NULL;
	  port_string_length(p) = 0;
	  port_needs_free(p) = false;
	}
    }
  port_read_character(p) = closed_port_read_char;
  port_read_line(p) = closed_port_read_line;
  port_write_character(p) = closed_port_write_char;
  port_write_string(p) = closed_port_write_string;
  port_display(p) = closed_port_display;
  port_is_closed(p) = true;
}


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"
  s7_pointer pt;
  pt = car(args);
  if (!is_output_port(pt))
    {
      CHECK_METHOD(sc, pt, sc->CLOSE_OUTPUT_PORT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->CLOSE_OUTPUT_PORT, pt, AN_OUTPUT_PORT));
    }
  if (!(is_immutable(pt)))
    s7_close_output_port(sc, pt);
  return(sc->UNSPECIFIED);
}


/* -------- read character functions -------- */

static int file_read_char(s7_scheme *sc, s7_pointer port)
{
  return(fgetc(port_file(port)));
}


static int function_read_char(s7_scheme *sc, s7_pointer port)
{
  return(character((*(port_input_function(port)))(sc, S7_READ_CHAR, port)));
}


static int string_read_char(s7_scheme *sc, s7_pointer port)
{
  if (port_string_length(port) <= port_string_point(port)) /* port_string_length is 0 if no port string */
    return(EOF);
  return((unsigned char)port_string(port)[port_string_point(port)++]);
}


static int output_read_char(s7_scheme *sc, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_INPUT_PORT);
  return(0);
}


static int closed_port_read_char(s7_scheme *sc, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_OPEN_PORT);
  return(0);
}



/* -------- read line functions -------- */

static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  return(simple_wrong_type_argument_with_type(sc, sc->READ_LINE, port, AN_INPUT_PORT));
}


static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  return(simple_wrong_type_argument_with_type(sc, sc->READ_LINE, port, AN_OPEN_PORT));
}


static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  return((*(port_input_function(port)))(sc, S7_READ_LINE, port));
}


static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  if (sc->read_line_buf == NULL)
    {
      sc->read_line_buf_size = 1024;
      sc->read_line_buf = (char *)malloc(sc->read_line_buf_size * sizeof(char));
    }

  if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin) != NULL)
    return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */
  return(s7_make_string_with_length(sc, NULL, 0));
}


static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  char *buf;
  int read_size, previous_size = 0;

  if (sc->read_line_buf == NULL)
    {
      sc->read_line_buf_size = 1024;
      sc->read_line_buf = (char *)malloc(sc->read_line_buf_size * sizeof(char));
    }
  
  buf = sc->read_line_buf;
  read_size = sc->read_line_buf_size;

  while (true)
    {
      char *p, *rtn;
      size_t len;

      p = fgets(buf, read_size, port_file(port));
      if (!p)
	return(sc->EOF_OBJECT);

      rtn = strchr(buf, (int)'\n');
      if (rtn)
	{
	  port_line_number(port)++;
	  return(s7_make_terminated_string_with_length(sc, sc->read_line_buf, (with_eol) ? (previous_size + rtn - p + 1) : (previous_size + rtn - p)));
	}
      /* if no newline, then either at eof or need bigger buffer */
      len = strlen(sc->read_line_buf);

      if ((len + 1) < sc->read_line_buf_size)
	return(s7_make_terminated_string_with_length(sc, sc->read_line_buf, len));
      
      previous_size = sc->read_line_buf_size;
      sc->read_line_buf_size *= 2;
      sc->read_line_buf = (char *)realloc(sc->read_line_buf, sc->read_line_buf_size * sizeof(char));
      read_size = previous_size;
      previous_size -= 1;
      buf = (char *)(sc->read_line_buf + previous_size);
    }
  return(sc->EOF_OBJECT);
}


static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
{
  unsigned int i, port_start;
  char *port_str, *cur, *start;

  /* this string can be left uncopied if port_needs_free(port), then the sc->strings
   *   array checked when the port is closed, and any held strings copied.  But 
   *   even in a best case (make-index.scm), the savings is small.
   *
   * perhaps dont free port string until GC sweep, sweep strings ahead of ports, do the holder check just before free
   *   but this fails because FFI code (snd-xen.c) assumes strings end in null.  This will mess up uncopied substring too...
   */

  port_start = port_string_point(port);
  port_str = port_string(port);
  start = (char *)(port_str + port_start);

  cur = strchr(start, (int)'\n');
  if (cur)
      {
	port_line_number(port)++;
	i = cur - port_str;
	port_string_point(port) = i + 1;
	return(s7_make_terminated_string_with_length(sc, start, ((with_eol) ? i + 1 : i) - port_start));
      }
  i = port_string_length(port);
  port_string_point(port) = i;
  if (i <= port_start)         /* the < part can happen -- if not caught we try to create a string of length -1 -> segfault */
    return(sc->EOF_OBJECT);

  return(s7_make_terminated_string_with_length(sc, start, i - port_start));
}


/* -------- write character functions -------- */

static void string_write_char(s7_scheme *sc, int c, s7_pointer pt)
{
  if (port_string_point(pt) >= port_string_length(pt))
    {
      int loc;
      loc = port_string_length(pt);
      port_string_length(pt) *= 2;
      port_string(pt) = (char *)realloc(port_string(pt), port_string_length(pt) * sizeof(char));
      memset((void *)(port_string(pt) + loc), 0, loc);
    }
  port_string(pt)[port_string_point(pt)++] = c;
}

static void stdout_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  fputc(c, stdout);
}

static void stderr_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  fputc(c, stderr);
}

static void function_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  (*(port_output_function(port)))(sc, c, port);
}


#define PORT_DATA_SIZE 256
static void file_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  if (port_position(port) == PORT_DATA_SIZE)
    {
      fwrite((void *)(port_data(port)), 1, PORT_DATA_SIZE, port_file(port));
      port_position(port) = 0;
    }
  port_data(port)[port_position(port)++] = (unsigned char)c;
}


static void input_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE_CHAR, port, AN_OUTPUT_PORT);
}


static void closed_port_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE_CHAR, port, AN_OPEN_PORT);
}



/* -------- write string functions -------- */

static void input_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OUTPUT_PORT);
}


static void closed_port_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OPEN_PORT);
}


static void input_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OUTPUT_PORT);
}

static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->WRITE, port, AN_OPEN_PORT);
}

static void stdout_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  fputs(str, stdout);
}

static void stderr_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  fputs(str, stderr);
}

static void string_write_string(s7_scheme *sc, const char *str, int len, s7_pointer pt)
{
  int new_len;
  /* len is known to be non-zero */

  /* if (len != safe_strlen(str)) fprintf(stderr, "%d %d in %s\n", len, safe_strlen(str), str);
   */

  new_len = port_string_point(pt) + len;
  if (new_len >= (int)port_string_length(pt))
    {
      int loc;
      loc = port_string_length(pt);
      port_string_length(pt) = new_len * 2;
      port_string(pt) = (char *)realloc(port_string(pt), port_string_length(pt) * sizeof(char) + 8);
      memset((void *)(port_string(pt) + loc), 0, port_string_length(pt) + 8 - loc); 
    }

  memcpy((void *)(port_string(pt) + port_string_point(pt)), (void *)str, len);
  /* memcpy is much faster than the equivalent while loop */
  port_string_point(pt) = new_len;
}

static void file_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s)
    {
      if (port_position(port) > 0)
	{
	  fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port));
	  port_position(port) = 0;
	}
      if (fputs(s, port_file(port)) == EOF)
	fprintf(stderr, "write to %s: %s\n", port_filename(port), strerror(errno));
    }
}

static void file_write_string(s7_scheme *sc, const char *str, int len, s7_pointer pt)
{
  file_display(sc, str, pt);
}

static void string_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s)
    string_write_string(sc, s, safe_strlen(s), port);
}


static void function_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s)
    {
      for (; *s; s++)
	(*(port_output_function(port)))(sc, *s, port);
    }
}

static void function_write_string(s7_scheme *sc, const char *str, int len, s7_pointer pt)
{
  function_display(sc, str, pt);
}

static void stdout_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s) fputs(s, stdout);
}


static void stderr_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s) fputs(s, stderr);
}


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."
  s7_pointer str, port;
  s7_Int start = 0, end;

  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->WRITE_STRING, args);
      return(wrong_type_argument(sc, sc->WRITE_STRING, small_int(1), str, T_STRING));
    }

  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      port = cadr(args);
      if (!is_output_port(port))
	return(wrong_type_argument_with_type(sc, sc->WRITE_STRING, small_int(2), port, AN_OUTPUT_PORT));

      start_and_end(sc, sc->WRITE_STRING, cddr(args), 3, &start, &end);
    }
  else port = sc->output_port;

  if (start == 0)
    port_write_string(port)(sc, string_value(str), end, port);
  else port_write_string(port)(sc, (char *)(string_value(str) + start), (end - start), port);
  return(sc->UNSPECIFIED);
}



/* -------- skip to semicolon readers -------- */

static token_t file_read_semicolon(s7_scheme *sc, s7_pointer pt)
{
  int c;
  do (c = fgetc(port_file(pt))); while ((c != '\n') && (c != EOF));
  port_line_number(pt)++;
  if (c == EOF)
    return(TOKEN_EOF);
  return(token(sc));
}


static token_t string_read_semicolon(s7_scheme *sc, s7_pointer pt)
{
  const char *orig_str, *str;      
  str = (const char *)(port_string(pt) + port_string_point(pt));
  orig_str = strchr(str, (int)'\n');
  if (!orig_str)
    {
      port_string_point(pt) = port_string_length(pt);
      return(TOKEN_EOF);
    }
  port_string_point(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */
  port_line_number(pt)++;
  return(token(sc));
}


/* -------- white space readers -------- */

static int file_read_white_space(s7_scheme *sc, s7_pointer port)
{
  int c;
  while (is_white_space(c = fgetc(port_file(port))))
    if (c == '\n')
      port_line_number(port)++;
  return(c);
}

static int string_read_white_space(s7_scheme *sc, s7_pointer pt)
{
  char *orig_str, *str;
  unsigned char c1;

  if (port_string_length(pt) <= port_string_point(pt))
    return(EOF);

  str = (char *)(port_string(pt) + port_string_point(pt));

  /* we can't depend on the extra 0 of padding at the end of an input string port --
   *   eval_string and others take the given string without copying or padding.
   */
  /* half the time this is called, the initial character is not white space, but splitting that out
   *   is slower.
   */
  orig_str = str;
  while (white_space[c1 = (unsigned char)(*str++)]) /* (let ((a 1)) a) -- 255 is not -1 = EOF */
    if (c1 == '\n')
      port_line_number(pt)++;

  if (c1 == 0)
    {
      port_string_point(pt) += (str - orig_str - 1);
      return(EOF);
    }
  port_string_point(pt) += (str - orig_str);
  return((int)c1);
}


/* name (alphanumeric token) readers */

static void resize_strbuf(s7_scheme *sc)
{
  unsigned int i, old_size;
  old_size = sc->strbuf_size;
  sc->strbuf_size *= 2;
  sc->strbuf = (char *)realloc(sc->strbuf, sc->strbuf_size * sizeof(char));
  for (i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0';
}


static s7_pointer file_read_name(s7_scheme *sc, s7_pointer pt, bool atom_case)
{
  int c;
  unsigned i = 1;
  /* sc->strbuf[0] has the first char of the string we're reading */

  do {
    c = fgetc(port_file(pt)); /* might return EOF */
    if (c == '\n')
      port_line_number(pt)++;
    
    sc->strbuf[i++] = c;
    if (i >= sc->strbuf_size)
      resize_strbuf(sc);
  } while ((c != EOF) && (char_ok_in_a_name[c]));
  
  if ((i == 2) && 
      (sc->strbuf[0] == '\\'))
    sc->strbuf[2] = '\0';
  else 
    {
      if (c != EOF)
	{
	  if (c == '\n')
	    port_line_number(pt)--;
	  ungetc(c, port_file(pt));
	}
      sc->strbuf[i - 1] = '\0';
    }

  if (atom_case)
    return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));

  return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
}


#define WITH_SHARP false
#define NO_SHARP true

static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt, bool atom_case)
{
  /* sc->strbuf[0] has the first char of the string we're reading */

  unsigned int k = 0;
  char *orig_str, *str;
  
  orig_str = (char *)(port_string(pt) + port_string_point(pt) - 1);
  str = (char *)(orig_str + 1);
  
  while (char_ok_in_a_name[(unsigned char)(*str)]) {str++;}
  k = str - orig_str;

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

  port_string_point(pt) += k;
  
  if ((!atom_case) &&             /* there's a bizarre special case here \ with the next char #\null: (eval-string "(list \\\x00 1)") */
      (k == 1) && 
      (*orig_str == '\\'))
    {
      /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
      sc->strbuf[1] = orig_str[1];
      sc->strbuf[2] = '\0';
      return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
    }

  /* 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);
  
  memcpy((void *)(sc->strbuf), (void *)orig_str, k);
  if (*str != 0) port_string_point(pt)--;
  sc->strbuf[k] = '\0';

  if (atom_case)
    return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));
  return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
}


static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt, bool atom_case)
{
  /* port_string was allocated (and read from a file) so we can mess with it directly */
  s7_pointer result;
  unsigned int k = 0;
  char *orig_str, *str;
  char endc;
  
  str = (char *)(port_string(pt) + port_string_point(pt));
  orig_str = (char *)(str - 1);
  
  while (char_ok_in_a_name[(unsigned char)(*str)]) {str++;}
  k = str - orig_str;
  port_string_point(pt) += k;
  
  if (!atom_case)             /* there's a bizarre special case here \ with the next char #\null: (eval-string "(list \\\x00 1)") */
    {
      if (k == 1)
	{
	  /* most common case (#f etc)
	   */
	  if (*orig_str == '\\')
	    {
	      /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
	      sc->strbuf[1] = orig_str[1];
	      sc->strbuf[2] = '\0';
	    }
	  else
	    {
	      if (*str != 0) port_string_point(pt)--;
	      if (*orig_str == 'f') return(sc->F);
	      if (*orig_str == 't') return(sc->T);
	      sc->strbuf[0] = orig_str[0];
	      sc->strbuf[1] = '\0';
	    }
	  return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
	}
#if 0
      /* port_string was allocated (and read from a file) so we can mess with it directly 
       * but this doesn't work with *#reader* internal reads
       */
      endc = orig_str[k];
      orig_str[k] = '\0';
      if (endc != 0) port_string_point(pt)--; 
      result = make_sharp_constant(sc, orig_str, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR);
      orig_str[k] = endc;
      return(result);
#else
      if ((k + 1) >= sc->strbuf_size)
	resize_strbuf(sc);
  
      memcpy((void *)(sc->strbuf), (void *)orig_str, k);
      if (*str != 0) port_string_point(pt)--;
      sc->strbuf[k] = '\0';

      return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
#endif
    }

  endc = (*str);
  (*str) = '\0';
  
  switch (*orig_str)
    {
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
    case '.': case '+': case '-':
      result = make_atom(sc, orig_str, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR);
      break;
      
    case '#':
      result = make_sharp_constant(sc, (char *)(orig_str + 1), UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR);
      break;
      
    default:
      /* result = make_symbol(sc, orig_str); 
       *    expanded for speed
       */
      {
	int location;
	s7_pointer x; 
	unsigned int loc = 0;
	const char *c; 
	
	for (c = orig_str; *c; c++) 
	  loc = *c + loc * HASH_MULT;
	location = loc % SYMBOL_TABLE_SIZE; 
	
	result = sc->NIL;
	for (x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x)) 
	  { 
	    const char *s; 
	    s = symbol_name(car(x)); 
	    if ((s[0] == orig_str[0]) &&
		(strings_are_equal(orig_str, s)))
	      /* the string lengths here are k (for orig_str) and symbol_name_length(car(x)),
	       *   but checking that these are equal before calling strcmp is slower?!?
	       */
	      {
		result = car(x);
		break;
	      }
	  }
	if (is_null(result))
	  {
	    if (sc->symbol_table_is_locked)
	      result = sc->F;
	    else 
	      {
		result = new_symbol(sc, orig_str, location); 
		symbol_hash(result) = location; /* was loc */
	      }
	  }
      }
      break;
    }
  
  (*str) = endc;
  if (endc != 0) port_string_point(pt)--;

  /* skipping the null has one minor consequence:
   *    (let ((str "(+ 1 2 3)")) (set! (str 2) #\null) (eval-string str)) ; "(+\x001 2 3)" -> 6
   *    (let ((str "(+ 1 2 3)")) (set! (str 3) #\null) (eval-string str)) ; "(+ \x00 2 3)" -> missing paren error
   */
  return(result);
}


static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, long max_size, const char *caller)
{
  s7_pointer port;
#ifndef _MSC_VER
  long size;
#endif
  int port_loc;

  NEW_CELL(sc, port);
  port_loc = s7_gc_protect(sc, port);
  set_type(port, T_INPUT_PORT);
  port_port(port) = alloc_port(sc);
  port_is_closed(port) = false;
  port_original_input_string(port) = sc->NIL;
  port_write_character(port) = input_write_char;
  port_write_string(port) = input_write_string;

  /* if we're constantly opening files, and each open saves the file name in permanent
   *   memory, we gradually core-up.  
   */
  port_filename_length(port) = safe_strlen(name);
  port_filename(port) = copy_string_with_len(name, port_filename_length(port));
  port_line_number(port) = 1;  /* first line is numbered 1 */
  add_input_port(sc, port);

#ifndef _MSC_VER
  /* 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)))
    {
      size_t bytes;
      char *content;

      content = (char *)malloc((size + 2) * sizeof(char));
      bytes = fread(content, sizeof(char), size, fp);
      if (bytes != (size_t)size)
	{
	  char tmp[256];
	  int len;
	  len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %ld?", caller, name, (long)bytes, size);
	  port_write_string(sc->output_port)(sc, tmp, len, sc->output_port);
	  size = bytes;
	}
      content[size] = '\0';
      content[size + 1] = '\0';
      fclose(fp);

      port_type(port) = STRING_PORT;
      port_string(port) = content;
      port_string_length(port) = size;
      port_string_point(port) = 0;
      port_needs_free(port) = true;
      port_read_character(port) = string_read_char;
      port_read_line(port) = string_read_line;
      port_display(port) = input_display;
      port_read_semicolon(port) = string_read_semicolon;
      port_read_white_space(port) = string_read_white_space;
      port_read_name(port) = string_read_name;
    }
  else
    {
      port_file(port) = fp;
      port_type(port) = FILE_PORT;
      port_needs_free(port) = false;
      port_read_character(port) = file_read_char;
      port_read_line(port) = file_read_line;
      port_display(port) = input_display;
      port_read_semicolon(port) = file_read_semicolon;
      port_read_white_space(port) = file_read_white_space;
      port_read_name(port) = file_read_name;
    }
#else
  /* _stat64 is no better than the fseek/ftell route, and 
   *    GetFileSizeEx and friends requires Windows.h which makes hash of everything else.
   *    fread until done takes too long on big files, so use a file port
   */
  port_file(port) = fp;
  port_type(port) = FILE_PORT;
  port_needs_free(port) = false;
  port_read_character(port) = file_read_char;
  port_read_line(port) = file_read_line;
  port_display(port) = input_display;
  port_read_semicolon(port) = file_read_semicolon;
  port_read_white_space(port) = file_read_white_space;
  port_read_name(port) = file_read_name;
#endif

  s7_gc_unprotect_at(sc, port_loc);
  return(port);
}


static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp)
{
  #define MAX_SIZE_FOR_STRING_PORT 5000000
  return(read_file(sc, fp, name, MAX_SIZE_FOR_STRING_PORT, "open"));
}

#if (!MS_WINDOWS)
#include <sys/stat.h>
#endif

static bool is_directory(const char *filename)
{
#if (!MS_WINDOWS)
  #ifdef S_ISDIR
    struct stat statbuf;
    return((stat(filename, &statbuf) >= 0) &&
	   (S_ISDIR(statbuf.st_mode)));
  #endif
#endif
  return(false);
}


static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char *mode, const char *caller)
{
  FILE *fp;
  /* see if we can open this file before allocating a port */

  if (is_directory(name))
    return(file_error(sc, caller, "is a directory", name));

  errno = 0;
  fp = fopen(name, mode);
  if (!fp)
    {
#if (!MS_WINDOWS)
      if (errno == EINVAL)
	return(file_error(sc, caller, "invalid mode", mode));

#if WITH_GCC
      /* catch one special case, "~/..." */
      if ((name[0] == '~') &&
	  (name[1] == '/'))
	{
	  char *home;
	  home = getenv("HOME");
	  if (home)
	    {
	      char *filename;
	      int len;
	      len = safe_strlen(name) + safe_strlen(home) + 1;
	      filename = (char *)calloc(len, sizeof(char));
	      strcopy(filename, home, len);
	      strcat(filename, (char *)(name + 1));
	      fp = fopen(filename, "r");
	      free(filename);
	      if (fp)
		return(make_input_file(sc, name, fp));
	    }
	}
#endif
#endif
      return(file_error(sc, caller, strerror(errno), name));
    }

  return(make_input_file(sc, name, fp));
}


s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode)
{
  return(open_input_file_1(sc, name, mode, "open-input-file"));
}


static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args)
{
  #define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading"
  s7_pointer name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->OPEN_INPUT_FILE, args);
      return(wrong_type_argument(sc, sc->OPEN_INPUT_FILE, small_int(1), name, T_STRING));
    }
  if (is_pair(cdr(args)))
    {
      if (!is_string(cadr(args)))
	{
	  CHECK_METHOD(sc, cadr(args), sc->OPEN_INPUT_FILE, args);
	  return(wrong_type_argument_with_type(sc, sc->OPEN_INPUT_FILE, small_int(2), cadr(args), 
					       make_protected_string(sc, "a string (a mode such as \"r\")")));
	}
      return(open_input_file_1(sc, string_value(name), string_value(cadr(args)), "open-input-file"));
    }
  return(open_input_file_1(sc, string_value(name), "r", "open-input-file"));
}


static void make_standard_ports(s7_scheme *sc)
{
  s7_pointer x;

  /* standard output */
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  set_type(x, T_OUTPUT_PORT | T_IMMUTABLE);
  port_port(x) = (s7_port_t *)calloc(1, sizeof(s7_port_t));
  port_type(x) = FILE_PORT;
  port_is_closed(x) = false;
  port_filename_length(x) = 8;
  port_filename(x) = copy_string_with_len("*stdout*", 8);
  port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (__FUNC__ data) */
  port_line_number(x) = 0;
  port_file(x) = stdout;
  port_needs_free(x) = false;
  port_read_character(x) = output_read_char;
  port_read_line(x) = output_read_line;
  port_display(x) = stdout_display;
  port_write_character(x) = stdout_write_char;
  port_write_string(x) = stdout_write_string;
  sc->standard_output = x;

  /* standard error */
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  set_type(x, T_OUTPUT_PORT | T_IMMUTABLE);
  port_port(x) = (s7_port_t *)calloc(1, sizeof(s7_port_t));
  port_type(x) = FILE_PORT;
  port_is_closed(x) = false;
  port_filename_length(x) = 8;
  port_filename(x) = copy_string_with_len("*stderr*", 8);
  port_file_number(x) = remember_file_name(sc, port_filename(x));
  port_line_number(x) = 0;
  port_file(x) = stderr;
  port_needs_free(x) = false;
  port_read_character(x) = output_read_char;
  port_read_line(x) = output_read_line;
  port_display(x) = stderr_display;
  port_write_character(x) = stderr_write_char;
  port_write_string(x) = stderr_write_string;
  sc->standard_error = x;

  /* standard input */
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  set_type(x, T_INPUT_PORT | T_IMMUTABLE);
  port_port(x) = (s7_port_t *)calloc(1, sizeof(s7_port_t));
  port_type(x) = FILE_PORT;
  port_is_closed(x) = false;
  port_original_input_string(x) = sc->NIL;
  port_filename_length(x) = 7;
  port_filename(x) = copy_string_with_len("*stdin*", 7);
  port_file_number(x) = remember_file_name(sc, port_filename(x));
  port_line_number(x) = 0;
  port_file(x) = stdin;
  port_needs_free(x) = false;
  port_read_character(x) = file_read_char;
  port_read_line(x) = stdin_read_line;
  port_display(x) = input_display;
  port_read_semicolon(x) = file_read_semicolon;
  port_read_white_space(x) = file_read_white_space;
  port_read_name(x) = file_read_name;
  port_write_character(x) = input_write_char;
  port_write_string(x) = input_write_string;
  sc->standard_input = x;

  s7_define_constant(sc, "*stdin*", sc->standard_input);
  s7_define_constant(sc, "*stdout*", sc->standard_output);
  s7_define_constant(sc, "*stderr*", sc->standard_error);

  sc->input_port = sc->standard_input;
  sc->output_port = sc->standard_output;
  sc->error_port = sc->standard_error;
  sc->current_file = NULL;
  sc->current_line = -1;
}


s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode)
{
  FILE *fp;
  s7_pointer x;
  /* 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)
	return(file_error(sc, "open-output-file", "invalid mode", mode));
#endif
      return(file_error(sc, "open-output-file", strerror(errno), name));
    }

  NEW_CELL(sc, x);
  set_type(x, T_OUTPUT_PORT);
  
  port_port(x) = alloc_port(sc);
  port_type(x) = FILE_PORT;
  port_is_closed(x) = false;
  port_filename_length(x) = safe_strlen(name);
  port_filename(x) = copy_string_with_len(name, port_filename_length(x));
  port_line_number(x) = 1;
  port_file(x) = fp;
  port_needs_free(x) = false;
  port_read_character(x) = output_read_char;
  port_read_line(x) = output_read_line;
  port_display(x) = file_display;
  port_write_character(x) = file_write_char;
  port_write_string(x) = file_write_string;
  port_position(x) = 0;
  port_data(x) = (unsigned char *)malloc(PORT_DATA_SIZE);
  add_output_port(sc, x);
  return(x);
}


static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args)
{
  #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing"
  s7_pointer name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->OPEN_OUTPUT_FILE, args);
      return(wrong_type_argument(sc, sc->OPEN_OUTPUT_FILE, small_int(1), name, T_STRING));
    }
  if (is_pair(cdr(args)))
    {
      if (!is_string(cadr(args)))
	{
	  CHECK_METHOD(sc, cadr(args), sc->OPEN_OUTPUT_FILE, args);
	  return(wrong_type_argument_with_type(sc, sc->OPEN_OUTPUT_FILE, small_int(2), cadr(args), 
					       make_protected_string(sc, "a string (a mode such as \"w\")")));
	}
      return(s7_open_output_file(sc, string_value(name), string_value(cadr(args))));
    }
  return(s7_open_output_file(sc, string_value(name), "w"));
}


static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, int len)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_INPUT_PORT);
  
  port_port(x) = alloc_port(sc);
  port_type(x) = STRING_PORT;
  port_is_closed(x) = false;
  port_original_input_string(x) = sc->NIL;
  port_string(x) = (char *)input_string;
  port_string_length(x) = len;
  port_string_point(x) = 0;
  port_filename_length(x) = 0;
  port_filename(x) = NULL;
  port_file_number(x) = -1;
  port_needs_free(x) = false;
  port_read_character(x) = string_read_char;
  port_read_line(x) = string_read_line;
  port_display(x) = input_display;
  port_read_semicolon(x) = string_read_semicolon;
  port_read_white_space(x) = string_read_white_space;
  port_read_name(x) = string_read_name_no_free;
  port_write_character(x) = input_write_char;
  port_write_string(x) = input_write_string;
  add_input_port(sc, x);
  return(x);
}

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"
  s7_pointer input_string = car(args);

  if (!is_string(input_string))
    {
      CHECK_METHOD(sc, input_string, sc->OPEN_INPUT_STRING, args);
      return(simple_wrong_type_argument(sc, sc->OPEN_INPUT_STRING, input_string, T_STRING));
    }
  return(open_input_string(sc, string_value(input_string), string_length(input_string))); /* presumably the caller is protecting the input string?? */
}


#define STRING_PORT_INITIAL_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)
 */

s7_pointer s7_open_output_string(s7_scheme *sc)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_OUTPUT_PORT);
  
  port_port(x) = alloc_port(sc);
  port_type(x) = STRING_PORT;
  port_is_closed(x) = false;
  port_string_length(x) = STRING_PORT_INITIAL_LENGTH;
  port_string(x) = (char *)calloc(STRING_PORT_INITIAL_LENGTH + 8, sizeof(char));
  port_string_point(x) = 0;
  port_needs_free(x) = true;
  port_read_character(x) = output_read_char;
  port_read_line(x) = output_read_line;
  port_display(x) = string_display;
  port_write_character(x) = string_write_char;
  port_write_string(x) = string_write_string;
  add_output_port(sc, x);
  return(x);
}


static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_open_output_string "(open-output-string) opens an output string port"
  return(s7_open_output_string(sc));
}


const char *s7_get_output_string(s7_scheme *sc, s7_pointer p)
{
  return(port_string(p));
}


static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_get_output_string "(get-output-string port) returns the output accumulated in port"
  s7_pointer p = car(args);

  if ((!is_output_port(p)) ||
      (!is_string_port(p)))
    {
      CHECK_METHOD(sc, p, sc->GET_OUTPUT_STRING, args);
      return(simple_wrong_type_argument_with_type(sc, sc->GET_OUTPUT_STRING, p, make_protected_string(sc, "an output string port")));
    }
  if (port_is_closed(p))
    return(simple_wrong_type_argument_with_type(sc, sc->GET_OUTPUT_STRING, p, make_protected_string(sc, "an active (open) string port")));

  return(s7_make_string_with_length(sc, port_string(p), port_string_point(p)));
}


s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port))
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_INPUT_PORT);
  
  port_port(x) = alloc_port(sc);
  port_type(x) = FUNCTION_PORT;
  port_is_closed(x) = false;
  port_original_input_string(x) = sc->NIL;
  port_needs_free(x) = false;
  port_input_function(x) = function;
  port_read_character(x) = function_read_char;
  port_read_line(x) = function_read_line;
  port_display(x) = input_display;
  port_write_character(x) = input_write_char;
  port_write_string(x) = input_write_string;
  add_input_port(sc, x);
  return(x);
}


s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, unsigned char c, s7_pointer port))
{
  s7_pointer x;
  NEW_CELL(sc, x);
  set_type(x, T_OUTPUT_PORT);
  
  port_port(x) = alloc_port(sc);
  port_type(x) = FUNCTION_PORT;
  port_is_closed(x) = false;
  port_needs_free(x) = false;
  port_output_function(x) = function;
  port_read_character(x) = output_read_char;
  port_read_line(x) = output_read_line;
  port_display(x) = function_display;
  port_write_character(x) = function_write_char;
  port_write_string(x) = function_write_string;
  add_output_port(sc, x);
  return(x);
}


static void push_input_port(s7_scheme *sc, s7_pointer new_port)
{
  sc->input_port_stack = cons(sc, sc->input_port, sc->input_port_stack);
  sc->input_port = new_port;
}


static void pop_input_port(s7_scheme *sc)
{
  if (is_pair(sc->input_port_stack))
    {
      sc->input_port = car(sc->input_port_stack);

      /* is this safe? */
      typeflag(sc->input_port_stack) = 0;
      (*(sc->free_heap_top++)) = sc->input_port_stack;

      sc->input_port_stack = cdr(sc->input_port_stack);
    }
  else sc->input_port = sc->standard_input;
}


static int inchar(s7_pointer pt)
{
  int c;
  if (is_file_port(pt))
    c = fgetc(port_file(pt)); /* not unsigned char! -- could be EOF */
  else 
    {
      if (port_string_length(pt) <= port_string_point(pt))
	return(EOF);
      c = (unsigned char)port_string(pt)[port_string_point(pt)++];
    }

  if (c == '\n')
    port_line_number(pt)++;

  return(c);
}


static void backchar(char c, s7_pointer pt) 
{
  if (c == '\n')
    port_line_number(pt)--;

  if (is_file_port(pt))
    ungetc(c, port_file(pt));
  else 
    {
      if (port_string_point(pt) > 0)
	port_string_point(pt)--;
    }
}


int s7_read_char(s7_scheme *sc, s7_pointer port)
{
  /* needs to be int return value so EOF=-1, but not 255 */
  return(port_read_character(port)(sc, port));
}


int s7_peek_char(s7_scheme *sc, s7_pointer port)
{
  int c;              /* needs to be an int so EOF=-1, but not 255 */
  c = port_read_character(port)(sc, port);
  if (c != EOF)
    backchar(c, port);
  return(c);
}


void s7_write_char(s7_scheme *sc, int c, s7_pointer pt) 
{
  port_write_character(pt)(sc, c, pt);
}


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"

  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else port = sc->input_port;
  if (!is_input_port(port))
    {
      CHECK_METHOD(sc, port, sc->READ_CHAR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_INPUT_PORT));
    }
  return(chars[port_read_character(port)(sc, port)]);
}


static s7_pointer read_char_0, read_char_1;
static s7_pointer g_read_char_0(s7_scheme *sc, s7_pointer args)
{
  return(chars[port_read_character(sc->input_port)(sc, sc->input_port)]);
}


static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port;
  port = car(args);
  if (!is_input_port(port))
    {
      CHECK_METHOD(sc, port, sc->READ_CHAR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, port, AN_INPUT_PORT));
    }
  return(chars[port_read_character(port)(sc, port)]);
}


static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 0)
    return(read_char_0);
  if (args == 1)
    return(read_char_1);
  return(f);
}


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"
  s7_pointer port, chr;
  
  chr = car(args);
  if (!s7_is_character(chr))
    {
      CHECK_METHOD(sc, chr, sc->WRITE_CHAR, args);
      return(wrong_type_argument(sc, sc->WRITE_CHAR, small_int(1), chr, T_CHARACTER));
    }
  if (is_pair(cdr(args)))
    {
      port = cadr(args);
      if (!is_output_port(port))
	return(wrong_type_argument_with_type(sc, sc->WRITE_CHAR, small_int(2), port, AN_OUTPUT_PORT));
    }
  else port = sc->output_port;

  port_write_character(port)(sc, s7_character(chr), port);
  return(sc->UNSPECIFIED);
}

static s7_pointer write_char_1;
static s7_pointer g_write_char_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer chr;
  
  chr = car(args);
  if (!s7_is_character(chr))
    {
      CHECK_METHOD(sc, chr, sc->WRITE_CHAR, args);
      return(wrong_type_argument(sc, sc->WRITE_CHAR, small_int(1), chr, T_CHARACTER));
    }
  port_write_character(sc->output_port)(sc, s7_character(chr), sc->output_port);
  return(sc->UNSPECIFIED);
}

static s7_pointer write_char_a_s;
static s7_pointer g_write_char_a_s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer chr, port;
  
  chr = ((s7_function)fcdr(args))(sc, car(args));
  if (!s7_is_character(chr))
    {
      CHECK_METHOD(sc, chr, sc->WRITE_CHAR, args);
      return(wrong_type_argument(sc, sc->WRITE_CHAR, small_int(1), car(args), T_CHARACTER));
    }

  port = finder(sc, cadr(args));
  if (!is_output_port(port))
    return(wrong_type_argument_with_type(sc, sc->WRITE_CHAR, small_int(2), port, AN_OUTPUT_PORT));
  
  port_write_character(port)(sc, s7_character(chr), port);
  return(sc->UNSPECIFIED);
}

static s7_pointer all_x_c_s(s7_scheme *sc, s7_pointer arg);
static s7_pointer write_char_a_s_looped;
static s7_pointer g_write_char_a_s_looped(s7_scheme *sc, s7_pointer args)
{
  /* args: (0 (read-char port) outport) */
  args = cdr(args); /* ignore the stepper -- here we only accept the case write(read) */
  if (fcdr(args) == (s7_pointer)all_x_c_s)
    {
      if (c_call(car(args)) == g_read_char_1)
	{
	  s7_pointer read_port, write_port;
	  int (*read_ch)(s7_scheme *sc, s7_pointer port);
	  void (*write_ch)(s7_scheme *sc, int c, s7_pointer port);

	  write_port = finder(sc, cadr(args));
	  if (!is_output_port(write_port))
	    return(wrong_type_argument_with_type(sc, sc->WRITE_CHAR, small_int(2), write_port, AN_OUTPUT_PORT));
	  write_ch = port_write_character(write_port);

	  read_port = finder(sc, cadar(args));
	  if (!is_input_port(read_port))
	    return(simple_wrong_type_argument_with_type(sc, sc->READ_CHAR, read_port, AN_INPUT_PORT));
	  read_ch = port_read_character(read_port);
	  
	  if ((read_ch == string_read_char) &&
	      (write_ch == file_write_char))    /* (do () () (write-char (read-char port) outport)) */
	    {
	      /* flush current write buffer */
	      if (port_position(write_port) > 0)
		fwrite((void *)(port_data(write_port)), 1, port_position(write_port), port_file(write_port));
	      port_position(write_port) = 0;
	      /* send out the entire string (only its EOF can stop us) */
	      fwrite((void *)(port_string(read_port) + port_string_point(read_port)), 1, /* start point in string */
		     port_string_length(read_port) - port_string_point(read_port),       /* length of remaining un-output string */
		     port_file(write_port));
	      port_string_point(read_port) = port_string_length(read_port);              /* make sure any subsequent read -> EOF */
	      /* simulate hitting the string end */
	      return(wrong_type_argument(sc, sc->WRITE_CHAR, small_int(1), sc->EOF_OBJECT, T_CHARACTER)); /* only normal way out! */
	    }

	  while (true)
	    {
	      int chr;
	      chr = read_ch(sc, read_port);
	      if (chr == EOF)
		return(wrong_type_argument(sc, sc->WRITE_CHAR, small_int(1), sc->EOF_OBJECT, T_CHARACTER)); /* only normal way out! */
	      write_ch(sc, chr, write_port);
	    }
	}
    }
  return(NULL);
}


static s7_pointer write_char_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 1)
    return(write_char_1);
  if (args == 2)
    {
      if ((is_symbol(caddr(expr))) &&
	  (is_all_x_safe(sc, cadr(expr))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  annotate_arg(sc, cdr(expr));
	  return(write_char_a_s);
	}
    }
  return(f);
}

/* (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.
 */


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"
  int c;
  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else port = sc->input_port;

  if (!is_input_port(port))
    {
      CHECK_METHOD(sc, port, sc->PEEK_CHAR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->PEEK_CHAR, port, AN_INPUT_PORT));
    }
  if (port_is_closed(port))
    return(simple_wrong_type_argument_with_type(sc, sc->PEEK_CHAR, port, AN_OPEN_PORT));
      
  c = s7_peek_char(sc, port);
  return(chars[c]);
}


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"
  s7_pointer port;
  int c;
  
  if (is_not_null(args))
    port = car(args);
  else port = sc->input_port;

  if (!is_input_port(port))
    {
      CHECK_METHOD(sc, port, sc->READ_BYTE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->READ_BYTE, port, AN_INPUT_PORT));
    }
  c = port_read_character(port)(sc, port);
  if (c == EOF)
    return(sc->EOF_OBJECT);
  return(small_int(c));
}


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"
  s7_pointer port;
  
  if (!s7_is_integer(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->WRITE_BYTE, args);
      return(wrong_type_argument(sc, sc->WRITE_BYTE, small_int(1), car(args), T_INTEGER));
    }
  if (is_pair(cdr(args)))
    port = cadr(args);
  else port = sc->output_port;

  if ((!is_output_port(port)) ||
      (is_string_port(port)))
    {
      CHECK_METHOD(sc, port, sc->WRITE_BYTE, args);
      return(wrong_type_argument_with_type(sc, sc->WRITE_BYTE, small_int(2), port, make_protected_string(sc, "an output file or function port")));
    }

  s7_write_char(sc, (int)(s7_integer(car(args))), port);
  return(car(args));
}


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."

  s7_pointer port;
  bool with_eol = false;

  if (is_not_null(args))
    {
      port = car(args);
      if (!is_input_port(port))
	{
	  CHECK_METHOD(sc, port, sc->READ_LINE, args);
	  return(wrong_type_argument_with_type(sc, sc->READ_LINE, small_int(1), port, AN_INPUT_PORT));
	}
      if (is_not_null(cdr(args)))
	{
	  /* support (read-line fp 'concat) for compatibility with guile */
	  if ((!s7_is_boolean(cadr(args))) &&
	      (!is_symbol(cadr(args))))
	    return(wrong_type_argument(sc, sc->READ_LINE, small_int(2), cadr(args), T_BOOLEAN));
	  if (cadr(args) != sc->F)
	    with_eol = true;
	}
    }
  else port = sc->input_port;
  return(port_read_line(port)(sc, port, with_eol));
}


static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
{
  #define H_read_string "(read-string k port) reads k characters from port into a new string and returns it."
  s7_pointer k, port, str;
  int c;
  s7_Int i, chars;

  k = car(args);
  if (!s7_is_integer(k))
    return(wrong_type_argument(sc, sc->READ_STRING, small_int(1), k, T_INTEGER));
  chars = s7_integer(k);
  if (chars < 0)
    return(wrong_type_argument_with_type(sc, sc->READ_STRING, small_int(1), k, A_NON_NEGATIVE_INTEGER));

  if (!is_null(cdr(args)))
    {
      port = cadr(args);
      if (!is_input_port(port))
	{
	  CHECK_METHOD(sc, port, sc->READ_STRING, args);
	  return(wrong_type_argument_with_type(sc, sc->READ_STRING, small_int(2), port, AN_INPUT_PORT));
	}
    }
  else port = sc->input_port;
  c = port_read_character(port)(sc, port);
  if (c == EOF)
    return(sc->EOF_OBJECT);

  if (chars == 0)
    {
      backchar(c, port);
      return(make_empty_string(sc, 0, 0));
    }
  
  str = make_empty_string(sc, chars, 0);
  string_value(str)[0] = c;
  for (i = 1; i < chars; i++)
    {
      c = port_read_character(port)(sc, port);
      if (c == EOF)
	{
	  string_length(str) = i;
	  return(str);
	}
      string_value(str)[i] = (unsigned int)c;
    }
  return(str);
}


s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
{
  if (is_input_port(port))
    {
      bool old_longjmp;
      s7_pointer old_envir;
      old_envir = sc->envir;
      sc->envir = sc->NIL; 
      if (sc->longjmp_ok)
	{
	  push_input_port(sc, port);
	  push_stack(sc, OP_BARRIER, port, sc->NIL);
	  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);  
	  eval(sc, OP_READ_INTERNAL);
	  pop_input_port(sc);
	  sc->envir = old_envir;
	  return(sc->value);
	}
      stack_reset(sc); 
      push_stack(sc, OP_EVAL_DONE, old_envir, sc->NIL); /* GC protect envir */
      push_input_port(sc, port);
      old_longjmp = sc->longjmp_ok;
      if (!sc->longjmp_ok)
	{
	  sc->longjmp_ok = true;
	  if (setjmp(sc->goto_start) != 0)
	    eval(sc, sc->op);
	  else eval(sc, OP_READ_INTERNAL);
	}
      sc->longjmp_ok = old_longjmp;
      pop_input_port(sc);
      sc->envir = old_envir;  
      return(sc->value);
    }
  return(simple_wrong_type_argument_with_type(sc, sc->READ, port, AN_INPUT_PORT));
}


static s7_pointer g_read(s7_scheme *sc, s7_pointer args)
{
  /* would it be useful to add an environment arg here?  (just set sc->envir at the end?)
   *    except for expansions, nothing is evaluated at read time, unless...
   *    say we set up a dot reader:
   *        (set! *#readers* (cons (cons #\. (lambda (str) (if (string=? str ".") (eval (read)) #f))) *#readers*))
   *    then 
   *        (call-with-input-string "(+ 1 #.(+ 1 hiho))" (lambda (p) (read p)))
   *    evaluates hiho in the global environment, but how to pass the env to the inner eval or read?
   * (eval, eval-string and load already have an env arg)
   */
  #define H_read "(read (port (current-input-port))) returns the next object in the input port, or #<eof> at the end"
  s7_pointer port;
  
  if (is_not_null(args))
    port = car(args);
  else port = sc->input_port;
  
  if (!is_input_port(port)) /* was also not stdin */
    {
      CHECK_METHOD(sc, port, sc->READ, args);
      return(simple_wrong_type_argument_with_type(sc, sc->READ, port, AN_INPUT_PORT));
    }

  if (is_function_port(port))
    return((*(port_input_function(port)))(sc, S7_READ, port));
  
  if ((is_string_port(port)) &&
      (port_string_length(port) <= port_string_point(port)))
    return(sc->EOF_OBJECT);

  push_input_port(sc, port);
  push_stack(sc, OP_READ_DONE, sc->NIL, sc->NIL); /* this stops the internal read process so we only get one form */
  push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);

  return(port);
}


/* -------------------------------- load -------------------------------- */

static FILE *search_load_path(s7_scheme *sc, const char *name)
{
  int i, len, name_len;
  s7_pointer lst;

  lst = s7_load_path(sc);
  len = s7_list_length(sc, lst);
  name_len = safe_strlen(name);

  for (i = 0; i < len; i++)
    {
      const char *new_dir;
      int size;
      new_dir = string_value(s7_list_ref(sc, lst, i));
      if (new_dir)
	{
	  char *new_name;
	  FILE *fp;
	  size = name_len + safe_strlen(new_dir) + 2;
	  new_name = (char *)malloc(size * sizeof(char));
	  snprintf(new_name, size, "%s/%s", new_dir, name);
	  fp = fopen(new_name, "r");
	  free(new_name);
	  if (fp) return(fp);
	}
    }

  return(NULL);
}


static s7_pointer load_file(s7_scheme *sc, FILE *fp, const char *name)
{
  return(read_file(sc, fp, name, -1, "load"));  /* -1 means always read its contents into a local string */
}


s7_pointer s7_load(s7_scheme *sc, const char *filename)
{
  bool old_longjmp;
  s7_pointer port;
  FILE *fp;
  
  fp = fopen(filename, "r");
  if (!fp)
    fp = search_load_path(sc, filename);
  if (!fp)
    return(file_error(sc, "load", "can't open", filename));

  if (is_pair(s7_hook_functions(sc, sc->load_hook)))
    s7_call(sc, sc->load_hook, list_1(sc, s7_make_string(sc, filename)));

  port = load_file(sc, fp, filename);
  port_file_number(port) = remember_file_name(sc, filename);
  push_input_port(sc, port);
  
  /* it's possible to call this recursively (s7_load is XEN_LOAD_FILE which can be invoked via s7_call)
   *   but in that case, we actually want it to behave like g_load and continue the evaluation upon completion
   */
  sc->envir = sc->NIL;
  
  if (!sc->longjmp_ok)
    {
      push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
      
      old_longjmp = sc->longjmp_ok;
      if (!sc->longjmp_ok)
	{
	  sc->longjmp_ok = true;
	  if (setjmp(sc->goto_start) != 0)
	    eval(sc, sc->op);
	  else eval(sc, OP_READ_INTERNAL);
	}
      sc->longjmp_ok = old_longjmp;  
      pop_input_port(sc);
      s7_close_input_port(sc, port);
    }
  else
    {
      /* caller here is assuming the load will be complete before this function returns */
      push_stack(sc, OP_LOAD_RETURN_IF_EOF, sc->args, sc->code);

      eval(sc, OP_READ_INTERNAL);
      pop_input_port(sc);
      s7_close_input_port(sc, port);
    }

  return(sc->value);
}


#if WITH_C_LOADER
#include <dlfcn.h>

/* besides the dynamic loader, we also need to fully specify the shared object file name.
 */

static char *full_filename(const char *filename)
{
  int len;
  char *pwd, *rtn;
  pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */
  len = safe_strlen(pwd) + safe_strlen(filename) + 8;
  rtn = (char *)calloc(len, sizeof(char));
  if (pwd)
    {
      strcopy(rtn, pwd, len);
      free(pwd);
      strcat(rtn, "/");
    }
  strcat(rtn, filename);
  return(rtn);
}
#endif


static s7_pointer g_load(s7_scheme *sc, s7_pointer args)
{
  #define H_load "(load file (env (global-environment))) loads the scheme file 'file'. The 'env' argument \
defaults to the global environment.  To load into the current environment instead, pass (current-environment)."

  FILE *fp = NULL;
  s7_pointer name, port;
  const char *fname;
  
  name = car(args);
  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->LOAD, args);
      return(wrong_type_argument(sc, sc->LOAD, small_int(1), name, T_STRING));
    }
  if (is_not_null(cdr(args))) 
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_environment(e))
	return(wrong_type_argument_with_type(sc, sc->LOAD, small_int(2), e, AN_ENVIRONMENT));
      if (e == sc->global_env)
	sc->envir = sc->NIL;
      else sc->envir = e; 
    }
  else sc->envir = sc->NIL;
  
  fname = string_value(name);
  if ((!fname) || (!(*fname)))                 /* fopen("", "r") returns a file pointer?? */
    return(s7_error(sc, sc->OUT_OF_RANGE, 
		    list_2(sc, 
			   make_protected_string(sc, "load's first argument, ~S, should be a filename"),
			   name)));

  if (is_directory(fname))
    return(s7_error(sc, sc->WRONG_TYPE_ARG, 
		    list_2(sc, make_protected_string(sc, "load argument, ~S, is a directory"), name)));

#if WITH_C_LOADER
  /* if fname ends in .so, try loading it as a c shared object
   *   (load "/home/bil/cl/m_j0.so" (environment (cons 'init_func 'init_m_j0)))
   */
  {
    int fname_len;
    fname_len = safe_strlen(fname);
    if ((fname_len > 3) &&
	(is_pair(cdr(args))) &&
	(strcmp((const char *)(fname + (fname_len - 3)), ".so") == 0))
      {
	s7_pointer init;
	const char *init_name = NULL;
	void *library;

	init = s7_environment_ref(sc, sc->envir, s7_make_symbol(sc, "init_func"));
	if (is_symbol(init))
	  {
	    char *pwd_name;
	    pwd_name = full_filename(fname);
	    init_name = symbol_name(init);
	    library = dlopen(pwd_name, RTLD_NOW);
	    if (library)
	      {
		void *init_func;
		init_func = dlsym(library, init_name);
		if (init_func)
		  {
		    typedef void *(*dl_func)(s7_scheme *sc);
		    ((dl_func)init_func)(sc); 
		    return(sc->T);
		  }
		else 
		  {
		    fprintf(stderr, "loaded %s, but can't find %s (%s)?\n", pwd_name, init_name, dlerror());
		    dlclose(library);
		  }
	      }
	    else fprintf(stderr, "load %s failed: %s\n", pwd_name, dlerror());
	    free(pwd_name);
	  }
	else fprintf(stderr, "can't load %s: no init function\n", fname);
	return(sc->F);
      }
  }
#endif

  fp = fopen(fname, "r");

#if WITH_GCC
  if (!fp)
    {
      /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors
       */
      if ((fname[0] == '~') &&
	  (fname[1] == '/'))
	{
	  char *home;
	  home = getenv("HOME");
	  if (home)
	    {
	      char *filename;
	      int len;
	      len = safe_strlen(fname) + safe_strlen(home) + 1;
	      filename = (char *)calloc(len, sizeof(char));
	      strcopy(filename, home, len);
	      strcat(filename, (char *)(fname + 1));
	      fp = fopen(filename, "r");
	      free(filename);
	    }
	}
    }
#endif

  if (!fp)
    {
      fp = search_load_path(sc, fname);
      if (!fp)
	return(file_error(sc, "load", "can't open", fname));
    }

  port = load_file(sc, fp, fname);
  port_file_number(port) = remember_file_name(sc, fname);
  push_input_port(sc, port);

  push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->NIL, sc->NIL);  /* was pushing args and code, but I don't think they're used later */
  push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
  
  /* now we've opened and moved to the file to be loaded, and set up the stack to return
   *   to where we were when it is read.  Call *load-hook* if it is a procedure.
   */
  
  if (is_not_null(s7_hook_functions(sc, sc->load_hook)))
    s7_apply_function(sc, sc->load_hook, list_1(sc, s7_make_string(sc, fname)));

  return(sc->UNSPECIFIED);
}


s7_pointer s7_load_path(s7_scheme *sc)
{
  return(s7_symbol_value(sc, sc->LOAD_PATH));
}


s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir)
{
  s7_symbol_set_value(sc, 
		      sc->LOAD_PATH,
		      cons(sc, 
			   s7_make_string(sc, dir), 
			   s7_symbol_value(sc, sc->LOAD_PATH)));
  return(s7_symbol_value(sc, sc->LOAD_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 */
  if (is_null(cadr(args))) return(cadr(args));
  if (is_pair(cadr(args)))
    {
      s7_pointer x;
      for (x = cadr(args); is_pair(x); x = cdr(x))
	if (!is_string(car(x)))
	  return(sc->ERROR);
      if (is_null(x))
	return(cadr(args));
    }
  return(sc->ERROR);
}


/* ---------------- autoload ---------------- */

void s7_autoload_set_names(s7_scheme *sc, const char **names, int size)
{
  /* 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 a la xg (gtk) as environments
   *   and every name in that library will come as an import once dlopen has picked up the library.
   *   So, hopefully, we can pre-declare as many names as we want from as many libraries as we want,
   *   without a bloated mess of a run-time image.  And new libraries are easy to accommodate --
   *   add the names to be auto-exported to this list with the name of the scheme file that cloads
   *   the library and exports the given name. So, we'll need a separate such file for each library?
   *
   * the environment variable could use the library base name in *: *libm* or *libgtk*
   *   (*libm* 'j0)
   * why not just predeclare these libraries?  The caller could import what he wants via require.
   * So the autoloader need only know which libraries, but this doesn't fit the current use of gtk in xg
   * In fact, we only need to see *libm* -> libm.so etc, but we still need the arg/return types of each function, etc
   * And libgtk is enormous -- seems too bad to tie-in everything via the FFI when we need less than 1% of it.
   * Perhaps each module as an environment within the main one: ((*libgtk* *gtkwidget*) 'gtk_widget_new)?
   * But that requires inside knowlege of the library, and changes without notice.
   *
   * Also we need to decide how to handle name collisions (by order of autoload lib setup)
   * And (lastly?) how to handle different library versions?
   *
   *
   * so autoload known libs here in s7 so we're indepentdent of snd
   *   (currently these are included in make-index.scm[line 575] -> snd-xref.c)
   * for each module, include an env in the lib env (*libgtk* 'gtkwidget.h) or whatever that has the names in that header
   * in autoload below, don't sort! -- just build a list of autoload tables and check each in order at autoload time (we want startup to be fast)
   * for versions, include wrapper macro at end of each c-define choice
   * in the xg case, there's no savings in delaying the defines
   *
   */
  if (sc->autoload_names == NULL)
    {
      sc->autoload_names = (const char ***)calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(const char **));
      sc->autoload_names_sizes = (int *)calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(int));
      sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE;
      sc->autoload_names_loc = 0;
    }
  else
    {
      if (sc->autoload_names_loc >= sc->autoload_names_top)
	{
	  int i;
	  sc->autoload_names_top *= 2;
	  sc->autoload_names = (const char ***)realloc(sc->autoload_names, sc->autoload_names_top);
	  sc->autoload_names_sizes = (int *)realloc(sc->autoload_names_sizes, sc->autoload_names_top);
	  for (i = sc->autoload_names_loc; i < sc->autoload_names_top; i++)
	    {
	      sc->autoload_names[i] = NULL;
	      sc->autoload_names_sizes[i] = 0;
	    }
	}
    }
     
  sc->autoload_names[sc->autoload_names_loc] = names;
  sc->autoload_names_sizes[sc->autoload_names_loc] = size;
  sc->autoload_names_loc++;
}


static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol)
{
  int l = 0, u, pos = -1, comp, lib, libs;
  const char *name, *this_name;
  const char **names;

  name = symbol_name(symbol);
  libs = sc->autoload_names_loc;

  for (lib = 0; lib < libs; lib++)
    {
      u = sc->autoload_names_sizes[lib] - 1;
      names = sc->autoload_names[lib];
      
      while (true)
	{
	  if (u < l) break;
	  pos = (l + u) / 2;
	  this_name = names[pos * 2];
	  comp = strcmp(this_name, name);
	  if (comp == 0)
	    {
	      /* fprintf(stderr, "found %s in %s\n", name,  sc->autoload_names[pos * 2 + 1]); */
	      return(names[pos * 2 + 1]);
	    }
	  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, 511);
  
  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."

  s7_pointer sym, value;

  sym = car(args);
  if (is_string(sym))
    sym = s7_make_symbol(sc, string_value(sym));
  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->AUTOLOAD, args);
      return(s7_wrong_type_arg_error(sc, "autoload", 1, sym, "a string (symbol-name) or a symbol"));
    }
  
  value = cadr(args);
  if ((is_string(value)) ||
      (is_closure(value)))
    return(s7_autoload(sc, sym, value));

  return(s7_wrong_type_arg_error(sc, "autoload", 2, value, "a string (file-name) or a thunk"));
}


static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args)
{
  #define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f."
  s7_pointer sym;

  sym = car(args);
  if (!is_symbol(sym))
    {
      CHECK_METHOD(sc, sym, sc->AUTOLOADER, args);
      return(s7_wrong_type_arg_error(sc, "*autoload*", 1, sym, "a symbol"));
    }
  if (sc->autoload_names)
    {
      const char *file;
      file = find_autoload_name(sc, sym);
      if (file)
	return(s7_make_string(sc, file));
    }
  if (is_hash_table(sc->autoload_table))
    return(s7_hash_table_ref(sc, sc->autoload_table, sym));

  return(sc->F);
}



/* -------------------------------- eval-string -------------------------------- */

static s7_pointer eval_string_1(s7_scheme *sc, const char *str)
{
  s7_pointer port;

  port = s7_open_input_string(sc, str);
  push_input_port(sc, port);

  push_stack(sc, OP_BARRIER, port, sc->NIL);
  /* we're being called directly from C here, not as part of a scheme program.
   *    Use this op to protect the port, I guess.
   */
  push_stack(sc, OP_EVAL_STRING, sc->args, sc->code);  
  /* eval-string is not tail-recursive because it pushes markers in eval to catch
   *    multiple statements in one eval-string call.
   */
  eval(sc, OP_READ_INTERNAL);

  pop_input_port(sc);
  s7_close_input_port(sc, port);
  if (is_multiple_value(sc->value))                    /* (+ 1 (eval-string "(values 2 3)")) */
    sc->value = splice_in_values(sc, multiple_value(sc->value));

  return(sc->value);
}


s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str)
{
  bool old_longjmp;
  s7_pointer port, old_envir;
  /* this can be called recursively via s7_call */

  old_envir = sc->envir;
  sc->envir = sc->NIL; 
  if (sc->longjmp_ok)
    {
      s7_pointer result;
      result = eval_string_1(sc, str);
      sc->envir = old_envir;
      return(result);
    }
  
  stack_reset(sc); 
  push_stack(sc, OP_EVAL_STRING, old_envir, sc->NIL); /* GC protect envir */

  port = s7_open_input_string(sc, str);
  push_input_port(sc, port);
  
  old_longjmp = sc->longjmp_ok;
  if (!sc->longjmp_ok)
    {
      sc->longjmp_ok = true;
      if (setjmp(sc->goto_start) != 0)
	eval(sc, sc->op);
      else eval(sc, OP_READ_INTERNAL);
    }
  
  sc->longjmp_ok = old_longjmp;
  pop_input_port(sc);
  s7_close_input_port(sc, port);
  sc->envir = old_envir;  

  return(sc->value);
}


static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args)
{
  #define H_eval_string "(eval-string str (env (current-environment))) returns the result of evaluating the string str as Scheme code"
  s7_pointer port, str;
  
  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->EVAL_STRING, args);
      return(wrong_type_argument(sc, sc->EVAL_STRING, small_int(1), str, T_STRING));
    }
  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_environment(e))
 	return(wrong_type_argument_with_type(sc, sc->EVAL_STRING, small_int(2), e, AN_ENVIRONMENT));
      if (e == sc->global_env)
	sc->envir = sc->NIL;
      else sc->envir = e;
    }

  port = open_input_string(sc, string_value(str), string_length(str));
  push_input_port(sc, port);
  
  sc->temp4 = sc->args;
  push_stack(sc, OP_EVAL_STRING_1, args, sc->code); /* was sc->args */
  push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
  
  return(sc->F);
}



static s7_pointer call_with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
{
  s7_pointer p;
  p = cadr(args);
  port_original_input_string(port) = car(args);
  push_stack(sc, OP_UNWIND_INPUT, sc->input_port, port);
  push_stack(sc, OP_APPLY, list_1(sc, port), p);
  return(sc->F);
}


static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args)
{
  s7_pointer str;
  #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it"
  
  /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45
   */
  
  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->CALL_WITH_INPUT_STRING, args);
      return(wrong_type_argument(sc, sc->CALL_WITH_INPUT_STRING, small_int(1), str, T_STRING));
    }
  if (!is_procedure(cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_STRING, small_int(2), cadr(args), A_PROCEDURE));
  if ((is_continuation(cadr(args))) || 
      (is_goto(cadr(args))))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_STRING, small_int(2), cadr(args), 
					 make_protected_string(sc, "a normal procedure (not a continuation)")));
  
  return(call_with_input(sc, open_input_string(sc, string_value(str), string_length(str)), args));
}


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"
  
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CALL_WITH_INPUT_FILE, args);
      return(wrong_type_argument(sc, sc->CALL_WITH_INPUT_FILE, small_int(1), car(args), T_STRING));
    }
  if (!is_procedure(cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_FILE, small_int(2), cadr(args), A_PROCEDURE));
  if ((is_continuation(cadr(args))) || 
      (is_goto(cadr(args))))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_INPUT_FILE, small_int(2), cadr(args), 
					 make_protected_string(sc, "a normal procedure (not a continuation)")));
  
  return(call_with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "call-with-input-file"), args));
}


static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
{
  s7_pointer old_input_port;
  old_input_port = sc->input_port;
  sc->input_port = port;
  port_original_input_string(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_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"
  s7_pointer str;

  str = car(args);
  if (!is_string(str))
    {
      CHECK_METHOD(sc, str, sc->WITH_INPUT_FROM_STRING, args);
      return(wrong_type_argument(sc, sc->WITH_INPUT_FROM_STRING, small_int(1), str, T_STRING));
    }
  if (!is_thunk(sc, cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->WITH_INPUT_FROM_STRING, small_int(2), cadr(args), A_THUNK));
  
  /* 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"
   */
  
  return(with_input(sc, open_input_string(sc, string_value(str), string_length(str)), args));
}


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"
  
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->WITH_INPUT_FROM_FILE, args);
      return(wrong_type_argument(sc, sc->WITH_INPUT_FROM_FILE, small_int(1), car(args), T_STRING));
    }
  if (!is_thunk(sc, cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->WITH_INPUT_FROM_FILE, small_int(2), cadr(args), A_THUNK));
  
  return(with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "with-input-from-file"), args));
}


static bool needs_slashification(const char *str, int len)
{
  /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */
  unsigned char *p, *pend;
  pend = (unsigned char *)(str + len);
  for (p = (unsigned char *)str; p < pend; p++)
    if (slashify_table[*p])
      return(true);
  return(false);
}


#define IN_QUOTES true
#define NOT_IN_QUOTES false

static char *slashify_string(s7_scheme *sc, const char *p, int len, bool quoted, int *nlen) /* do not free result */
{
  int j = 0, cur_size, size;
  char *s;
  unsigned char *pcur, *pend;

  pend = (unsigned char *)(p + len);
  cur_size = len + 256;
  size = cur_size + 2;
  if (size > sc->slash_str_size)
    {
      if (sc->slash_str) free(sc->slash_str);
      sc->slash_str_size = size;
      sc->slash_str = (char *)malloc(size);
    }
  memset((void *)sc->slash_str, 0, size);
  s = sc->slash_str;

  if (quoted) s[j++] = '"';

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

  for (pcur = (unsigned char *)p; pcur < pend; pcur++) 
    {
      if (slashify_table[*pcur])
	{
	  s[j++] = '\\';
	  switch (*pcur)
	    {
	    case '"':
	      s[j++] = '"';
	      break;
	      
	    case '\\':
	      s[j++] = '\\';
	      break;
	      
	    default:               /* this is the "\x01" stuff */
	      { 
		unsigned int n;
		static char dignum[] = "0123456789abcdef";
		s[j++] = 'x';
		n = (unsigned int)(*pcur);
		if (n < 16)
		  s[j++] = '0';
		else s[j++] = dignum[(n / 16) % 16];
		s[j++] = dignum[n % 16];
	      }
	      break;
	    }
	}
      else s[j++] = *pcur;
      if (j >= cur_size) /* even with 256 extra, we can overflow (for example, inordinately many tabs in ALSA output) */
	{
	  int k;
	  cur_size *= 2;
	  size = cur_size + 2;
	  sc->slash_str = (char *)realloc(sc->slash_str, size * sizeof(char));
	  s = sc->slash_str;
	  for (k = j; k < size; k++) s[k] = 0;
	}
    }
  if (quoted) s[j++] = '"';
  (*nlen) = j;
  return(s);
}


/* (let () (define (hi a) (+ a 1)) (object->string hi))
 * (let () (define (hi a) (asd a 1)) (environment->list (procedure-environment hi)))
 */
static s7_pointer find_closure_environment(s7_scheme *sc, s7_pointer cur_env)
{
  s7_pointer e;
  for (e = cur_env; is_environment(e); e = next_environment(e))
    if (is_function_env(e))
      return(e);
  return(sc->NIL);
}


static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer cur_env)
{
  s7_pointer e, y;
  for (e = cur_env; is_environment(e); e = next_environment(e))
    {
      if ((is_function_env(e)) &&
	  (is_symbol(environment_function(e))) &&
	  (is_global(environment_function(e))) && /* (define (f1) (lambda () 1)) shouldn't say the returned closure is named f1 */
	  (slot_value(global_slot(environment_function(e))) == closure))
	return(environment_function(e));

      for (y = environment_slots(e); is_slot(y); y = next_slot(y))
	if (slot_value(y) == closure)
	  return(slot_symbol(y));
    }
  return(sc->NIL);
}


static const char *c_closure_name(s7_scheme *sc, s7_pointer closure, int *nlen)
{
  s7_pointer x;
  x = find_closure(sc, closure, closure_environment(closure));

  if (is_symbol(x))
    {
      (*nlen) = symbol_name_length(x);
      return(symbol_name(x));
    }

  /* names like #<closure> and #<macro> are useless -- try to be a bit more informative
   *   #<lambda|* args> #<m|bacro|* args> (args truncated if long)
   * despite the name "c_closure..." this function refers to T_CLOSURE and T_CLOSURE_STAR objects only
   */
  if (is_null(closure_args(closure)))
    (*nlen) = snprintf(sc->strbuf, sc->strbuf_size, "#<lambda%s ()>", (type(closure) == T_CLOSURE) ? "" : "*");
  else
    {
      if (is_symbol(closure_args(closure)))
	(*nlen) = snprintf(sc->strbuf, sc->strbuf_size, "#<lambda%s %s>", (type(closure) == T_CLOSURE) ? "" : "*", symbol_name(closure_args(closure)));
      else
	{
	  x = closure_args(closure);
	  if (is_null(cdr(x)))
	    (*nlen) = snprintf(sc->strbuf, sc->strbuf_size, "#<lambda%s (%s)>", 
			       (type(closure) == T_CLOSURE) ? "" : "*", 
			       (is_pair(car(x))) ? symbol_name(caar(x)) : symbol_name(car(x)));
	  else (*nlen) = snprintf(sc->strbuf, sc->strbuf_size, "#<lambda%s (%s %s%s%s>", 
				  (type(closure) == T_CLOSURE) ? "" : "*", 
				  (is_pair(car(x))) ? symbol_name(caar(x)) : symbol_name(car(x)),
				  (is_pair(cdr(x))) ? "" : ". ",
				  (is_pair(cdr(x))) ? ((is_pair(cadr(x))) ? symbol_name(caadr(x)) : symbol_name(cadr(x))) : symbol_name(cdr(x)),
				  ((is_pair(cdr(x))) && (!is_null(cddr(x)))) ? " ..." : ")");
	}
    }
  return(sc->strbuf);
}


enum {NO_ARTICLE, DEFINITE_ARTICLE, INDEFINITE_ARTICLE};

static char *describe_type_bits(s7_scheme *sc, s7_pointer obj)
{
  char *buf;
  buf = (char *)calloc(512, sizeof(char));
  snprintf(buf, 512, "type: %d (%s), flags: #x%x%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", 
	   type(obj), 
	   type_name(sc, obj, NO_ARTICLE),
	   typeflag(obj),
	   is_procedure(obj) ?          " procedure" : "",
	   is_marked(obj) ?             " gc-marked" : "",
	   is_immutable(obj) ?          " immutable" : "",
	   is_global(obj) ?             " global" : "",
	   has_line_number(obj) ?       " line number" : "",
	   is_expansion(obj) ?          " expansion" : "",
	   is_multiple_value(obj) ?     " values" : "",
	   is_keyword(obj) ?            " keyword" : "",
	   dont_eval_args(obj) ?        " dont-eval-args" : "",
	   is_syntactic(obj) ?          " syntactic" : "",
	   is_overlaid(obj) ?           " overlay" : "",
	   is_checked(obj) ?            " checked" : "",
	   is_unsafe(obj) ?             " unsafe" : "",
	   is_optimized(obj) ?          " optimized" : "",
	   is_safe_closure(obj) ?       " safe-closure" : "",
	   is_safe_procedure(obj) ?     " safe-procedure" : "",
	   is_setter(obj) ?             " setter" : "",
	   needs_copied_args(obj) ?     " copy-args" : "",
	   is_gensym(obj) ?             " gensym" : "",
	   has_methods(obj) ?           " has methods" : "",
	   returns_temp(obj) ?          " returns temp cell" : "",
	   ((typeflag(obj) & UNUSED_BITS) != 0) ? " bad bits!" : "");
  return(buf);
}


#if (!DISABLE_DEPRECATED)
bool s7_is_valid_pointer(s7_pointer arg)
{
  return((arg) &&
	 (type(arg) > T_FREE) && (type(arg) < NUM_TYPES));
}
#endif


#if TRAP_SEGFAULT
#include <signal.h>
static sigjmp_buf senv;
static volatile sig_atomic_t can_jump = 0;
static void segv(int ignored) {if (can_jump) siglongjmp(senv, 1);}
#endif

bool s7_is_valid(s7_scheme *sc, s7_pointer arg)
{
  bool result;
  /* new name because the function above might be in use 
   */
  if (!arg) return(false);
  /* we might also check that (arg & 0x7) == 0, but see unaligned access above */

  /* this trap does not behave correctly in gdb because gdb notices the segfault 
   *   and the gdb-s7.scm pipe hangs awaiting kbd input.
   */

#if TRAP_SEGFAULT
  if (sigsetjmp(senv, 1) == 0)
    {
      void (*old_segv)(int sig);
      can_jump = 1;
      old_segv = signal(SIGSEGV, segv);
#endif

  result = ((type(arg) > T_FREE) && (type(arg) < NUM_TYPES) &&
	    ((arg->hloc == -1) ||
	     ((arg->hloc >= 0) && (arg->hloc < (int)sc->heap_size) && (sc->heap[arg->hloc] == arg))));

#if TRAP_SEGFAULT
  signal(SIGSEGV, old_segv);
    }
  can_jump = 0;
#endif

  return(result);
}


#define INITIAL_SHARED_INFO_SIZE 8

static int shared_ref(shared_info *ci, s7_pointer p)
{
  int i;
  s7_pointer *objs;
  objs = ci->objs;
  for (i = 0; i < ci->top; i++)
    if (objs[i] == p)
      {
	int val;
	val = ci->refs[i];
	if (val > 0)
	  ci->refs[i] = -ci->refs[i];
	return(val);
      }
  return(0);
}


static int peek_shared_ref(shared_info *ci, s7_pointer p)
{
  /* returns 0 if not found, otherwise the ref value for p */
  int i, lim;
  s7_pointer *objs;
  objs = ci->objs;
  i = 0;
  lim = ci->top - 4;
  while (i <= lim)
    {
      if (objs[i] == p) return(ci->refs[i]);
      i++;
      if (objs[i] == p) return(ci->refs[i]);
      i++;
      if (objs[i] == p) return(ci->refs[i]);
      i++;
      if (objs[i] == p) return(ci->refs[i]);
      i++;
    }
  for (; i < ci->top; i++)
    if (objs[i] == p) return(ci->refs[i]);
  return(0);
}


static void enlarge_shared_info(shared_info *ci)
{
  int i;
  ci->size *= 2;
  ci->objs = (s7_pointer *)realloc(ci->objs, ci->size * sizeof(s7_pointer));
  ci->refs = (int *)realloc(ci->refs, ci->size * sizeof(int));
  for (i = ci->top; i < ci->size; i++)
    {
      ci->refs[i] = 0;
      ci->objs[i] = NULL;
    }
}


static void add_equal_ref(shared_info *ci, s7_pointer x, s7_pointer y)
{
  /* assume neither x nor y is in the table, and that they should share a ref value */

  if ((ci->top + 2) >= ci->size)
    enlarge_shared_info(ci);

  ci->ref++;
  ci->objs[ci->top] = x;
  ci->refs[ci->top++] = ci->ref;
  ci->objs[ci->top] = y;
  ci->refs[ci->top++] = ci->ref;
}


static void add_shared_ref(shared_info *ci, s7_pointer x, int ref_x)
{
  if (ci->top == ci->size)
    enlarge_shared_info(ci);

  ci->objs[ci->top] = x;
  ci->refs[ci->top++] = ref_x;
}

static shared_info *collect_shared_info(s7_scheme *sc, shared_info *ci, s7_pointer top);
static s7_pointer hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key);
static s7_pointer hash_eq_func(s7_scheme *sc, s7_pointer table, s7_pointer key);

static void collect_vector_info(s7_scheme *sc, shared_info *ci, s7_pointer top)
{
  int i, plen;

  plen = s7_vector_print_length(sc); /* all stringification follows the print length */
  if (plen > vector_length(top))
    plen = vector_length(top);
  
  for (i = 0; i < plen; i++)
    if (has_structure(vector_element(top, i)))
      collect_shared_info(sc, ci, vector_element(top, i));
}


static shared_info *collect_shared_info(s7_scheme *sc, shared_info *ci, s7_pointer top)
{
  /* this only pertains to printing */
  int i;
  /* 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.
   */

  if (is_collected(top))
    {
      s7_pointer *p, *objs_end;
      objs_end = (s7_pointer *)(ci->objs + ci->top);

      for (p = ci->objs; p < objs_end; p++)
	if ((*p) == top)
	  {
	    i = (int)(p - ci->objs);
	    if (ci->refs[i] == 0)
	      {
		ci->has_hits = true;
		ci->refs[i] = ++ci->ref;  /* if found, set the ref number */
	      }
	    break;
	  }
    }
  else
    {
      /* 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;

      /* now search the rest of this structure */
      switch (type(top))
	{
	case T_PAIR:
	  if (has_structure(car(top)))
	    collect_shared_info(sc, ci, car(top));
	  if (has_structure(cdr(top)))
	    collect_shared_info(sc, ci, cdr(top));
	  break;
	  
	case T_VECTOR:
	  collect_vector_info(sc, ci, top);
	  break;
	  
	case T_HASH_TABLE:
	  if (hash_table_entries(top) > 0)
	    {
	      s7_pointer iterator;
	      int gc_iter;
	      bool keys_safe;
	      
	      keys_safe = ((hash_table_function(top) != hash_equal) &&
			   (hash_table_function(top) != hash_eq_func));
	      iterator = g_make_hash_table_iterator(sc, list_1(sc, top));
	      gc_iter = s7_gc_protect(sc, iterator);
	      
	      while (true)
		{
		  s7_pointer x;
		  x = hash_table_iterate(sc, iterator);
		  if (is_null(x)) break;
		  /* x is a cons, if hash_table_function(top) != hash_equal, we know car is ok */
		  if ((!keys_safe) &&
		      (has_structure(car(x))))
		    collect_shared_info(sc, ci, car(x));
		  if (has_structure(cdr(x)))
		    collect_shared_info(sc, ci, cdr(x));
		}
	      s7_gc_unprotect_at(sc, gc_iter);
	    }
	  break;

	case T_SLOT:
	  if (has_structure(slot_value(top)))
	    collect_shared_info(sc, ci, slot_value(top));
	  break;

	case T_ENVIRONMENT:
	  if (top == sc->global_env)
	    collect_vector_info(sc, ci, top);
	  else
	    {
	      s7_pointer p;
	      for (p = environment_slots(top); is_slot(p); p = next_slot(p))
		if (has_structure(slot_value(p)))
		  collect_shared_info(sc, ci, slot_value(p));
	    }
	  break;
	}	  
    }
  return(ci);
}


static shared_info *new_shared_info(s7_scheme *sc)
{
  shared_info *ci;
  if (sc->circle_info == NULL)
    {
      ci = (shared_info *)calloc(1, sizeof(shared_info));
      ci->size = INITIAL_SHARED_INFO_SIZE;
      ci->objs = (s7_pointer *)malloc(ci->size * sizeof(s7_pointer));
      ci->refs = (int *)calloc(ci->size, sizeof(int));   /* finder expects 0 = unseen previously */
      sc->circle_info = ci;
    }
  else 
    {
      ci = sc->circle_info;
      memset((void *)(ci->refs), 0, ci->top * sizeof(int));
    }
  ci->top = 0;
  ci->ref = 0;
  ci->has_hits = false;
  return(ci);
}


static shared_info *make_shared_info(s7_scheme *sc, s7_pointer top)
{
  shared_info *ci;
  int i, refs;
  s7_pointer *ci_objs;
  int *ci_refs;
  bool no_problem = true;
  s7_pointer x;

  /* check for simple cases first */
  if (is_pair(top))
    {
      if (s7_list_length(sc, top) != 0) /* it is not circular at the top level (following cdr), so we can check each car(x) */
	{
	  for (x = top; is_pair(x); x = cdr(x))
	    if (has_structure(car(x)))
	      {
		/* it can help a little in some cases to scan vectors here (and slots):
		 *   if no element has structure, it's ok (maybe also hash_table_entries == 0)
		 */
		no_problem = false;
		break;
	      }
	  if ((no_problem) &&
	      (!is_null(x)) &&
	      (has_structure(x)))
	    no_problem = false;
	    
	  if (no_problem)
	    return(NULL);
	}
    }
  else
    {
      if (s7_is_vector(top))
	{
	  if (type(top) != T_VECTOR)
	    return(NULL);

	  for (i = 0; i < vector_length(top); i++)
	    if (has_structure(vector_element(top, i)))
	      {
		no_problem = false;
		break;
	      }
	  if (no_problem)
	    return(NULL);
	}
    }

  ci = new_shared_info(sc);

  /* collect all pointers associated with top */
  collect_shared_info(sc, ci, top);

  {
    int i;
    for (i = 0; i < ci->top; i++)
      {
	s7_pointer p;
	p = ci->objs[i];
	clear_collected(p);
      }
  }

  if (!(ci->has_hits))
    return(NULL);

  ci_objs = ci->objs;
  ci_refs = ci->refs;

  /* find if any were referenced twice */
  for (i = 0, refs = 0; i < ci->top; i++)
    if (ci_refs[i] > 0)
      {
	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);
}


#define WITH_ELLIPSES false

static int circular_list_entries(s7_pointer lst)
{
  int i;
  s7_pointer x;
  for (i = 1, x = cdr(lst); ; i++, x = cdr(x))
    {
      int j;
      s7_pointer y;
      for (y = lst, j = 0; j < i; y = cdr(y), j++)
	if (x == y)
	  return(i);
    }
}


static void object_to_port_with_circle_check(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci);
static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci);
static s7_pointer write_or_display(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write);

static char *multivector_indices_to_string(s7_scheme *sc, s7_Int index, s7_pointer vect, char *str, int cur_dim)
{
  s7_Int size, ind;
  char buf[64];

  size = vector_dimension(vect, cur_dim);
  ind = index % size;
  if (cur_dim > 0)
    multivector_indices_to_string(sc, (index - ind) / size, vect, str, cur_dim - 1);

  snprintf(buf, 64, " %lld", ind);
  strcat(str, buf);
  return(str);
}


static int multivector_to_port(s7_scheme *sc, s7_pointer vec, s7_pointer port, 
			       int out_len, int flat_ref, int dimension, int dimensions, bool *last, 
			       use_write_t use_write, bool to_file, shared_info *ci)
{
  int i;

  if (use_write != USE_READABLE_WRITE)
    {
      if (*last)
	port_write_string(port)(sc, " (", 2, port);
      else port_write_character(port)(sc, '(', port);
      (*last) = false;
    }

  for (i = 0; i < vector_dimension(vec, dimension); i++)
    {
      if (dimension == (dimensions - 1))
	{
	  if (flat_ref < out_len)
	    {
	      int plen;
	      char buf[128];
	      if (use_write == USE_READABLE_WRITE)
		{
		  char *indices;
		  /* need to translate flat_ref into a set of indices
		   */
		  indices = (char *)calloc(128, sizeof(char));
		  plen = snprintf(buf, 128, "(set! ({v}%s) ", multivector_indices_to_string(sc, flat_ref, vec, indices, dimension));
		  port_write_string(port)(sc, buf, plen, port);
		  free(indices);
		}

	      if (is_int_vector(vec))
		{
		  plen = snprintf(buf, 128, "%lld", int_vector_element(vec, flat_ref));
		  port_write_string(port)(sc, buf, plen, port);
		}
	      else
		{
		  if (is_float_vector(vec))
		    {
		      plen = snprintf(buf, 128, "%.*g", WRITE_REAL_PRECISION, float_vector_element(vec, flat_ref));
		      floatify(buf, &plen);
		      port_write_string(port)(sc, buf, plen, port);
		    }
		  else object_to_port_with_circle_check(sc, vector_element(vec, flat_ref), port, DONT_USE_DISPLAY(use_write), to_file, ci); 
		}

	      if (use_write == USE_READABLE_WRITE)
		port_write_string(port)(sc, ") ", 2, port);
	      flat_ref++;
	    }
	  else
	    {
	      port_write_string(port)(sc, "...)", 4, port);
	      return(flat_ref);
	    }
	  if ((use_write != USE_READABLE_WRITE) &&
	      (i < (vector_dimension(vec, dimension) - 1)))
	    port_write_character(port)(sc, ' ', port);
	}
      else 
	{
	  if (flat_ref < out_len)
	    flat_ref = multivector_to_port(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, DONT_USE_DISPLAY(use_write), to_file, ci);
	  else 
	    {
	      port_write_string(port)(sc, "...)", 4, port);
	      return(flat_ref);
	    }
	}
    }
  if (use_write != USE_READABLE_WRITE)
    port_write_character(port)(sc, ')', port);
  (*last) = true;
  return(flat_ref);
}


static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci)
{
  s7_Int i, len;
  int plen;
  bool too_long = false;
  char buf[128];
  
  len = vector_length(vect);
  if (len == 0)
    {
      if (vector_is_multidimensional(vect))
	{
	  plen = snprintf(buf, 32, "#%dD()", vector_ndims(vect));
	  port_write_string(port)(sc, buf, plen, port);
	}
      else port_write_string(port)(sc, "#()", 3, port);
      return;
    }
  
  if ((!to_file) &&
      (use_write != USE_READABLE_WRITE))
    {
      /* if to_file we ignore *vector-print-length* so a subsequent read will be ok
       *
       * (with-output-to-file "test.test" 
       *   (lambda () 
       *     (let ((vect (make-vector (+ *vector-print-length* 2) 1.0))) 
       *       (write vect))))
       */

      plen = s7_vector_print_length(sc);
      if (plen <= 0)
	{
	  if (vector_is_multidimensional(vect))
	    {
	      plen = snprintf(buf, 32, "#%dD(...)", vector_ndims(vect));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  else port_write_string(port)(sc, "#(...)", 6, port);
	  return;
	}

      if (len > plen)
	{
	  too_long = true;
	  len = plen;
	}
    }

  if (use_write == USE_READABLE_WRITE)
    {
      port_write_string(port)(sc, "(let (({v} (make-vector ", 24, port);
      if (vector_is_multidimensional(vect))
	{
	  unsigned int dim;
	  port_write_string(port)(sc, "'(", 2, port);
	  for (dim = 0; dim < vector_ndims(vect); dim++)
	    {
	      plen = snprintf(buf, 128, "%lld ", vector_dimension(vect, dim));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  if (is_int_vector(vect))
	    port_write_string(port)(sc, ") 0 #t))) ", 10, port);
	  else
	    {
	      if (is_float_vector(vect))
		port_write_string(port)(sc, ") 0.0 #t))) ", 12, port);
	      else port_write_string(port)(sc, ")))) ", 5, port);
	    }
	}
      else
	{
	  if (is_int_vector(vect))
	    plen = snprintf(buf, 128, "%lld 0 #t))) ", vector_length(vect));
	  else
	    {
	      if (is_float_vector(vect))
		plen = snprintf(buf, 128, "%lld 0.0 #t))) ", vector_length(vect));
	      else plen = snprintf(buf, 128, "%lld))) ", vector_length(vect));
	    }
	  port_write_string(port)(sc, buf, plen, port);
	}

      if ((ci) &&
	  (shared_ref(ci, vect) < 0))
	{
	  plen = snprintf(buf, 128, "(set! {%d} {v}) ", -shared_ref(ci, vect));
	  port_write_string(port)(sc, buf, plen, port);
	}

      if (vector_is_multidimensional(vect))
	{
	  bool last = false;
	  multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), &last, use_write, to_file, ci);
	}
      else
	{
	  for (i = 0; i < len; i++)
	    {
	      port_write_string(port)(sc, "(set! ({v} ", 11, port);
	      plen = snprintf(buf, 128, "%lld) ", i);
	      port_write_string(port)(sc, buf, plen, port);

	      if (is_int_vector(vect))
		{
		  plen = snprintf(buf, 128, "%lld", int_vector_element(vect, i));
		  port_write_string(port)(sc, buf, plen, port);
		}
	      else
		{
		  if (is_float_vector(vect))
		    {
		      plen = snprintf(buf, 128, "%.*g", WRITE_REAL_PRECISION, float_vector_element(vect, i));
		      floatify(buf, &plen);
		      port_write_string(port)(sc, buf, plen, port);
		    }
		  else object_to_port_with_circle_check(sc, vector_element(vect, i), port, use_write, to_file, ci);
		}

	      port_write_string(port)(sc, ") ", 2, port);
	    }
	}
      port_write_string(port)(sc, "{v})", 4, port);
    }
  else
    {
      if (vector_is_multidimensional(vect))
	{
	  bool last = false;
	  if (vector_ndims(vect) > 1)
	    {
	      plen = snprintf(buf, 32, "#%dD", vector_ndims(vect));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  else port_write_character(port)(sc, '#', port);
	  multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), &last, use_write, to_file, ci);
	}
      else
	{
	  port_write_string(port)(sc, "#(", 2, port);
	  if (is_int_vector(vect))
	    {
	      for (i = 0; i < len - 1; i++)
		{
		  plen = snprintf(buf, 128, "%lld ", int_vector_element(vect, i));
		  port_write_string(port)(sc, buf, plen, port);
		}
	      plen = snprintf(buf, 128, "%lld", int_vector_element(vect, i));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  else
	    {
	      if (is_float_vector(vect))
		{
		  plen = snprintf(buf, 128, "%.*g", WRITE_REAL_PRECISION, float_vector_element(vect, 0));
		  floatify(buf, &plen);
		  port_write_string(port)(sc, buf, plen, port);
		  for (i = 1; i < len; i++)
		    {
		      plen = snprintf(buf, 128, " %.*g", WRITE_REAL_PRECISION, float_vector_element(vect, i));
		      floatify(buf, &plen);
		      port_write_string(port)(sc, buf, plen, port);
		    }
		}
	      else
		{
		  for (i = 0; i < len - 1; i++)
		    {
		      object_to_port_with_circle_check(sc, vector_element(vect, i), port, DONT_USE_DISPLAY(use_write), to_file, ci);
		      port_write_character(port)(sc, ' ', port);
		    }
		  object_to_port_with_circle_check(sc, vector_element(vect, i), port, DONT_USE_DISPLAY(use_write), to_file, ci);
		}
	    }

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);
	}
    }
}


static void bytevector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, bool to_file)
{
  s7_Int i, len, plen;
  bool too_long = false;

  len = string_length(vect);
  if (use_write == USE_READABLE_WRITE)
    plen = len;
  else plen = s7_vector_print_length(sc);

  if (len == 0)
    port_write_string(port)(sc, "#u8()", 5, port);
  else
    {
      if (plen <= 0)
	port_write_string(port)(sc, "#u8(...)", 8, port);
      else
	{
	  int nlen;
          #define BYTE_TO_STR_SIZE 8
	  char byte_to_str[BYTE_TO_STR_SIZE];

	  if (len > plen)
	    {
	      too_long = true;
	      len = plen;
	    }
	  port_write_string(port)(sc, "#u8(", 4, port);
	  for (i = 0; i < len - 1; i++)
	    {
	      nlen = snprintf(byte_to_str, BYTE_TO_STR_SIZE, "%d", (unsigned int)((unsigned char)string_value(vect)[i])); /* casts are not redundant */
	      port_write_string(port)(sc, byte_to_str, nlen, port);
	      port_write_character(port)(sc, ' ', port);
	    }
	  nlen = snprintf(byte_to_str, BYTE_TO_STR_SIZE, "%d", (unsigned int)((unsigned char)string_value(vect)[i]));
	  port_write_string(port)(sc, byte_to_str, nlen, port);

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);
	}
    }
}


static void list_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci)
{
  s7_pointer x;
  int i, len, true_len;

  true_len = s7_list_length(sc, lst);
  if (true_len < 0)                    /* a dotted list -- handle cars, then final cdr */
    len = (-true_len + 1);
  else
    {
      if (true_len == 0)               /* either '() or a circular list */
	{
	  if (is_not_null(lst))
	    len = circular_list_entries(lst);
	  else
	    {
	      port_write_string(port)(sc, "()", 2, port);
	      return;
	    }
	}
      else len = true_len;
    }

  if (((car(lst) == sc->QUOTE) || 
       (car(lst) == sc->QUOTE_UNCHECKED)) && /* this can happen (see lint.scm) */
      (true_len == 2))
    {
      /* len == 1 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)
       *
       * in CL:
       *    [2]> (list 'quote 1 2)
       *    (QUOTE 1 2)
       *    [3]> (list 'quote 1)
       *    '1
       *    [4]> (cons 'quote 1)
       *    (QUOTE . 1)
       *
       * in s7:
       *    :(list 'quote 1 2)
       *    (quote 1 2)
       *    :(list 'quote 1)
       *    '1
       *    :(cons 'quote 1)
       *    (quote . 1)
       *    (write (list 'quote 1))
       *    -> '1
       */

      port_write_character(port)(sc, '\'', port);
      object_to_port_with_circle_check(sc, cadr(lst), port, DONT_USE_DISPLAY(use_write), to_file, ci);
      return;
    }
  else port_write_character(port)(sc, '(', port);

  if (is_multiple_value(lst))
    port_write_string(port)(sc, "values ", 7, port);

  if (use_write == USE_READABLE_WRITE)
    {
      if (ci) 
	{
	  int plen;
	  char buf[128];

	  port_write_string(port)(sc, "let (({lst} (make-list ", 23, port);
	  plen = snprintf(buf, 128, "%d))) ", len);
	  port_write_string(port)(sc, buf, plen, port);

	  if ((shared_ref(ci, lst) < 0))
	    {
	      plen = snprintf(buf, 128, "(set! {%d} {lst}) ", -shared_ref(ci, lst));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  
	  port_write_string(port)(sc, "(let (({x} {lst})) ", 19, port);
	  for (i = 0, x = lst; (i < len) && (is_pair(x)); i++, x = cdr(x))
	    {
	      port_write_string(port)(sc, "(set-car! {x} ", 14, port);
	      object_to_port_with_circle_check(sc, car(x), port, use_write, to_file, ci);
	      port_write_string(port)(sc, ") ", 2, port);
	      if (i < len - 1)
		port_write_string(port)(sc, "(set! {x} (cdr {x})) ", 21, port);
	    }
	  if (!is_null(x))
	    {
	      port_write_string(port)(sc, "(set-cdr! {x} ", 14, port);
	      object_to_port_with_circle_check(sc, x, port, use_write, to_file, ci);
	      port_write_string(port)(sc, ") ", 2, port);
	    }
	  port_write_string(port)(sc, ") {lst})", 8, port);
	}
      else
	{
	  /* the easier cases: no circles or shared refs to patch up */
	  if (true_len > 0)
	    {
	      port_write_string(port)(sc, "list", 4, port);
	      for (x = lst; is_pair(x); x = cdr(x))
		{
		  port_write_character(port)(sc, ' ', port);
		  object_to_port_with_circle_check(sc, car(x), port, use_write, to_file, ci);
		}
	      port_write_character(port)(sc, ')', port);
	    }
	  else
	    {
	      port_write_string(port)(sc, "cons ", 5, port);
	      object_to_port_with_circle_check(sc, car(lst), port, use_write, to_file, ci);
	      for (x = cdr(lst); is_pair(x); x = cdr(x))
		{
		  port_write_character(port)(sc, ' ', port);
		  port_write_string(port)(sc, "(cons ", 6, port);
		  object_to_port_with_circle_check(sc, car(x), port, use_write, to_file, ci);
		}
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, x, port, use_write, to_file, ci);
	      for (i = 1; i < len; i++)
		port_write_character(port)(sc, ')', port);
	    }
	}
    }
  else
    {
      for (x = lst, i = 0; (is_pair(x)) && (i < len) && ((!ci) || (i == 0) || (peek_shared_ref(ci, x) == 0)); i++, x = cdr(x))
	{
	  object_to_port_with_circle_check(sc, car(x), port, DONT_USE_DISPLAY(use_write), to_file, ci);
	  if (i < (len - 1)) 
	    port_write_character(port)(sc, ' ', port);
	}
      if (is_not_null(x))
	{
	  if ((true_len == 0) &&
	      (i == len))
	    port_write_string(port)(sc, " . ", 3, port);
	  else port_write_string(port)(sc, ". ", 2, port);
	  object_to_port_with_circle_check(sc, x, port, DONT_USE_DISPLAY(use_write), to_file, ci);
	}
      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, bool to_file, shared_info *ci)
{
  int i, len, gc_iter;
  bool too_long = false;
  s7_pointer iterator;
  
  /* if hash is a member of ci, just print its number
   * (let ((ht (hash-table '(a . 1)))) (hash-table-set! ht 'b ht))
   *
   * since equal? does not care about the hash-table lengths, we can ignore that complication in the :readable case
   */

  len = hash_table_entries(hash);
  if (len == 0)
    {
      if (use_write == USE_READABLE_WRITE)
	port_write_string(port)(sc, "(hash-table)", 12, port);
      else port_write_string(port)(sc, "#<hash-table>", 13, port);
      return;
    }

  if ((use_write != USE_READABLE_WRITE) &&
      (!to_file))
    {
      int plen;
      plen = s7_vector_print_length(sc);
      if (plen <= 0)
	{
	  port_write_string(port)(sc, "#<hash-table ...>", 17, port);
	  return;
	}
      if (len > plen)
	{
	  too_long = true;
	  len = plen;
	}
    }

  iterator = g_make_hash_table_iterator(sc, list_1(sc, hash));
  gc_iter = s7_gc_protect(sc, iterator);

  if (use_write == USE_READABLE_WRITE)
    {
      port_write_string(port)(sc, "(let (({ht} (make-hash-table)))", 31, port);
      if ((ci) &&
	  (shared_ref(ci, hash) < 0))
	{
	  int plen;
	  char buf[64];
	  plen = snprintf(buf, 64, "(set! {%d} {ht}) ", -shared_ref(ci, hash));
	  port_write_string(port)(sc, buf, plen, port);
	}
      for (i = 0; i < len; i++)
	{
	  s7_pointer key_val, key, val;

	  key_val = hash_table_iterate(sc, iterator);
	  key = car(key_val);
	  val = cdr(key_val);

	  port_write_string(port)(sc, " (set! ({ht} ", 13, port);	  
	  if (key == hash)
	    port_write_string(port)(sc, "{ht}", 4, port);
	  else object_to_port_with_circle_check(sc, key, port, USE_READABLE_WRITE, to_file, ci);
	  port_write_string(port)(sc, ") ", 2, port);
	  if (val == hash)
	    port_write_string(port)(sc, "{ht}", 4, port);
	  else object_to_port_with_circle_check(sc, val, port, USE_READABLE_WRITE, to_file, ci);
	  port_write_character(port)(sc, ')', port);
	}
      port_write_string(port)(sc, " {ht})", 6, port);
    }
  else 
    {
      port_write_string(port)(sc, "#<hash-table ", 13, port);
      for (i = 0; i < len - 1; i++)
	{
	  object_to_port_with_circle_check(sc, hash_table_iterate(sc, iterator), port, DONT_USE_DISPLAY(use_write), to_file, ci);
	  port_write_character(port)(sc, ' ', port);
	}
      object_to_port_with_circle_check(sc, hash_table_iterate(sc, iterator), port, DONT_USE_DISPLAY(use_write), to_file, ci);
      if (too_long)
	port_write_string(port)(sc, " ...>", 5, port);
      else port_write_character(port)(sc, '>', port);
    }

  s7_gc_unprotect_at(sc, gc_iter);
}


static void write_readably_error(s7_scheme *sc, const char *type)
{
  s7_error(sc, make_symbol(sc, "io-error"), 
	   list_2(sc, 
		  make_protected_string(sc, "can't write ~A readably"),
		  make_protected_string(sc, type)));
}


static void environment_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci)
{
  /* if outer env points to (say) method list, the object needs to specialize object->string itself
   */
  if (has_methods(obj))
    {
      s7_pointer print_func;
      print_func = find_method(sc, obj, sc->OBJECT_TO_STRING);
      if (print_func != sc->UNDEFINED)
	{
	  s7_pointer p;
	  /* what needs to be protected here? */
	  push_stack(sc, OP_NO_OP, sc->temp_cell_2, sc->temp_cell_3);
	  if (use_write == USE_WRITE)
	    p = s7_apply_function(sc, print_func, list_1(sc, obj));
	  else p = s7_apply_function(sc, print_func, list_2(sc, obj, (use_write == USE_DISPLAY) ? sc->F : sc->KEY_READABLE));
	  sc->temp_cell_2 = main_stack_args(sc);
	  sc->temp_cell_3 = main_stack_code(sc);
	  pop_main_stack(sc);
	  
	  if (string_length(p) > 0)
	    port_write_string(port)(sc, string_value(p), string_length(p), port);
	  return;
	}
    }
  if (obj == sc->global_env)
    {
      if (use_write == USE_READABLE_WRITE)
	port_write_string(port)(sc, "(global-environment)", 20, port);
      else port_write_string(port)(sc, "#<global-environment>", 21, port);
    }
  else
    {
      /* circles can happen here: 
       *    (let () (let ((b (current-environment))) (current-environment)))
       *    #<environment #<slot: b #<environment>>>
       * or (let ((b #f)) (set! b (current-environment)) (current-environment))
       *    #1=#<environment #<slot: b #1#>>
       */
      s7_pointer x;
      
      if (use_write == USE_READABLE_WRITE)
	{
	  if (obj == sc->error_env)
	    port_write_string(port)(sc, "(error-environment)", 19, port);
	  else
	    {
	      if (obj == sc->stacktrace_env)
		port_write_string(port)(sc, "*stacktrace*", 12, port);
	      else
		{
		  port_write_string(port)(sc, "(let (({e} (environment))) ", 27, port);
		  if ((ci) &&
		      (shared_ref(ci, obj) < 0))
		    {
		      int plen;
		      char buf[64];
		      plen = snprintf(buf, 64, "(set! {%d} {e}) ", -shared_ref(ci, obj));
		      port_write_string(port)(sc, buf, plen, port);
		    }

		  port_write_string(port)(sc, "(apply augment-environment! {e} (reverse (list ", 47, port);
		  for (x = environment_slots(obj); is_slot(x); x = next_slot(x))
		    {
		      port_write_string(port)(sc, "(cons ", 6, port);
		      object_to_port(sc, slot_symbol(x), port, use_write, to_file, ci);
		      port_write_character(port)(sc, ' ', port);
		      object_to_port_with_circle_check(sc, slot_value(x), port, use_write, to_file, ci);
		      port_write_character(port)(sc, ')', port);
		    }
		  port_write_string(port)(sc, "))) {e})", 8, port);
		}
	    }
	}
      else
	{
	  port_write_string(port)(sc, "#<environment", 13, port);
	  for (x = environment_slots(obj); is_slot(x); x = next_slot(x))
	    {
	      port_write_string(port)(sc, "\n  ", 3, port);
	      object_to_port_with_circle_check(sc, x, port, use_write, to_file, ci);
	    }
	  port_write_character(port)(sc, '>', port);
	}
    }
}


static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  s7_pointer arglist, body, expr;
  bool starred;

  body = cadar(closure_body(obj));
  arglist = cadr(body);
  starred = (car(body) == sc->LAMBDA_STAR);
  body = cddr(body);

  port_write_string(port)(sc, "(symbol->value (define-", 23, port);
  port_write_string(port)(sc, (type(obj) == T_MACRO) ? "macro" : "bacro", 5, port); 
  if (starred)
    port_write_character(port)(sc, '*', port);
  port_write_string(port)(sc, " (_m_", 5, port);
  if (is_symbol(arglist))
    {
      port_write_string(port)(sc, " . ", 3, port);
      port_write_string(port)(sc, symbol_name(arglist), symbol_name_length(arglist), port);
    }
  else
    {
      if (is_pair(arglist))
	{
	  for (expr = arglist; is_pair(expr); expr = cdr(expr))
	    {
	      port_write_character(port)(sc, ' ', port);
	      object_to_port(sc, car(expr), port, USE_WRITE, false, NULL);
	    }
	  if (!is_null(expr))
	    {
	      port_write_string(port)(sc, " . ", 3, port);
	      object_to_port(sc, expr, port, USE_WRITE, false, NULL);
	    }
	}
    }
  port_write_string(port)(sc, ") ", 2, port);
  for (expr = body; is_pair(expr); expr = cdr(expr))
    object_to_port(sc, car(expr), port, USE_WRITE, false, NULL);
  port_write_string(port)(sc, "))", 2, port);
}


static s7_pointer match_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  s7_pointer y, le;
  for (le = e; is_environment(le) && (le != sc->global_env); le = next_environment(le))
    for (y = environment_slots(le); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	return(y);
  return(NULL);
}

static bool slot_memq(s7_pointer symbol, s7_pointer symbols)
{
  s7_pointer x;
  for (x = symbols; is_pair(x); x = cdr(x))
    if (slot_symbol(x) == symbol)
      return(x);
  return(NULL);
}


static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, int gc_loc)
{
  if (is_pair(body))
    {
      collect_locals(sc, car(body), e, gc_loc);
      collect_locals(sc, cdr(body), e, gc_loc);
    }
  else
    {
      if (is_symbol(body))
	{
	  if (!slot_memq(body, gc_protected_at(sc, gc_loc)))
	    {
	      s7_pointer slot;
	      slot = match_symbol(sc, body, e);
	      if (slot)
		gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc));
	    }
	}
    }
}


static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  s7_pointer body, arglist, pe, local_slots, p;
  int gc_loc;

  body = closure_body(obj);
  arglist = closure_args(obj);
  pe = closure_environment(obj);
  gc_loc = s7_gc_protect(sc, sc->NIL);
  collect_locals(sc, body, pe, gc_loc);
  local_slots = gc_protected_at(sc, gc_loc);

  if (!is_null(local_slots))
    {
      s7_pointer x, slot;
      port_write_string(port)(sc, "(let (", 6, port);
      for (x = local_slots; is_pair(x); x = cdr(x))
	{
	  slot = car(x);
	  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);
	  write_or_display(sc, slot_value(slot), port, USE_WRITE);
	  port_write_character(port)(sc, ')', port);
	}
      port_write_string(port)(sc, ") ", 2, port);
    }

  port_write_string(port)(sc, "(lambda", 7, port);
  if (type(obj) == T_CLOSURE_STAR)
    port_write_character(port)(sc, '*', port);
  port_write_character(port)(sc, ' ', port);
  write_or_display(sc, arglist, port, USE_WRITE); /* here we just want the straight output (a b) not (list 'a 'b) */
  
  for (p = body; is_pair(p); p = cdr(p))
    {
      port_write_character(port)(sc, ' ', port);
      write_or_display(sc, car(p), port, USE_WRITE);
    }
  port_write_character(port)(sc, ')', port);
  
  if (!is_null(local_slots))
    port_write_character(port)(sc, ')', port);
  s7_gc_unprotect_at(sc, gc_loc);
}


static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci)
{
  int nlen = 0;
  char *str;
  char buf[64];
  
  switch (type(obj))
    {
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      vector_to_port(sc, obj, port, use_write, to_file, ci);
      break;

    case T_PAIR:
      list_to_port(sc, obj, port, use_write, to_file, ci);
      break;

    case T_HASH_TABLE:
      hash_table_to_port(sc, obj, port, use_write, to_file, ci);
      break;

    case T_ENVIRONMENT:
      environment_to_port(sc, obj, port, use_write, to_file, ci);
      break;

    case T_BOOLEAN:
    case T_NIL:
    case T_UNIQUE:
      port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
      break;

    case T_INPUT_PORT:
      if (obj == sc->standard_input)
	port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
      else
	{
	  if (use_write == USE_READABLE_WRITE)
	    {
	      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))
		    write_readably_error(sc, "a function input port");
		  else
		    {
		      if (port_read_character(port) == file_read_char)
			write_readably_error(sc, "a very large file input port");
		      else
			{
			  if (port_string_point(obj) != 0)
			    port_write_string(port)(sc, "(let ((p ", 9, port);
			  if (port_filename(obj) != NULL)
			    {
			      /* try to avoid storing enormous in-core strings */
			      port_write_string(port)(sc, "(open-input-file \"", 18, port);
			      port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
			      port_write_string(port)(sc, "\")", 2, port);
			    }
			  else
			    {
			      char *str;
			      int nlen = 0;
			      port_write_string(port)(sc, "(open-input-string ", 19, port);
			      /* not port_write_string here because there might be embedded double-quotes */
			      str = slashify_string(sc, port_string(obj), port_string_length(obj), IN_QUOTES, &nlen);
			      port_write_string(port)(sc, str, nlen, port);
			      port_write_character(port)(sc, ')', port);
			    }
			  if (port_string_point(obj) != 0)
			    {
			      char buf[64];
			      int plen;
			      port_write_string(port)(sc, ")) (do ((i 0 (+ i 1))) ((= i ", 29, port);
			      plen = snprintf(buf, 64, "%d) p) (read-char p)))", port_string_point(obj));
			      port_write_string(port)(sc, buf, plen, port);
			    }
			}
		    }
		}
	    }
	  else
	    {
	      nlen = snprintf(buf, 64, "<input-%s-port%s>", 
			      (is_file_port(obj)) ? "file" : ((is_string_port(obj)) ? "string" : "function"), 
			      (port_is_closed(obj)) ? " (closed)" : "");
	    }
	  port_write_string(port)(sc, buf, nlen, port);
	}
      break;

    case T_OUTPUT_PORT:
      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 == USE_READABLE_WRITE)
	    {
	      if (port_is_closed(obj))
		port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port);
	      else write_readably_error(sc, "an output port");
	      /* there's nothing safe or even modestly foolproof that we can do here */
	    }
	  else
	    {
	      nlen = snprintf(buf, 64, "<output-%s-port%s>", 
			      (is_file_port(obj)) ? "file" : ((is_string_port(obj)) ? "string" : "function"), 
			      (port_is_closed(obj)) ? " (closed)" : "");
	      port_write_string(port)(sc, buf, nlen, port);
	    }
	}
      break;

    case T_COUNTER:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "an internal for-each descriptor");
      nlen = snprintf(buf, 64, "#<counter: %lld>", counter_count(obj));
      port_write_string(port)(sc, buf, nlen, port);
      break;

    case T_BAFFLE:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "an internal with-baffle descriptor");
      nlen = snprintf(buf, 64, "#<baffle: %d>", baffle_key(obj));
      port_write_string(port)(sc, buf, nlen, port);
      break;

    case T_INTEGER:
      if (has_print_name(obj))
	port_write_string(port)(sc, print_name(obj), print_name_length(obj), port);
      else
	{
	  nlen = 0;
	  str = integer_to_string_base_10_no_width(obj, &nlen);
	  if (nlen > 0)
	    {
	      set_print_name(obj, str, nlen);
	      port_write_string(port)(sc, str, nlen, port);
	    }
	  else port_display(port)(sc, str, port);
	}
      break;

    case T_REAL:
    case T_RATIO:
    case T_COMPLEX:
      if (has_print_name(obj))
	port_write_string(port)(sc, print_name(obj), print_name_length(obj), port);
      else
	{
	  nlen = 0;
	  str = number_to_string_base_10(obj, 0, WRITE_REAL_PRECISION, 'g', &nlen, use_write); /* was 14 */
	  if (nlen > 0)
	    {
	      set_print_name(obj, str, nlen);
	      port_write_string(port)(sc, str, nlen, port);
	    }
	  else 
	    {
	      set_print_name(obj, str, safe_strlen(str));
	      port_display(port)(sc, str, port);
	    }
	}
      break;

#if WITH_GMP
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
    case T_BIG_REAL:
    case T_BIG_COMPLEX:
      nlen = 0;
      str = big_number_to_string_with_radix(obj, BASE_10, 0, &nlen, use_write);
      if (nlen > 0)
	port_write_string(port)(sc, str, nlen, port);
      else port_display(port)(sc, str, port);
      free(str);
      break;
#endif

    case T_SYMBOL:
      /* I think this is the only place we print a symbol's name */
      if ((symbol_name(obj)[0] == '#') ||                 /* otherwise the reader thinks there's a #-reader problem */
	  (needs_slashification(symbol_name(obj), symbol_name_length(obj))))
	{
	  char *symstr;
	  str = slashify_string(sc, symbol_name(obj), symbol_name_length(obj), NOT_IN_QUOTES, &nlen);
	  nlen += 16;
	  symstr = (char *)calloc(nlen, sizeof(char));
	  nlen = snprintf(symstr, nlen, "(symbol \"%s\")", str);
	  port_write_string(port)(sc, symstr, nlen, port);
	  free(symstr);
	}
      else 
	{
	  if ((use_write == USE_READABLE_WRITE) &&
	      (!is_keyword(obj)))
	    port_write_character(port)(sc, '\'', port);
	  port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port);
	}
      break;

    case T_SYNTAX:
      port_display(port)(sc, op_names[(int)syntax_opcode(obj)], port);
      break;

    case T_STRING:
      if (is_bytevector(obj))
	bytevector_to_port(sc, obj, port, use_write, to_file);
      else
	{
	  if (string_length(obj) > 0)
	    {
	      /* this used to check for length > 1<<24 -- is that still necessary?
	       * since string_length is a scheme length, not C, this write can embed nulls from C's point of view 
	       */
	      if (use_write == USE_DISPLAY)
		port_write_string(port)(sc, string_value(obj), string_length(obj), port);
	      else
		{
		  if (!needs_slashification(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
		    {
		      str = slashify_string(sc, string_value(obj), string_length(obj), IN_QUOTES, &nlen);
		      port_write_string(port)(sc, str, nlen, port);
		    }
		}
	    }
	  else
	    {
	      if (use_write != USE_DISPLAY)
		port_write_string(port)(sc, "\"\"", 2, port);
	    }
	}
      break;

    case T_CHARACTER:
      if (use_write == USE_DISPLAY) 
	port_write_character(port)(sc, character(obj), port);
      else port_write_string(port)(sc, character_name(obj), character_name_length(obj), port);
      break;

    case T_MACRO:
      if (use_write == USE_READABLE_WRITE)
	write_macro_readably(sc, obj, port);
      else port_write_string(port)(sc, "#<macro>", 8, port);
      break;

    case T_BACRO:
      if (use_write == USE_READABLE_WRITE)
	write_macro_readably(sc, obj, port);
      else port_write_string(port)(sc, "#<bacro>", 8, port);
      break;

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(obj))
	{
	  /* look for object->string method else fallback on ordinary case.
	   * can't use recursion on closure_environment here because then the fallback name is #<environment>.
	   */
	  s7_pointer print_func;
	  print_func = find_method(sc, closure_environment(obj), sc->OBJECT_TO_STRING);
	  if (print_func != sc->UNDEFINED)
	    {
	      s7_pointer p;
	      p = s7_apply_function(sc, print_func, list_1(sc, obj));
	      if (string_length(p) > 0)
		port_write_string(port)(sc, string_value(p), string_length(p), port);
	      break;
	    }
	}
      if (use_write == USE_READABLE_WRITE)
	write_closure_readably(sc, obj, port);
      else
	{
	  const char *p;
	  p = c_closure_name(sc, obj, &nlen);
	  if (nlen > 0)
	    port_write_string(port)(sc, p, nlen, port);
	}
      break;
  
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION:
      port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
      break;

    case T_C_MACRO:
      port_write_string(port)(sc, c_macro_name(obj), c_macro_name_length(obj), port);
      break;
  
    case T_C_POINTER:
      if (use_write == USE_READABLE_WRITE)
	{
#if (SIZEOF_VOID_P == 4)
	  if ((long)raw_pointer(obj) < 2) /* 0 = NULL is the main case, -1 is used in some libraries */
	    nlen = snprintf(buf, 64, "(c-pointer %ld)", (long)raw_pointer(obj));
#else
	  if ((long long int)raw_pointer(obj) < 2) /* 0 = NULL is the main case, -1 is used in some libraries */
	    nlen = snprintf(buf, 64, "(c-pointer %lld)", (long long int)raw_pointer(obj));
#endif
	  else write_readably_error(sc, "raw c pointer");
	}
      else nlen = snprintf(buf, 64, "#<c_pointer %p>", raw_pointer(obj));
      port_write_string(port)(sc, buf, nlen, port);
      break;
  
    case T_CONTINUATION:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "a continuation");
      port_write_string(port)(sc, "#<continuation>", 15, port);
      break;
  
    case T_GOTO:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "a call-with-exit goto");
      port_write_string(port)(sc, "#<goto>", 7, port);
      break;
  
    case T_CATCH:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "an internal catch descriptor");
      port_write_string(port)(sc, "#<catch>", 8, port);
      break;

    case T_DYNAMIC_WIND:
      /* this can happen (or could while *stack* was tied in) because *stack* can involve dynamic-wind markers */
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "an internal dynamic-wind descriptor");
      port_write_string(port)(sc, "#<dynamic-wind>", 15, port);
      break;
  
    case T_C_OBJECT:
      if ((use_write == USE_READABLE_WRITE) &&
	  (c_object_print_readably(obj)))
	str = ((*(c_object_print_readably(obj)))(sc, c_object_value(obj)));
      else str = ((*(c_object_print(obj)))(sc, c_object_value(obj)));
      port_display(port)(sc, str, port);
      free(str);
      break;

    case T_SLOT:
      if (use_write == USE_READABLE_WRITE)
	write_readably_error(sc, "an internal slot");

      port_write_string(port)(sc, "#<slot: ", 8, port);
      port_write_string(port)(sc, symbol_name(slot_symbol(obj)), symbol_name_length(slot_symbol(obj)), port);
      port_write_character(port)(sc, ' ', port);
      object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, to_file, ci);
      port_write_character(port)(sc, '>', port);
      break;

    default:
#if DEBUGGING
      {
	/* show current state, current allocated state, and previous allocated state.
	 */
	char *current_bits, *allocated_bits, *previous_bits, *str;
	int save_typeflag, len;
	const char *excl_name;
	
	if (type(obj) == T_FREE)
	  excl_name = "free cell!";
	else excl_name = "unknown object!";
	
	current_bits = describe_type_bits(sc, obj);
	save_typeflag = typeflag(obj);
	typeflag(obj) = obj->current_alloc_type;
	allocated_bits = describe_type_bits(sc, obj);
	typeflag(obj) = obj->previous_alloc_type;
	previous_bits = describe_type_bits(sc, obj);
	typeflag(obj) = save_typeflag;
	
	len = safe_strlen(excl_name) + 
          safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(previous_bits) + 
          safe_strlen(obj->previous_alloc_func) + safe_strlen(obj->current_alloc_func) + 512;
	str = (char *)calloc(len, sizeof(char));
	
	nlen = snprintf(str, len, 
			"\n<%s %s,\n  current: %s[%d] %s,\n  previous: %s[%d] %s\n  hloc: %d>", 
			excl_name, current_bits, 
			obj->current_alloc_func, obj->current_alloc_line, allocated_bits,
			obj->previous_alloc_func, obj->previous_alloc_line, previous_bits,
			heap_location(obj));

	free(current_bits);
	free(allocated_bits);
	free(previous_bits);
	port_write_string(port)(sc, str, nlen, port);
	free(str);
      }
#else
      {
	char *str, *tmp;
	int len;
	tmp = describe_type_bits(sc, obj);
	len = 32 + safe_strlen(tmp);
	str = (char *)malloc(len * sizeof(char));
	if (type(obj) == T_FREE)
	  nlen = snprintf(str, len, "<free cell! %s>", tmp);
	else nlen = snprintf(str, len, "<unknown object! %s>", tmp);
	free(tmp);
	port_write_string(port)(sc, str, nlen, port);
	free(str);
      }
#endif
      break;
    }
}


static void object_to_port_with_circle_check(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, bool to_file, shared_info *ci)
{
  if ((ci) &&
      (has_structure(vr)))
    {
      int ref;
      ref = shared_ref(ci, vr);
      if (ref != 0)
	{
	  char buf[32];
	  int nlen;
	  if (ref > 0)
	    {
	      if (use_write == USE_READABLE_WRITE)
		{
		  nlen = snprintf(buf, 32, "(set! {%d} ", ref);
		  port_write_string(port)(sc, buf, nlen, port);
		  object_to_port(sc, vr, port, USE_READABLE_WRITE, to_file, ci);
		  port_write_character(port)(sc, ')', port);
		}
	      else
		{
		  nlen = snprintf(buf, 32, "#%d=", ref);
		  port_write_string(port)(sc, buf, nlen, port);
		  object_to_port(sc, vr, port, DONT_USE_DISPLAY(use_write), WITH_ELLIPSES, ci);
		}
	    }
	  else
	    {
	      if (use_write == USE_READABLE_WRITE)
		nlen = snprintf(buf, 32, "{%d}", -ref);
	      else nlen = snprintf(buf, 32, "#%d#", -ref); 
	      port_write_string(port)(sc, buf, nlen, port);
	    }
	  return;
	}
    }
  object_to_port(sc, vr, port, use_write, to_file, ci);
  return;
}


static void setup_shared_reads(s7_scheme *sc, s7_pointer port, shared_info *ci)
{
  int i, len;
  char buf[64];

  port_write_string(port)(sc, "(let (", 6, port);
  for (i = 1; i <= ci->top; i++)
    {
      len = snprintf(buf, 64, "({%d} #f)", i);
      port_write_string(port)(sc, buf, len, port);
    }
  port_write_string(port)(sc, ") ", 2, port);
}

static void finish_shared_reads(s7_scheme *sc, s7_pointer port, shared_info *ci)
{
  port_write_character(port)(sc, ')', port);
}

static s7_pointer write_or_display(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  shared_info *ci = NULL;

  if (port_is_closed(port))
    return(s7_wrong_type_arg_error(sc, (use_write != USE_DISPLAY) ? "write" : "display", 2, port, "an open input port"));

  if (has_structure(obj))
    {
      if (obj != sc->global_env)
	ci = make_shared_info(sc, obj);
      if ((ci) &&
	  (use_write == USE_READABLE_WRITE))
	{
	  setup_shared_reads(sc, port, ci);
	  object_to_port_with_circle_check(sc, obj, port, use_write, is_file_port(port), ci);
	  finish_shared_reads(sc, port, ci);
	}
      else object_to_port_with_circle_check(sc, obj, port, use_write, is_file_port(port), ci);
    }
  else object_to_port(sc, obj, port, use_write, is_file_port(port), ci);
  return(obj);
}


static char *s7_object_to_c_string_1(s7_scheme *sc, s7_pointer obj, use_write_t use_write, int *nlen)
{
  shared_info *ci = NULL;
  char *str;
  s7_pointer strport;
  int gc_loc;

  strport = s7_open_output_string(sc);
  gc_loc = s7_gc_protect(sc, strport);

  if (has_structure(obj))
    {
      if (obj != sc->global_env)
	ci = make_shared_info(sc, obj);
      if ((ci) &&
	  (use_write == USE_READABLE_WRITE))
	{
	  setup_shared_reads(sc, strport, ci);
	  object_to_port_with_circle_check(sc, obj, strport, use_write, WITH_ELLIPSES, ci);
	  finish_shared_reads(sc, strport, ci);
	}
      else object_to_port_with_circle_check(sc, obj, strport, use_write, WITH_ELLIPSES, ci);
    }
  else object_to_port(sc, obj, strport, use_write, WITH_ELLIPSES, ci);
  str = port_string(strport);
  if (nlen) (*nlen) = port_string_point(strport);
  port_string(strport) = NULL;
  port_needs_free(strport) = false;
  s7_close_output_port(sc, strport);
  s7_gc_unprotect_at(sc, gc_loc);

  return(str);
}


char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj)
{
  return(s7_object_to_c_string_1(sc, obj, USE_WRITE, NULL));
}


s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */
{
  char *str;

  str = s7_object_to_c_string_1(sc, obj, (use_write) ? USE_WRITE : USE_DISPLAY, NULL);
  if (str)
    return(make_string_uncopied(sc, str));

  return(s7_make_string_with_length(sc, "", 0)); 
}


void s7_newline(s7_scheme *sc, s7_pointer port)
{
  s7_write_char(sc, '\n', port);
}


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"
  s7_pointer port;
  
  if (is_not_null(args))
    {
      port = car(args);
      if (!is_output_port(port))
	{
	  CHECK_METHOD(sc, port, sc->NEWLINE, args);
	  return(simple_wrong_type_argument_with_type(sc, sc->NEWLINE, port, AN_OUTPUT_PORT));
	}
    }
  else port = sc->output_port;
  
  s7_newline(sc, port);
  return(sc->UNSPECIFIED);
}


void s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  write_or_display(sc, obj, port, USE_WRITE);
}


static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
{
  #define H_write "(write str (port (current-output-port))) writes str (a string) to the output port"
  s7_pointer port;
  
  if (is_pair(cdr(args)))
    {
      port = cadr(args);
      if (!is_output_port(port))
	{
	  CHECK_METHOD(sc, port, sc->WRITE, args);
	  return(wrong_type_argument_with_type(sc, sc->WRITE, small_int(2), port, AN_OUTPUT_PORT));
	}
    }
  else port = sc->output_port;
  write_or_display(sc, car(args), port, USE_WRITE);
  return(sc->UNSPECIFIED);
}

/* currently: 
 *   (let ((x (list 1 2))) (write (list x x))) 
 * writes (#1=(1 2) #1#) as does display
 * but there are no circles here, so this seems unnecessarily ugly
 */


void s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  write_or_display(sc, obj, port, USE_DISPLAY);
}


static s7_pointer g_display(s7_scheme *sc, s7_pointer args)
{
  #define H_display "(display obj (port (current-output-port))) prints obj"
  s7_pointer port;
  
  if (is_pair(cdr(args)))
    {
      port = cadr(args);
      if (!is_output_port(port))
	{
	  CHECK_METHOD(sc, port, sc->DISPLAY, args);
	  return(wrong_type_argument_with_type(sc, sc->DISPLAY, small_int(2), port, AN_OUTPUT_PORT));
	}
    }
  else port = sc->output_port;
  write_or_display(sc, car(args), port, USE_DISPLAY);
  return(sc->UNSPECIFIED); /* wouldn't it be more useful to return car(args) here and in write? */
}


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"
  s7_pointer port;

  if (!is_procedure(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CALL_WITH_OUTPUT_STRING, args);
      return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_STRING, small_int(1), car(args), A_PROCEDURE));
    }
  if ((is_continuation(car(args))) || is_goto(car(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_STRING, small_int(2), car(args), 
					 make_protected_string(sc, "a normal procedure (not a continuation)")));
  if (is_thunk(sc, car(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_STRING, small_int(2), car(args), 
					 make_protected_string(sc, "a procedure of one argument (the port)")));
  port = s7_open_output_string(sc);
  push_stack(sc, OP_UNWIND_OUTPUT, sc->F, port);
  push_stack(sc, OP_GET_OUTPUT_STRING, sc->F, port);
  push_stack(sc, OP_APPLY, list_1(sc, port), car(args));
  return(sc->F);
}


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"
  s7_pointer port;
  
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CALL_WITH_OUTPUT_FILE, args);
      return(wrong_type_argument(sc, sc->CALL_WITH_OUTPUT_FILE, small_int(1), car(args), T_STRING));
    }
  if (!is_procedure(cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_FILE, small_int(2), cadr(args), A_PROCEDURE));
  if ((is_continuation(cadr(args))) || is_goto(cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_FILE, small_int(2), cadr(args), 
					 make_protected_string(sc, "a normal procedure (not a continuation)")));
  if (is_thunk(sc, car(args)))
    return(wrong_type_argument_with_type(sc, sc->CALL_WITH_OUTPUT_FILE, small_int(2), car(args), 
					 make_protected_string(sc, "a procedure of one argument (the port)")));
  
  port = s7_open_output_file(sc, string_value(car(args)), "w");
  push_stack(sc, OP_UNWIND_OUTPUT, sc->F, port);
  push_stack(sc, OP_APPLY, list_1(sc, port), cadr(args));
  return(sc->F);
}


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"
  s7_pointer old_output_port;

  if (!is_thunk(sc, car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->WITH_OUTPUT_TO_STRING, args);
      return(wrong_type_argument_with_type(sc, sc->WITH_OUTPUT_TO_STRING, small_int(1), car(args), A_THUNK));
    }
  old_output_port = sc->output_port;
  sc->output_port = s7_open_output_string(sc);
  push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, sc->output_port);
  push_stack(sc, OP_GET_OUTPUT_STRING, sc->F, sc->output_port);
  push_stack(sc, OP_APPLY, sc->NIL, car(args));
  return(sc->F);
}

/* (string-ref (with-output-to-string (lambda () (write "1234") (values (get-output-string) 1)))) */


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"
  s7_pointer old_output_port;
  
  if (!is_string(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->WITH_OUTPUT_TO_FILE, args);
      return(wrong_type_argument(sc, sc->WITH_OUTPUT_TO_FILE, small_int(1), car(args), T_STRING));
    }
  if (!is_thunk(sc, cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->WITH_OUTPUT_TO_FILE, small_int(2), cadr(args), A_THUNK));
  
  old_output_port = sc->output_port;
  sc->output_port = s7_open_output_file(sc, string_value(car(args)), "w");
  push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, sc->output_port);
  push_stack(sc, OP_APPLY, sc->NIL, cadr(args));
  return(sc->F);
}




/* -------------------------------- format -------------------------------- */

static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj);

static s7_pointer format_error(s7_scheme *sc, const char *msg, const char *str, s7_pointer args, format_data *fdat)
{
  int len;
  char *errmsg;
  s7_pointer x;

  if (fdat->loc == 0)
    {
      len = safe_strlen(msg) + 32;
      errmsg = (char *)malloc(len * sizeof(char));
      if (is_pair(args))
	snprintf(errmsg, len, "format ~S ~{~S~^ ~}: %s", msg);
      else snprintf(errmsg, len, "format ~S: %s", msg);
    }
  else 
    {
      char *filler;
      int i;
      filler = (char *)calloc(fdat->loc + 12, sizeof(char));
      for (i = 0; i < fdat->loc + 11; i++)
	filler[i] = ' ';
      len = safe_strlen(msg) + 32 + fdat->loc + 12;
      errmsg = (char *)malloc(len * sizeof(char));
      if (is_pair(args))
	snprintf(errmsg, len, "format: ~S ~{~S~^ ~}\n%s^: %s", filler, msg);
      else snprintf(errmsg, len, "format: ~S\n%s^: %s", filler, msg);
      free(filler);
    }

  if (is_pair(args))
    x = list_3(sc, make_string_uncopied(sc, errmsg), make_protected_string(sc, str), args);
  else x = list_2(sc, make_string_uncopied(sc, errmsg), make_protected_string(sc, str));

  if (fdat->gc_loc >= 0)
    {
      s7_gc_unprotect_at(sc, fdat->gc_loc);
      fdat->gc_loc = -1;
    }

  return(s7_error(sc, sc->FORMAT_ERROR, x));
}


static void format_append_char(s7_scheme *sc, format_data *fdat, char c, s7_pointer port)
{
  port_write_character(port)(sc, c, port);
  fdat->col++;

  /* if c is #\null, is this the right thing to do? 
   * We used to return "1 2 3 4" because ~C was first turned into a string (empty in this case)
   *   (format #f "1 2~C3 4" #\null)
   *   "1 2"
   * Clisp does this:
   *   (format nil "1 2~C3 4" (int-char 0))
   *   "1 23 4"
   * whereas sbcl says int-char is undefined, and
   * Guile returns "1 2\x003 4"
   */
}

static void format_append_newline(s7_scheme *sc, format_data *fdat, s7_pointer port)
{
  port_write_character(port)(sc, '\n', port);
  fdat->col = 0;
}


static void format_append_string(s7_scheme *sc, format_data *fdat, const char *str, int len, s7_pointer port)
{
  port_write_string(port)(sc, str, len, port);
  fdat->loc += len;
  fdat->col += len;
}


static int format_read_integer(s7_scheme *sc, int *cur_i, int str_len, const char *str, s7_pointer args, format_data *fdat)
{
  int i, arg1 = -1;
  char *tmp;
  i = *cur_i;
  if (isdigit(str[i]))
    {
      tmp = (char *)(str + i);
      if (sscanf(tmp, "%d", &arg1) < 1)
	format_error(sc, "bad number?", str, args, fdat);

      for (i = i + 1; i < str_len - 1; i++)
	if (!isdigit(str[i]))
	  break;
      if (i >= str_len)
	format_error(sc, "numeric argument, but no directive!", str, args, fdat);
    }
  *cur_i = i;
  return(arg1);
}


static void format_number(s7_scheme *sc, format_data *fdat, int radix, int width, int precision, char float_choice, char pad, s7_pointer port)
{
  char *tmp;
  int nlen = 0;
  if (width < 0) width = 0;

  /* precision choice depends on float_choice if it's -1 */
  if (precision < 0)
    {
      if ((float_choice == 'e') ||
	  (float_choice == 'f') ||
	  (float_choice == 'g'))
	precision = 6;
      else
	{
	  /* in the "int" cases, precision depends on the arg type */
	  switch (type(car(fdat->args)))
	    {
	    case T_INTEGER: 
	    case T_RATIO:
	      precision = 0; 
	      break;

	    default:
	      precision = 6;
	      break;
	    }
	}
    }

  /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */

  tmp = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen);

  if (pad != ' ')
    {
      char *padtmp;
      padtmp = tmp;
      while (*padtmp == ' ') (*(padtmp++)) = pad;
    }

  format_append_string(sc, fdat, tmp, (nlen == 0) ? safe_strlen(tmp) : nlen, port);

  free(tmp);
  fdat->args = cdr(fdat->args);
}


#if WITH_GMP
static bool s7_is_one_or_big_one(s7_pointer p);
#else
#define s7_is_one_or_big_one(Num) s7_is_one(Num)
#endif


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, int len)
{
  int i = 0, str_len = 0;
  format_data *fdat = NULL;
  s7_pointer deferred_port = sc->F;
  bool port_is_string;
  use_write_t choice;

  if ((!with_result) &&
      (port == sc->F))
    return(sc->F);

  if (len <= 0)
    {
      str_len = safe_strlen(str);
      if (str_len == 0)
	{
	  if (is_not_null(args))
	    return(s7_error(sc, 
			    sc->FORMAT_ERROR, 
			    list_2(sc, make_protected_string(sc, "format control string is null, but there are other arguments: ~S"), args)));
	  return(make_protected_string(sc, ""));
	}
    }
  else str_len = len;

  sc->format_depth++;
  if (sc->format_depth >= sc->num_fdats)
    {
      int i, new_num_fdats;
      new_num_fdats = sc->format_depth * 2;
      sc->fdats = (format_data **)realloc(sc->fdats, sizeof(format_data *) * new_num_fdats);
      for (i = sc->num_fdats; i < new_num_fdats; i++) sc->fdats[i] = NULL;
      sc->num_fdats = new_num_fdats;
    }

  fdat = sc->fdats[sc->format_depth];
  if (!fdat)
    {
      fdat = (format_data *)malloc(sizeof(format_data));
      sc->fdats[sc->format_depth] = fdat;
      fdat->curly_len = 0;
      fdat->curly_str = NULL;
    }
  else
    {
      if (fdat->gc_loc >= 0)
	s7_gc_unprotect_at(sc, fdat->gc_loc); /* I don't think this can happen, but its innocuous. */
    }
  fdat->gc_loc = -1;
  fdat->loc = 0;
  fdat->col = 0;
  fdat->args = args;

  /* choose whether to write to a temporary string port, or simply use the in-coming port
   *   if with_result, returned string is wanted.
   *   if port is sc->F, no non-string result is wanted.
   *   if port is not boolean, it better be a port.
   *   if we are about to goto START in eval, and main_stack_op(Sc) == OP_BEGIN1, no return string is wanted -- yow, this is not true
   *   since format is now safe, it can be embedded, so we also have to check that op(cur_code) is hop_safe_sc?
   */

  if (with_result)
    {
      deferred_port = port;
      port = s7_open_output_string(sc);
      fdat->gc_loc = s7_gc_protect(sc, port);
      port_is_string = true;
    }
  else port_is_string = is_string_port(port);

  for (i = 0; i < str_len; i++)
    {
      if (str[i] == '~') /* strchr here was slower! */
	{
	  if (i == str_len - 1)
	    return(format_error(sc, "control string ends in tilde", str, args, fdat));
	  
	  switch (str[i + 1])
	    {
	    case '%':                           /* -------- newline -------- */
	      /* sbcl apparently accepts numeric args here (including 0) */

	      if ((port_is_string) &&
		  (port_string_point(port) < port_string_length(port)))
		{
		  port_string(port)[port_string_point(port)++] = '\n';
		  /* which is actually a bad idea, but as a desperate stopgap, I simply padded
		   *  the string port string with 8 chars that are not in the length.
		   */
		  fdat->col = 0;
		}
	      else format_append_newline(sc, fdat, port);
	      i++;
	      break;
	      
	    case '&':                           /* -------- conditional newline -------- */
	      if (fdat->col > 0)
		format_append_newline(sc, fdat, port);
	      i++;
	      break;
	      
	    case '~':                           /* -------- tilde -------- */
	      format_append_char(sc, fdat, '~', port);
	      i++;
	      break;
	      
	    case '\n':                          /* -------- trim white-space -------- */
	      for (i = i + 2; i <str_len - 1; i++)
		if (!(white_space[(unsigned char)(str[i])]))
		  {
		    i--;
		    break;
		  }
	      break;
	      
	    case '*':                           /* -------- ignore arg -------- */
	      i++;
	      fdat->args = cdr(fdat->args);
	      break;
	      
	    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'))
		return(format_error(sc, "unknown '@' directive", str, args, fdat));
	      if (!s7_is_real(car(fdat->args)))        /* CL accepts non numbers here */
		return(format_error(sc, "'@P' directive argument is not a real number", str, args, fdat));
	      
	      if (!s7_is_one_or_big_one(car(fdat->args)))
		format_append_string(sc, fdat, "ies", 3, port);
	      else format_append_char(sc, fdat, 'y', port);
	      
	      fdat->args = cdr(fdat->args);
	      break;
	      
	    case 'P': case 'p':                 /* -------- plural in 's' -------- */
	      if (!s7_is_real(car(fdat->args)))
		return(format_error(sc, "'P' directive argument is not a real number", str, args, fdat));
	      if (!s7_is_one_or_big_one(car(fdat->args)))
		format_append_char(sc, fdat, 's', port);
	      i++;
	      fdat->args = cdr(fdat->args);
	      break;
	      
	    case '{':                           /* -------- iteration -------- */
	      {
		int k, curly_len = -1, curly_nesting = 1;
		
		if (is_null(fdat->args))
		  return(format_error(sc, "missing argument", str, args, fdat));
		
		for (k = i + 2; k < str_len - 1; k++)
		  if (str[k] == '~')
		    {
		      if (str[k + 1] == '}')
			{
			  curly_nesting--;
			  if (curly_nesting == 0)
			    {
			      curly_len = k - i - 1;
			      break;
			    }
			}
		      else
			{
			  if (str[k + 1] == '{')
			    curly_nesting++;
			}
		    }
		
		if (curly_len == -1)
		  return(format_error(sc, "'{' directive, but no matching '}'", str, args, fdat));
		
		/* what about cons's here?  I can't see any way in CL either to specify the car or cdr of a cons within the format string 
		 *   (cons 1 2) is applicable: ((cons 1 2) 0) -> 1
		 *   also there can be applicable objects that won't work in the map context (arg not integer etc)
		 */
		if (is_not_null(car(fdat->args)))               /* (format #f "~{~A ~}" '()) -> "" */
		  {
		    s7_pointer curly_arg;
		    
		    curly_arg = object_to_list(sc, car(fdat->args)); 
		    if (is_not_null(curly_arg))                /* (format #f "~{~A ~}" #()) -> "" */
		      {
			char *curly_str = NULL;                /* this is the local (nested) format control string */
			int curly_gc;
			
			if (!is_proper_list(sc, curly_arg))
			  return(format_error(sc, "'{' directive argument should be a proper list or something we can turn into a list", 
					      str, args, fdat));
			curly_gc = s7_gc_protect(sc, 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 * sizeof(char));
			  }
			curly_str = fdat->curly_str;
			memcpy((void *)curly_str, (void *)(str + i + 2), curly_len - 1);
			curly_str[curly_len - 1] = '\0';
			
			while (is_not_null(curly_arg))
			  {
			    s7_pointer new_arg = sc->NIL;
			    
			    format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1);
			    if (curly_arg == new_arg)
			      {
				s7_gc_unprotect_at(sc, curly_gc);
				return(format_error(sc, "'{...}' doesn't consume any arguments!", str, args, fdat));
			      }
			    curly_arg = new_arg;
			  }
			s7_gc_unprotect_at(sc, curly_gc);
		      }
		  }
		
		i += (curly_len + 2); /* jump past the ending '}' too */
		fdat->args = cdr(fdat->args);
	      }
	      break;
	      
	    case '}':
	      return(format_error(sc, "unmatched '}'", str, args, fdat));

	    case 'W': case 'w':
	      choice = USE_READABLE_WRITE;
	      goto OBJSTR;

	    case 'S': case 's':
	      choice = USE_WRITE;
	      goto OBJSTR;

	    case 'A': case 'a': 
	      choice = USE_DISPLAY;
	    OBJSTR:
	      /* object->string */
	      {
		s7_pointer obj;

		if (is_null(fdat->args))
		  return(format_error(sc, "missing argument", str, args, fdat));

		i++;
		obj = car(fdat->args);
		/* for the column check, we need to know the length of the object->string output
		 */

		if (!columnized)
		  {
		    if ((has_structure(obj)) &&
			(obj != sc->global_env))
		      {
			shared_info *ci = NULL;
			ci = make_shared_info(sc, obj);
			if ((ci) &&
			    (choice == USE_READABLE_WRITE))
			  {
			    setup_shared_reads(sc, port, ci);
			    object_to_port_with_circle_check(sc, obj, port, choice, is_file_port(port), ci);
			    finish_shared_reads(sc, port, ci);
			  }
			else object_to_port_with_circle_check(sc, obj, port, choice, is_file_port(port), ci);
		      }
		    else object_to_port(sc, obj, port, choice, is_file_port(port), NULL);
		  }
		else
		  {
		    char *s;
		    int nlen = 0;
		    s = s7_object_to_c_string_1(sc, obj, choice, &nlen);
		    if (nlen > 0)
		      format_append_string(sc, fdat, s, nlen, port);
		    free(s);
		  }

		fdat->args = cdr(fdat->args);
	      }
	      break;
		    

	      /* -------- numeric args -------- */
	    case '0': case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9': case ',':
	      
	    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':
	      {
		int width = -1, precision = -1;
		char pad = ' ';
		i++;
		
		if (isdigit(str[i]))
		  {
		    width = format_read_integer(sc, &i, str_len, str, args, fdat);
		    if ((width < 0) ||  /* sccanf is 32 bit so (format #f "~922337203685477580F" pi) gets a width of -1 or some such number */
			(width > MAX_STRING_LENGTH))
		      return(format_error(sc, "numeric argument too large", str, args, fdat));
		  }
		
		if (str[i] == ',')
		  {
		    i++;
		    if (isdigit(str[i]))
		      {
			precision = format_read_integer(sc, &i, str_len, str, args, fdat);
			if ((precision < 0) ||
			    (precision > MAX_STRING_LENGTH)) /* needed in 32-bit case */
			  return(format_error(sc, "numeric argument too large", str, args, fdat));
		      }
		    /* is (format #f "~12,12D" 1) an error?  The precision has no use here. */
		    else
		      {
			if (str[i] == '\'')       /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
			  {
			    pad = str[i + 1];
			    i += 2;
			  }
			/* 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.~%"))
			 */
			int j;
			if (precision > 0)
			  {
			    int mult;
			    mult = (int)(ceil((s7_Double)(fdat->col + 1 - width) / (s7_Double)precision)); /* CLtL2 ("least positive int") */
			    if (mult < 1) mult = 1;
			    width += (precision * mult);
			  }
			for (j = fdat->col + 1; j < width; j++)
			  format_append_char(sc, fdat, pad, port);
		      }
		    break;

		  case 'C': case 'c':
		    {
		      s7_pointer obj;
		      
		      if (is_null(fdat->args))
			return(format_error(sc, "~~C: missing argument", str, args, fdat));
		      /* the "~~" here and below protects against "~C" being treated as a directive */
		      /* i++; */
		      obj = car(fdat->args);
		      
		      if (!s7_is_character(obj))
			return(format_error(sc, "'C' directive requires a character argument", str, args, fdat));
		      
		      /* here use_write is false, so we just add the char, not its name */
		      if (width == -1)
			format_append_char(sc, fdat, character(obj), port);
		      else
			{
			  int j;
			  for (j = 0; j < width; j++)
			    format_append_char(sc, fdat, character(obj), port);
			}
		      fdat->args = cdr(fdat->args);
		    }
		    break;
		    
		    /* -------- numbers -------- */
		  case 'F': case 'f':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~F: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~F: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 10, width, precision, 'f', pad, port);
		    break;
		    
		  case 'G': case 'g':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~G: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~G: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 10, width, precision, 'g', pad, port);
		    break;
		    
		  case 'E': case 'e':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~E: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~E: numeric argument required", str, args, fdat));
		    
		    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")!!
		     *   Guile raises an error ("argument is not an integer").  slib also raise an error.
		     *   I think I'll use the type of the number to choose the output format.
		     */
		  case 'D': case 'd':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~D: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~D: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 10, width, precision, 'd', pad, port);
		    break;
		    
		  case 'O': case 'o':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~O: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~O: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 8, width, precision, 'o', pad, port);
		    break;
		    
		  case 'X': case 'x':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~X: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~X: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 16, width, precision, 'x', pad, port);
		    break;
		    
		  case 'B': case 'b':
		    if (is_null(fdat->args))
		      return(format_error(sc, "~~B: missing argument", str, args, fdat));
		    if (!(s7_is_number(car(fdat->args))))
		      return(format_error(sc, "~~B: numeric argument required", str, args, fdat));
		    
		    format_number(sc, fdat, 2, width, precision, 'b', pad, port);
		    break;
		    
		  default:
		    if (width > 0)
		      return(format_error(sc, "format directive does not take a numeric argument", str, args, fdat));
		    return(format_error(sc, "unimplemented format directive", str, args, fdat));
		  }
	      }
	      break;
	      
	    default:
	      return(format_error(sc, "unimplemented format directive", str, args, fdat));
	    }
	}
      else 
	{
	  if ((port_is_string) &&
	      (port_string_point(port) < port_string_length(port)))
	    {
	      port_string(port)[port_string_point(port)++] = str[i];
	      fdat->col++;
	    }
	  else format_append_char(sc, fdat, str[i], port);
	}
    }

 ALL_DONE:
  if (next_arg)
    (*next_arg) = fdat->args;
  else
    {
      if (is_not_null(fdat->args))
	return(format_error(sc, "too many arguments", str, args, fdat));
    }
  if (i < str_len)
    format_append_char(sc, fdat, str[i], port);    /* possible trailing ~ is sent out */

  sc->format_depth--;

  if (with_result)
    {
      s7_pointer result;

      if ((is_output_port(deferred_port)) &&
	  (port_string_point(port) > 0))
	port_write_string(deferred_port)(sc, port_string(port), port_string_point(port), deferred_port);

      result = make_string_uncopied_with_length(sc, port_string(port), port_string_point(port));
      port_string(port) = NULL;
      port_needs_free(port) = false;
      s7_close_output_port(sc, port);

      if (fdat->gc_loc >= 0)
	{
	  s7_gc_unprotect_at(sc, fdat->gc_loc);
	  fdat->gc_loc = -1;
	}
      return(result);
    }
  return(sc->F);
}


static bool is_columnizing(const char *str)
{
  char *p;
  bool in_tilde = false;

  for (p = (char *)str; (*p); p++)
    {
      if (*p == '~')
	in_tilde = !in_tilde;
      else
	{
	  if ((in_tilde) &&
	      ((*p == 'T') || (*p == 't')))
	    return(true);
	  else
	    {
	      if ((!isdigit((int)(*p))) &&
		  (*p != ','))
		in_tilde = false;
	    }
	}
    }
  return(false);
}


static s7_pointer format_to_port(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, s7_pointer *next_arg, bool with_result, int len)
{
  return(format_to_port_1(sc, port, str, args, next_arg, with_result, is_columnizing(str), len));
}


static s7_pointer g_format_1(s7_scheme *sc, s7_pointer args, bool with_result)
{
  s7_pointer pt;

  sc->args = sc->NIL;
  pt = car(args);

  if (is_string(pt))
    return(format_to_port(sc, sc->F, string_value(pt), cdr(args), NULL, with_result, string_length(pt)));

  if (!is_string(cadr(args)))
    {
      CHECK_METHOD(sc, cadr(args), sc->FORMAT, args);
      return(wrong_type_argument(sc, sc->FORMAT, small_int(2), cadr(args), T_STRING));
    }
  if (!((s7_is_boolean(pt)) ||               /* #f or #t */
	((is_output_port(pt)) &&             /* (current-output-port) or call-with-open-file arg, etc */
	 (!port_is_closed(pt)))))
    {
      CHECK_METHOD(sc, pt, sc->FORMAT, args);
      return(wrong_type_argument_with_type(sc, sc->FORMAT, small_int(1), pt, AN_OUTPUT_PORT));
    }
  return(format_to_port(sc, 
			(pt == sc->T) ? sc->output_port : pt, 
			string_value(cadr(args)), cddr(args), NULL, with_result, 
			string_length(cadr(args))));
}


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 argument 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)"

  return(g_format_1(sc, args, true)); 
}


const char *s7_format(s7_scheme *sc, s7_pointer args)
{
  return(string_value(g_format_1(sc, args, true)));
}





/* -------------------------------- system extras -------------------------------- */

#if WITH_SYSTEM_EXTRAS

/* according to gnulib, these headers are in every OS:
 *    <float.h>, <limits.h>, <stdarg.h>, <stddef.h>, <ctime.h>, <errno.h>, <fcntl.h>,
 *    <locale.h>, <signal.h>, <stdio.h>, <stdlib.h>, <string.h>, <time.h>, <sys/types.h>
 */

#include <fcntl.h>

  /* other possibilities:
   *   setenv, home-directory
   *   current-time, time->string (ie strftime packaged up), temporary-filename or temp-directory, sleep
   *   lseek [open|close|delete-hook] file-write-date or file-write-time since we want it to work with time->string
   *   full-filename
   *   would need T_TIME type so need time?
   * CL names: file-length file-position file-write-date
   */

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"
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->DIRECTORYP, args);
      return(simple_wrong_type_argument(sc, sc->DIRECTORYP, name, T_STRING));
    }
  return(s7_make_boolean(sc, is_directory(string_value(name))));
}


static bool file_probe(const char *arg)
{
#if (!MS_WINDOWS)
  return(access(arg, F_OK) == 0);
#else
  int fd;
  fd = open(arg, O_RDONLY, 0);
  if (fd == -1) return(false);
  close(fd);
  return(true);
#endif
}


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"
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->FILE_EXISTSP, args);
      return(simple_wrong_type_argument(sc, sc->FILE_EXISTSP, name, T_STRING));
    }
  return(s7_make_boolean(sc, file_probe(string_value(name))));
}


static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args)
{
  #define H_delete_file "(delete-file filename) deletes the file filename."
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->DELETE_FILE, args);
      return(simple_wrong_type_argument(sc, sc->DELETE_FILE, name, T_STRING));
    }
  return(make_integer(sc, unlink(string_value(name))));
}


static s7_pointer g_getenv_1(s7_scheme *sc, s7_pointer args)
{
  #define H_getenv "(getenv var) returns the value of an environment variable."
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->GETENV, args);
      return(simple_wrong_type_argument(sc, sc->GETENV, name, T_STRING));
    }
  return(s7_make_string(sc, getenv(string_value(name))));
}


static s7_pointer g_system(s7_scheme *sc, s7_pointer args)
{
  #define H_system "(system command) executes the command."
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->SYSTEM, args);
      return(simple_wrong_type_argument(sc, sc->SYSTEM, name, T_STRING));
    }
  return(make_integer(sc, system(string_value(name))));
}


#ifndef _MSC_VER
#include <dirent.h>

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)."
  DIR *dpos;
  s7_pointer name, result;

  name = car(args);
  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->DIRECTORY_TO_LIST, args);
      return(simple_wrong_type_argument(sc, sc->DIRECTORY_TO_LIST, name, T_STRING));
    }
  sc->w = sc->NIL;
  if ((dpos = opendir(string_value(name))) != NULL)
    {
      struct dirent *dirp;
      while ((dirp = readdir(dpos)) != NULL)
	sc->w = cons(sc, s7_make_string(sc, dirp->d_name), sc->w);
      closedir(dpos);
    }

  result = sc->w;
  sc->w = sc->NIL;
  return(result);
}


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"

  struct stat statbuf;
  int err;
  s7_pointer name;

  name = car(args);
  if (!is_string(name))
    {
      CHECK_METHOD(sc, name, sc->FILE_MTIME, args);
      return(simple_wrong_type_argument(sc, sc->FILE_MTIME, name, T_STRING));
    }

  err = stat(string_value(name), &statbuf);
  if (err < 0) 
    return(file_error(sc, "file-mtime", strerror(errno), string_value(name)));

  return(s7_make_integer(sc, (s7_Int)(statbuf.st_mtime)));
}
#endif

#endif





/* -------------------------------- lists -------------------------------- */

s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b) 
{
  s7_pointer x;
  NEW_CELL(sc, x);
  car(x) = a;
  cdr(x) = b;
  set_type(x, T_PAIR | T_SAFE_PROCEDURE);
  return(x);
}


static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) 
{
  /* apparently slightly faster as a function? */
  s7_pointer x;
  NEW_CELL_NO_CHECK(sc, x);
  car(x) = a;
  cdr(x) = b;
  set_type(x, T_PAIR | T_SAFE_PROCEDURE);
  return(x);
}


static s7_pointer permanent_cons(s7_pointer a, s7_pointer b, int type)
{
  /* for the symbol table which is never GC'd (and its contents aren't marked) */
  s7_pointer x;
  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  car(x) = a;
  cdr(x) = b;
  set_type(x, type);
  return(x);
}


bool s7_is_pair(s7_pointer p)
{
  return(is_pair(p));
}


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) 
{ 
  car(p) = q;
  return(p);
}


s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q) 
{ 
  cdr(p) = q;
  return(p);
}

/* -------------------------------------------------------------------------------- */

s7_pointer s7_apply_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1))
{
  return(f1(car(args)));
}

s7_pointer s7_apply_2(s7_scheme *sc, s7_pointer args, s7_pointer (*f2)(s7_pointer a1, s7_pointer a2))
{
  return(f2(car(args), cadr(args)));
}

s7_pointer s7_apply_3(s7_scheme *sc, s7_pointer args, s7_pointer (*f3)(s7_pointer a1, s7_pointer a2, s7_pointer a3))
{
  s7_pointer a1;
  a1 = car(args);
  args = cdr(args);
  return(f3(a1, car(args), cadr(args)));
}

s7_pointer s7_apply_4(s7_scheme *sc, s7_pointer args, s7_pointer (*f4)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4))
{
  s7_pointer a1, a2;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  return(f4(a1, a2, car(args), cadr(args)));
}

s7_pointer s7_apply_5(s7_scheme *sc, s7_pointer args, s7_pointer (*f5)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5))
{
  s7_pointer a1, a2, a3, a4;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  a3 = car(args);
  a4 = cadr(args);
  args = cddr(args);
  return(f5(a1, a2, a3, a4, car(args)));
}

s7_pointer s7_apply_6(s7_scheme *sc, s7_pointer args, 
		      s7_pointer (*f6)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
				       s7_pointer a5, s7_pointer a6))
{
  s7_pointer a1, a2, a3, a4;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  a3 = car(args);
  a4 = cadr(args);
  args = cddr(args);
  return(f6(a1, a2, a3, a4, car(args), cadr(args)));
}

s7_pointer s7_apply_7(s7_scheme *sc, s7_pointer args, 
		      s7_pointer (*f7)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
				       s7_pointer a5, s7_pointer a6, s7_pointer a7))
{
  s7_pointer a1, a2, a3, a4, a5, a6;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  a3 = car(args);
  a4 = cadr(args);
  args = cddr(args);
  a5 = car(args);
  a6 = cadr(args);
  args = cddr(args);
  return(f7(a1, a2, a3, a4, a5, a6, car(args)));
}

s7_pointer s7_apply_8(s7_scheme *sc, s7_pointer args, 
		      s7_pointer (*f8)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
				       s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8))
{
  s7_pointer a1, a2, a3, a4, a5, a6;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  a3 = car(args);
  a4 = cadr(args);
  args = cddr(args);
  a5 = car(args);
  a6 = cadr(args);
  args = cddr(args);
  return(f8(a1, a2, a3, a4, a5, a6, car(args), cadr(args)));
}

s7_pointer s7_apply_9(s7_scheme *sc, s7_pointer args, 
		      s7_pointer (*f9)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
				       s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8, s7_pointer a9))
{
  s7_pointer a1, a2, a3, a4, a5, a6;
  a1 = car(args);
  a2 = cadr(args);
  args = cddr(args);
  a3 = car(args);
  a4 = cadr(args);
  args = cddr(args);
  a5 = car(args);
  a6 = cadr(args);
  args = cddr(args);
  return(f9(a1, a2, a3, a4, a5, a6, car(args), cadr(args), caddr(args)));
}

s7_pointer s7_apply_n_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1))
{
  if (is_pair(args)) 
    return(f1(car(args)));
  return(f1(sc->UNDEFINED));
}

s7_pointer s7_apply_n_2(s7_scheme *sc, s7_pointer args, s7_pointer (*f2)(s7_pointer a1, s7_pointer a2))
{
  if (is_pair(args))
    {
      if (is_pair(cdr(args)))
	return(f2(car(args), cadr(args)));
      return(f2(car(args), sc->UNDEFINED));
    }
  return(f2(sc->UNDEFINED, sc->UNDEFINED));
}

s7_pointer s7_apply_n_3(s7_scheme *sc, s7_pointer args, s7_pointer (*f3)(s7_pointer a1, s7_pointer a2, s7_pointer a3))
{
  if (is_pair(args))
    {
      s7_pointer a1, a2;
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  if (is_pair(cdr(args))) 
	    return(f3(a1, a2, cadr(args)));
	  return(f3(a1, a2, sc->UNDEFINED));
	}
      return(f3(a1, sc->UNDEFINED, sc->UNDEFINED));
    }
  return(f3(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
}

s7_pointer s7_apply_n_4(s7_scheme *sc, s7_pointer args, s7_pointer (*f4)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4))
{
  if (is_pair(args))
    {
      s7_pointer a1, a2, a3;
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      if (is_pair(cdr(args)))
		return(f4(a1, a2, a3, cadr(args)));
	      return(f4(a1, a2, a3, sc->UNDEFINED));
	    }
	  return(f4(a1, a2, sc->UNDEFINED, sc->UNDEFINED));
	}
      return(f4(a1, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
    }
  return(f4(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
}

s7_pointer s7_apply_n_5(s7_scheme *sc, s7_pointer args, 
			s7_pointer (*f5)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5))
{
  if (is_pair(args))
    {
      s7_pointer a1, a2, a3, a4;
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  if (is_pair(cdr(args))) 
		    return(f5(a1, a2, a3, a4, cadr(args)));
		  return(f5(a1, a2, a3, a4, sc->UNDEFINED));
		}
	      return(f5(a1, a2, a3, sc->UNDEFINED, sc->UNDEFINED));
	    }
	  return(f5(a1, a2, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
	}
      return(f5(a1, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
    }
  return(f5(sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED, sc->UNDEFINED));
}

s7_pointer s7_apply_n_6(s7_scheme *sc, s7_pointer args, 
			s7_pointer (*f6)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, s7_pointer a5, s7_pointer a6))
{
  s7_pointer a1, a2, a3, a4, a5, a6;
  a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; a6 = sc->UNDEFINED;
  if (is_pair(args))
    {
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  args = cdr(args);
		  if (is_pair(args))
		    {
		      a5 = car(args);
		      if (is_pair(cdr(args))) a6 = cadr(args);
		    }}}}}
  return(f6(a1, a2, a3, a4, a5, a6));
}

s7_pointer s7_apply_n_7(s7_scheme *sc, s7_pointer args, 
			s7_pointer (*f7)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
					 s7_pointer a5, s7_pointer a6, s7_pointer a7))
{
  s7_pointer a1, a2, a3, a4, a5, a6, a7;
  a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; 
  a6 = sc->UNDEFINED, a7 = sc->UNDEFINED;
  if (is_pair(args))
    {
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  args = cdr(args);
		  if (is_pair(args))
		    {
		      a5 = car(args);
		      args = cdr(args);
		      if (is_pair(args))
			{
			  a6 = car(args);
			  if (is_pair(cdr(args))) a7 = cadr(args);
			}}}}}}
  return(f7(a1, a2, a3, a4, a5, a6, a7));
}

s7_pointer s7_apply_n_8(s7_scheme *sc, s7_pointer args, 
			s7_pointer (*f8)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
					 s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8))
{
  s7_pointer a1, a2, a3, a4, a5, a6, a7, a8;
  a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; 
  a6 = sc->UNDEFINED, a7 = sc->UNDEFINED; a8 = sc->UNDEFINED;
  if (is_pair(args))
    {
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  args = cdr(args);
		  if (is_pair(args))
		    {
		      a5 = car(args);
		      args = cdr(args);
		      if (is_pair(args))
			{
			  a6 = car(args);
			  args = cdr(args);
			  if (is_pair(args))
			    {
			      a7 = car(args);
			      if (is_pair(cdr(args))) a8 = cadr(args);
			    }}}}}}}
  return(f8(a1, a2, a3, a4, a5, a6, a7, a8));
}

s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args, 
			s7_pointer (*f9)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
					 s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8,
					 s7_pointer a9))
{
  s7_pointer a1, a2, a3, a4, a5, a6, a7, a8, a9;
  a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; 
  a6 = sc->UNDEFINED, a7 = sc->UNDEFINED; a8 = sc->UNDEFINED; a9 = sc->UNDEFINED;
  if (is_pair(args))
    {
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  args = cdr(args);
		  if (is_pair(args))
		    {
		      a5 = car(args);
		      args = cdr(args);
		      if (is_pair(args))
			{
			  a6 = car(args);
			  args = cdr(args);
			  if (is_pair(args))
			    {
			      a7 = car(args);
			      args = cdr(args);
			      if (is_pair(args))
				{
				  a8 = car(args);
				  if (is_pair(cdr(args))) a9 = cadr(args);
				}}}}}}}}
  return(f9(a1, a2, a3, a4, a5, a6, a7, a8, a9));
}

s7_pointer s7_apply_n_10(s7_scheme *sc, s7_pointer args, 
			 s7_pointer (*f10)(s7_pointer a1, s7_pointer a2, s7_pointer a3, s7_pointer a4, 
					   s7_pointer a5, s7_pointer a6, s7_pointer a7, s7_pointer a8,
					   s7_pointer a9, s7_pointer a10))
{
  s7_pointer a1, a2, a3, a4, a5, a6, a7, a8, a9, a10;
  a1 = sc->UNDEFINED; a2 = sc->UNDEFINED; a3 = sc->UNDEFINED; a4 = sc->UNDEFINED; a5 = sc->UNDEFINED; 
  a6 = sc->UNDEFINED, a7 = sc->UNDEFINED; a8 = sc->UNDEFINED; a9 = sc->UNDEFINED; a10 = sc->UNDEFINED;
  if (is_pair(args))
    {
      a1 = car(args);
      args = cdr(args);
      if (is_pair(args))
	{
	  a2 = car(args);
	  args = cdr(args);
	  if (is_pair(args))
	    {
	      a3 = car(args);
	      args = cdr(args);
	      if (is_pair(args))
		{
		  a4 = car(args);
		  args = cdr(args);
		  if (is_pair(args))
		    {
		      a5 = car(args);
		      args = cdr(args);
		      if (is_pair(args))
			{
			  a6 = car(args);
			  args = cdr(args);
			  if (is_pair(args))
			    {
			      a7 = car(args);
			      args = cdr(args);
			      if (is_pair(args))
				{
				  a8 = car(args);
				  args = cdr(args);
				  if (is_pair(args))
				    {
				      a9 = car(args);
				      if (is_pair(cdr(args))) a10 = cadr(args);
				    }}}}}}}}}
  return(f10(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10));
}

/* -------------------------------------------------------------------------------- */



s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, int num)
{
  int i;
  s7_pointer x;

  for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
  if ((i == num) && (is_pair(x)))
    return(car(x));

  return(sc->NIL);
}


s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, int num, s7_pointer val)
{
  int i;
  s7_pointer x;

  for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
  if ((i == num) &&
      (is_pair(x)))
    car(x) = val;

  return(val);
}


static void list_set(s7_scheme *sc, s7_pointer lst, int num, s7_pointer val)
{
  /* internal form where we know the list is ok */
  int i;
  s7_pointer x;
  for (x = lst, i = 0; i < num; i++, x = cdr(x)) {}
  car(x) = val;
}


s7_pointer s7_member(s7_scheme *sc, s7_pointer sym, s7_pointer lst)
{
  s7_pointer x;

  for (x = lst; is_pair(x); x = cdr(x))
    if (s7_is_equal(sc, sym, car(x)))
      return(x);

  return(sc->F);
}


static bool symbol_is_in_arg_list(s7_pointer sym, s7_pointer lst)
{
  s7_pointer x;
  for (x = lst; is_pair(x); x = cdr(x))
    if ((sym == car(x)) ||
	((is_pair(car(x))) &&
	 (sym == caar(x))))
	return(true);
  return(sym == x);
}


s7_pointer s7_assoc(s7_scheme *sc, s7_pointer sym, s7_pointer lst)
{
  s7_pointer x, y;

  if (!is_pair(lst))
    return(sc->F);

  x = lst;
  y = lst;
  while (true)
    {
      if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F);
}


s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) 
{
  /* reverse list -- produce new list (other code assumes this function does not return the original!) */
  s7_pointer x, p;

  if (is_null(a)) return(a);

  if (!is_pair(cdr(a)))
    {
      if (is_not_null(cdr(a)))
	return(cons(sc, cdr(a), car(a)));
      return(cons(sc, car(a), sc->NIL)); /* don't return 'a' itself */
    }

  sc->w = list_1(sc, car(a));

  for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p))
    {
      sc->w = cons(sc, car(x), sc->w);
      if (is_pair(cdr(x)))
	{
	  x = cdr(x);
	  sc->w = cons(sc, car(x), sc->w);
	}
      if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */
	break;
    }

  if (is_not_null(x))
    p = cons(sc, x, sc->w);    /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return '() here */
  else p = sc->w;

  sc->w = sc->NIL;
  return(p);
}

/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late) 
 *  (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0)
 */


static s7_pointer reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list) 
{
  s7_pointer p = list, result = term, q;

  while (is_not_null(p))
    {
      q = cdr(p);
      if ((!is_pair(q)) &&
	  (is_not_null(q)))
	return(sc->NIL); /* improper list? */
      cdr(p) = result;
      result = p;
      p = q;
    }

  return(result);
}


static s7_pointer safe_reverse_in_place(s7_scheme *sc, s7_pointer list) /* "safe" here means we guarantee this list is unproblematic */
{
  s7_pointer p = list, result, q;
  result = sc->NIL;

  while (is_not_null(p))
    {
      q = cdr(p);
      /*   also if (is_null(list)) || (is_null(cdr(list))) return(list) */
      cdr(p) = result;
      result = p;
      p = q;

      /* unroll the loop for speed */
      if (is_null(p)) break;
      q = cdr(p);
      cdr(p) = result;
      result = p;
      p = q;

      if (is_null(p)) break;
      q = cdr(p);
      cdr(p) = result;
      result = p;
      p = q;

      if (is_null(p)) break;
      q = cdr(p);
      cdr(p) = result;
      result = p;
      p = q;
    }

  return(result);
}


/* is this correct? (let ((x (list 1 2))) (eq? x (append '() x))) -> #t
 */

s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) 
{
  s7_pointer p = b, q;
  
  if (is_not_null(a)) 
    {
      a = s7_reverse(sc, a);
      while (is_not_null(a)) 
	{
	  q = cdr(a);
	  cdr(a) = p;
	  p = a;
	  a = q;
	}
    }
  return(p);
}


static s7_pointer copy_list(s7_scheme *sc, s7_pointer lst)
{
  /* the non-recursive version of this is only slightly faster 
   *   but isn't the recursive version slightly dangerous in regard to the GC? 
   */
  s7_pointer p;
  sc->w = sc->NIL;
  for (p = lst; is_pair(p); p = cdr(p))
    sc->w = cons(sc, car(p), sc->w);
  return(safe_reverse_in_place(sc, sc->w));
}


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.
   */
   
  s7_pointer p = b, q;
  
  if (is_not_null(a)) 
    {
      a = copy_list(sc, a); 
      while (is_not_null(a)) 
	{
	  q = cdr(a);
	  cdr(a) = p;
	  p = a;
	  a = q;
	}
    }
  return(p);
}

static int safe_list_length(s7_scheme *sc, s7_pointer a)
{
  /* assume that "a" is a proper list */
  int i = 0;
  s7_pointer b;
  for (b = a; is_pair(b); i++, b = cdr(b)) {};
  return(i);
}


int s7_list_length(s7_scheme *sc, s7_pointer a) 
{
  /* returns -len if list is dotted, 0 if it's (directly) circular */
  int i;
  s7_pointer slow, fast;

  slow = fast = a;
  for (i = 0; ; i += 2)
    {
      if (!is_pair(fast))
	{
	  if (is_null(fast))
	    return(i);
	  return(-i);
	}
      
      fast = cdr(fast);
      if (!is_pair(fast)) 
	{
	  if (is_null(fast))
	    return(i + 1);
	  return(-i - 1);
	}
      /* if unrolled further, it's a lot slower? */
      
      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow) 
	return(0);
    }
  return(0);
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_null, sc->NULLP, args);
  /* as a generic this could be: has_structure and length == 0 */
}


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)"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_pair, sc->PAIRP, args);
}


bool s7_is_list(s7_scheme *sc, s7_pointer p)
{
  return((is_pair(p)) ||
	 (is_null(p)));
}


static bool is_proper_list(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer slow, fast;

  fast = lst;
  slow = lst;
  while (true)
    {
      if (!is_pair(fast)) 
	return(is_null(fast)); /* else it's an improper list */

      fast = cdr(fast);
      if (!is_pair(fast)) return(is_null(fast));

      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_list(s7_scheme *sc, s7_pointer args)
{
  #define H_is_list "(list? obj) returns #t if obj is a proper list"
  s7_pointer p;
  p = car(args);
  if (is_proper_list(sc, p)) return(sc->T);
  CHECK_METHOD(sc, p, sc->LISTP, args);
  return(sc->F);
}


static s7_pointer make_list(s7_scheme *sc, int len, s7_pointer init)
{
  /* sc->v used only here */
  switch (len)
    {
    case 0: return(sc->NIL);
    case 1: return(cons(sc, init, sc->NIL));
    case 2: return(cons_unchecked(sc, init, cons(sc, init, sc->NIL)));
    case 3: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL))));
    case 4: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->NIL)))));
    case 5: return(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, 
		    cons_unchecked(sc, init, cons(sc, init, sc->NIL))))));
    case 6: return(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(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:
      sc->v = sc->NIL;
      if (len < (sc->free_heap_top - sc->free_heap))
	{
	  int i;
	  for (i = 0; i < len; i++)
	    sc->v = cons_unchecked(sc, init, sc->v);
	}
      else
	{
	  int i;
	  for (i = 0; i < len; i++)
	    sc->v = cons(sc, init, sc->v);
	}
    }
  return(sc->v);
}


#define MAX_LIST_LENGTH 1073741824

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'."

  s7_pointer init;
  s7_Int len;

  if (!s7_is_integer(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->MAKE_LIST, args);
      return(wrong_type_argument(sc, sc->MAKE_LIST, small_int(1), car(args), T_INTEGER));
    }
  len = s7_integer(car(args));            /* needs to be s7_Int here so that (make-list most-negative-fixnum) is handled correctly */
  if (len < 0)
    return(out_of_range(sc, sc->MAKE_LIST, small_int(1), car(args), "should be non-negative"));
  if (len == 0) return(sc->NIL);          /* what about (make-list 0 123)? */
  if (len > MAX_LIST_LENGTH)
    return(out_of_range(sc, sc->MAKE_LIST, small_int(1), car(args), "should be a reasonable integer"));

  if (is_pair(cdr(args)))
    init = cadr(args);
  else init = sc->F;
  return(make_list(sc, (int)len, init));
}


static s7_pointer list_ref_ic;
static s7_pointer g_list_ref_ic(s7_scheme *sc, s7_pointer args)
{
  s7_Int i, index;
  s7_pointer lst, p;

  lst = car(args);
  if (!is_pair(lst))
    {
      CHECK_METHOD(sc, lst, sc->LIST_REF, args);
      return(wrong_type_argument(sc, sc->LIST_REF, small_int(1), lst, T_PAIR));
    }
  index = s7_integer(cadr(args));

  for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  
  if (!is_pair(p))
    {
      if (is_null(p))
	return(out_of_range(sc, sc->LIST_REF, small_int(2), cadr(args), "should be less than list length"));
      return(wrong_type_argument_with_type(sc, sc->LIST_REF, small_int(1), lst, A_PROPER_LIST));
    }
  return(car(p));
}


static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
{
  s7_Int i, index;
  s7_pointer p;

  if (!s7_is_integer(ind))
    return(wrong_type_argument(sc, sc->LIST_REF, small_int(2), ind, T_INTEGER));
  
  index = s7_integer(ind);
  if (index < 0)
    return(out_of_range(sc, sc->LIST_REF, small_int(2), ind, "should be non-negative"));

  if (index > MAX_LIST_LENGTH)
    return(out_of_range(sc, sc->LIST_REF, small_int(2), ind, "should be a reasonable integer"));
  
  for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  
  if (!is_pair(p))
    {
      if (is_null(p))
	return(out_of_range(sc, sc->LIST_REF, small_int(2), ind, "should be less than list length"));
      return(wrong_type_argument_with_type(sc, sc->LIST_REF, small_int(1), lst, A_PROPER_LIST));
    }
  return(car(p));
}


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"
  
  /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) 

    (define (lref L . args) 
      (if (null? (cdr args))
          (list-ref L (car args))
          (apply lref (list-ref L (car args)) (cdr args))))
  */

  s7_pointer lst, inds;

  lst = car(args);
  if (!is_pair(lst))
    {
      CHECK_METHOD(sc, lst, sc->LIST_REF, args);
      return(wrong_type_argument(sc, sc->LIST_REF, small_int(1), lst, T_PAIR));
    }
  inds = cdr(args);
  while (true)
    {
      lst = list_ref_1(sc, lst, car(inds));
      if (is_null(cdr(inds)))
	return(lst);
      inds = cdr(inds);
      if (!is_pair(lst)) /* trying to avoid a cons here at the cost of one extra type check */
	return(implicit_index(sc, lst, inds));
    }
}


static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int arg_num)
{
  #define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val"
  
  int i;
  s7_Int index;
  s7_pointer p, ind;

  /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */

  if (!is_pair(lst))
    {
      CHECK_METHOD(sc, lst, sc->LIST_SET, args);
      return(wrong_type_argument(sc, sc->LIST_SET, small_int(1), lst, T_PAIR));
    }
  ind = car(args);
  if (!s7_is_integer(ind))
    return(wrong_type_argument(sc, sc->LIST_SET, small_int(arg_num), ind, T_INTEGER));
  
  index = s7_integer(ind);
  if (index < 0)
    return(out_of_range(sc, sc->LIST_SET, small_int(arg_num), ind, "index should be non-negative"));
  
  if (index > MAX_LIST_LENGTH)
    return(out_of_range(sc, sc->LIST_SET, small_int(arg_num), ind, "should be a reasonable integer"));
  
  for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  
  if (!is_pair(p))
    {
      if (is_null(p))
	return(out_of_range(sc, sc->LIST_SET, small_int(arg_num), ind, "should be less than list length"));
      return(wrong_type_argument_with_type(sc, sc->LIST_SET, small_int(1), lst, A_PROPER_LIST));
    }
  if (is_null(cddr(args)))
    car(p) = cadr(args);
  else return(g_list_set_1(sc, car(p), cdr(args), arg_num + 1));

  return(cadr(args));
}


static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args)
{
  return(g_list_set_1(sc, car(args), cdr(args), 2));
}


static s7_pointer list_set_ic;
static s7_pointer g_list_set_ic(s7_scheme *sc, s7_pointer args)
{
  int i;
  s7_Int index;
  s7_pointer p, lst;

  lst = car(args);
  if (!is_pair(lst))
    {
      CHECK_METHOD(sc, lst, sc->LIST_SET, args);
      return(wrong_type_argument(sc, sc->LIST_SET, small_int(1), lst, T_PAIR));
    }
  index = s7_integer(cadr(args));
  for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) {}
  
  if (!is_pair(p))
    {
      if (is_null(p))
	return(out_of_range(sc, sc->LIST_SET, small_int(2), cadr(args), "should be less than list length"));
      return(wrong_type_argument_with_type(sc, sc->LIST_SET, small_int(1), lst, A_PROPER_LIST));
    }

  car(p) = caddr(args);
  return(car(p));
}


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"
  
  int i;
  s7_Int index;
  s7_pointer p;

  if (!s7_is_list(sc, car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->LIST_TAIL, args);
      return(wrong_type_argument_with_type(sc, sc->LIST_TAIL, small_int(1), car(args), A_LIST));
    }
  if (!s7_is_integer(cadr(args)))
    return(wrong_type_argument(sc, sc->LIST_TAIL, small_int(2), cadr(args), T_INTEGER));
  
  index = s7_integer(cadr(args));
  if (index < 0)
    return(out_of_range(sc, sc->LIST_TAIL, small_int(2), cadr(args), "should be non-negative"));
  if (index > MAX_LIST_LENGTH)
    return(out_of_range(sc, sc->LIST_TAIL, small_int(2), cadr(args), "should be a reasonable integer"));
  
  for (i = 0, p = car(args); (i < index) && (is_pair(p)); i++, p = cdr(p)) {}
  
  if (i < index)
    return(out_of_range(sc, sc->LIST_TAIL, small_int(2), cadr(args), "index should be less than list length"));

  /* I guess this would make sense with more than one index, but I'm not sure it's very important */
  
  return(p);
}


static s7_pointer g_car(s7_scheme *sc, s7_pointer args)
{
  #define H_car "(car pair) returns the first element of the pair"
  if (!is_pair(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CAR, args);
      return(simple_wrong_type_argument(sc, sc->CAR, car(args), T_PAIR));
    }
  return(caar(args));
}


static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdr "(cdr pair) returns the second element of the pair"
  if (!is_pair(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->CDR, args);
      return(simple_wrong_type_argument(sc, sc->CDR, car(args), T_PAIR));
    }
  return(cdar(args));
}


static s7_pointer g_cons(s7_scheme *sc, s7_pointer args)
{
  /* n-ary cons could be the equivalent of CL's list*? */
  /*   it would be neater to have a single cons cell able to contain (directly) any number of elements */
  /*   (set! (cadr (cons 1 2 3)) 4) -> (1 4 . 3) */

  #define H_cons "(cons a b) returns a pair containing a and b"
  
  /* cdr(args) = cadr(args);
   * this is not safe -- it changes a variable's value directly:
   *   (let ((lst (list 1 2))) (list (apply cons lst) lst)) -> '((1 . 2) (1 . 2))
   */
  s7_pointer x;

  NEW_CELL(sc, x);
  car(x) = car(args);
  cdr(x) = cadr(args);
  set_type(x, T_PAIR | T_SAFE_PROCEDURE);
  return(x);
}


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"
  s7_pointer p;

  p = car(args);
  if (!is_pair(p))
    {
      CHECK_METHOD(sc, p, sc->SET_CARB, args);
      return(wrong_type_argument(sc, sc->SET_CARB, small_int(1), p, T_PAIR));
    }
  car(p) = cadr(args);
  return(cadr(args));
}


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"
  s7_pointer p;

  p = car(args);
  if (!is_pair(p))
    {
      CHECK_METHOD(sc, p, sc->SET_CDRB, args);
      return(wrong_type_argument(sc, sc->SET_CDRB, small_int(1), p, T_PAIR));
    }
  cdr(p) = cadr(args);
  return(cadr(args));
}


static void init_car_a_list(void)
{
  CAR_A_LIST = s7_make_permanent_string("a list whose car is also a list");
  CDR_A_LIST = s7_make_permanent_string("a list whose cdr is also a list");

  CAAR_A_LIST = s7_make_permanent_string("a list whose caar is also a list");
  CADR_A_LIST = s7_make_permanent_string("a list whose cadr is also a list");
  CDAR_A_LIST = s7_make_permanent_string("a list whose cdar is also a list");
  CDDR_A_LIST = s7_make_permanent_string("a list whose cddr is also a list");

  CAAAR_A_LIST = s7_make_permanent_string("a list whose caaar is also a list");
  CAADR_A_LIST = s7_make_permanent_string("a list whose caadr is also a list");
  CADAR_A_LIST = s7_make_permanent_string("a list whose cadar is also a list");
  CADDR_A_LIST = s7_make_permanent_string("a list whose caddr is also a list");
  CDAAR_A_LIST = s7_make_permanent_string("a list whose cdaar is also a list");
  CDADR_A_LIST = s7_make_permanent_string("a list whose cdadr is also a list");
  CDDAR_A_LIST = s7_make_permanent_string("a list whose cddar is also a list");
  CDDDR_A_LIST = s7_make_permanent_string("a list whose cdddr is also a list");

  A_LIST = s7_make_permanent_string("a list");
  AN_ASSOCIATION_LIST = s7_make_permanent_string("an association list");
  A_NORMAL_REAL = s7_make_permanent_string("a normal real");
  A_RATIONAL = s7_make_permanent_string("an integer or a ratio");
  A_NUMBER = s7_make_permanent_string("a number");
  A_PROCEDURE = s7_make_permanent_string("a procedure");
  AN_ENVIRONMENT = s7_make_permanent_string("an environment");
  A_PROPER_LIST = s7_make_permanent_string("a proper list");
  A_CLOSURE = s7_make_permanent_string("a function");
  AN_INPUT_PORT = s7_make_permanent_string("an input port");
  AN_OPEN_PORT = s7_make_permanent_string("an open port");
  AN_OUTPUT_PORT = s7_make_permanent_string("an output port");
  A_THUNK = s7_make_permanent_string("a thunk");
  A_SYMBOL = s7_make_permanent_string("a symbol");
  A_NON_NEGATIVE_INTEGER = s7_make_permanent_string("a non-negative integer");
  AN_UNSIGNED_BYTE = s7_make_permanent_string("an unsigned byte");
  SOMETHING_APPLICABLE = s7_make_permanent_string("a procedure or something applicable");
  CONSTANT_ARG_ERROR = s7_make_permanent_string("lambda* parameter '~A is a constant");
  BAD_BINDING = s7_make_permanent_string("~A: can't bind some variable to ~S");
  A_FORMAT_PORT = s7_make_permanent_string("#f, #t, or an open output port");
}


static s7_pointer g_caar(s7_scheme *sc, s7_pointer args)
{
  #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAAR, args);
      return(simple_wrong_type_argument(sc, sc->CAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAR, lst, CAR_A_LIST));
  
  /* it makes absolutely no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) 
   */
  return(car(car(lst)));
}

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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADR, args);
      return(simple_wrong_type_argument(sc, sc->CADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADR, lst, CDR_A_LIST));

  return(car(cdr(lst)));
}


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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDAR, args);
      return(simple_wrong_type_argument(sc, sc->CDAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAR, lst, CAR_A_LIST));

  return(cdr(car(lst)));
}


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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDR, args);
      return(simple_wrong_type_argument(sc, sc->CDDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDR, lst, CDR_A_LIST));

  return(cdr(cdr(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAAAR, args);
      return(simple_wrong_type_argument(sc, sc->CAAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAR, lst, CAR_A_LIST));
  if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAR, lst, CAAR_A_LIST));

  return(car(car(car(lst))));
}


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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAADR, args);
      return(simple_wrong_type_argument(sc, sc->CAADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADR, lst, CDR_A_LIST));
  if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CAADR, lst, CADR_A_LIST));

  return(car(car(cdr(lst))));
}


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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADAR, args);
      return(simple_wrong_type_argument(sc, sc->CADAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAR, lst, CAR_A_LIST));
  if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CADAR, lst, CDAR_A_LIST));

  return(car(cdr(car(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDAAR, args);
      return(simple_wrong_type_argument(sc, sc->CDAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAR, lst, CAR_A_LIST));
  if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAR, lst, CAAR_A_LIST));

  return(cdr(car(car(lst))));
}


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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADDR, args);
      return(simple_wrong_type_argument(sc, sc->CADDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDR, lst, CDR_A_LIST));
  if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CADDR, lst, CDDR_A_LIST));

  return(car(cdr(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDDR, args);
      return(simple_wrong_type_argument(sc, sc->CDDDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDR, lst, CDR_A_LIST));
  if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDR, lst, CDDR_A_LIST));

  return(cdr(cdr(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDADR, args);
      return(simple_wrong_type_argument(sc, sc->CDADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADR, lst, CDR_A_LIST));
  if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDADR, lst, CADR_A_LIST));

  return(cdr(car(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDAR, args);
      return(simple_wrong_type_argument(sc, sc->CDDAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAR, lst, CAR_A_LIST));
  if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAR, lst, CDAR_A_LIST));

  return(cdr(cdr(car(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAAAAR, args);
      return(simple_wrong_type_argument(sc, sc->CAAAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAR_A_LIST));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAAR_A_LIST));
  if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAAAR, lst, CAAAR_A_LIST));

  return(car(car(car(car(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAAADR, args);
      return(simple_wrong_type_argument(sc, sc->CAAADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CDR_A_LIST));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CADR_A_LIST));
  if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAAADR, lst, CAADR_A_LIST));

  return(car(car(car(cdr(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAADAR, args);
      return(simple_wrong_type_argument(sc, sc->CAADAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CAR_A_LIST));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CDAR_A_LIST));
  if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADAR, lst, CADAR_A_LIST));

  return(car(car(cdr(car(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADAAR, args);
      return(simple_wrong_type_argument(sc, sc->CADAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CAR_A_LIST));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CAAR_A_LIST));
  if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADAAR, lst, CDAAR_A_LIST));

  return(car(cdr(car(car(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CAADDR, args);
      return(simple_wrong_type_argument(sc, sc->CAADDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CDR_A_LIST));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CDDR_A_LIST));
  if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CAADDR, lst, CADDR_A_LIST));

  return(car(car(cdr(cdr(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADDDR, args);
      return(simple_wrong_type_argument(sc, sc->CADDDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDR_A_LIST));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDDR_A_LIST));
  if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDDR, lst, CDDDR_A_LIST));

  return(car(cdr(cdr(cdr(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADADR, args);
      return(simple_wrong_type_argument(sc, sc->CADADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CDR_A_LIST));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CADR_A_LIST));
  if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADADR, lst, CDADR_A_LIST));

  return(car(cdr(car(cdr(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"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CADDAR, args);
      return(simple_wrong_type_argument(sc, sc->CADDAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CAR_A_LIST));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CDAR_A_LIST));
  if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CADDAR, lst, CDDAR_A_LIST));

  return(car(cdr(cdr(car(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDAAAR, args);
      return(simple_wrong_type_argument(sc, sc->CDAAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAR_A_LIST));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAAR_A_LIST));
  if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAAAR, lst, CAAAR_A_LIST));

  return(cdr(car(car(car(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDAADR, args);
      return(simple_wrong_type_argument(sc, sc->CDAADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CDR_A_LIST));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CADR_A_LIST));
  if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDAADR, lst, CAADR_A_LIST));

  return(cdr(car(car(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDADAR, args);
      return(simple_wrong_type_argument(sc, sc->CDADAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CAR_A_LIST));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CDAR_A_LIST));
  if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADAR, lst, CADAR_A_LIST));

  return(cdr(car(cdr(car(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDAAR, args);
      return(simple_wrong_type_argument(sc, sc->CDDAAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CAR_A_LIST));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CAAR_A_LIST));
  if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDAAR, lst, CDAAR_A_LIST));

  return(cdr(cdr(car(car(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDADDR, args);
      return(simple_wrong_type_argument(sc, sc->CDADDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CDR_A_LIST));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CDDR_A_LIST));
  if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDADDR, lst, CADDR_A_LIST));

  return(cdr(car(cdr(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDDDR, args);
      return(simple_wrong_type_argument(sc, sc->CDDDDR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDR_A_LIST));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDDR_A_LIST));
  if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDDR, lst, CDDDR_A_LIST));

  return(cdr(cdr(cdr(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDADR, args);
      return(simple_wrong_type_argument(sc, sc->CDDADR, lst, T_PAIR));
    }
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CDR_A_LIST));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CADR_A_LIST));
  if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDADR, lst, CDADR_A_LIST));

  return(cdr(cdr(car(cdr(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)"
  s7_pointer lst = car(args);

  if (!is_pair(lst)) 
    {
      CHECK_METHOD(sc, lst, sc->CDDDAR, args);
      return(simple_wrong_type_argument(sc, sc->CDDDAR, lst, T_PAIR));
    }
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CAR_A_LIST));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CDAR_A_LIST));
  if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->CDDDAR, lst, CDDAR_A_LIST));

  return(cdr(cdr(cdr(car(lst)))));
}


/* reverse is in the generic function section */
static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args)
{
  #define H_reverse_in_place "(reverse! lst) reverses lst in place"
  s7_pointer p, np;
  
  p = car(args);
  if (is_null(p))
    return(sc->NIL);
  
  if (!is_pair(p))
    {
      CHECK_METHOD(sc, p, sc->REVERSEB, args);
      return(simple_wrong_type_argument_with_type(sc, sc->REVERSEB, p, A_LIST));
    }
  
  np = reverse_in_place(sc, sc->NIL, p);
  if (is_null(np))
    return(simple_wrong_type_argument_with_type(sc, sc->REVERSEB, p, A_PROPER_LIST));
  
  return(np);
}


s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
{
  s7_pointer y;
  y = x;
  while (true)
    {
      /* we can blithely take the car of anything, since we're not treating it as an object,
       *   then if we get a bogus match, the following check that caar made sense ought to catch it.
       *
       * I thought I could speed this up by having econs/essq using the ecdr field for the key, but
       *   the difference is only 10%.
       */
      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == caar(x)) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}


static s7_pointer 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"
  /* this version accepts any kind of list 
   *   my little essay: the scheme standard should not unnecessarily restrict the kinds of arguments
   *                    a function can take (such as saying memq only accepts proper lists).  It is
   *                    trivial for the programmer to add such a check to a built-in function, but
   *                    not trivial to re-invent the built-in function with that restriction removed.
   *                    If some structure exists as a normal scheme object (a dotted or circular list),
   *                    every built-in function should be able to deal with it, if it makes sense at all.
   */

  s7_pointer x;

  x = cadr(args);
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->ASSQ, args);
      return(wrong_type_argument_with_type(sc, sc->ASSQ, small_int(2), x, AN_ASSOCIATION_LIST));
    }
  return(s7_assq(sc, car(args), x));
}


static s7_pointer g_assv(s7_scheme *sc, s7_pointer args)
{
  #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist"
  s7_pointer x, y, obj;

  x = cadr(args);
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->ASSV, args);
      return(wrong_type_argument_with_type(sc, sc->ASSV, small_int(2), x, AN_ASSOCIATION_LIST));
    }
  obj = car(args);
  if (is_simple(obj))
    return(s7_assq(sc, obj, x));

  y = x;
  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(x))) && (s7_is_eqv(obj, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((is_pair(car(x))) && (s7_is_eqv(obj, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}


static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args)
{
  #define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\
If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"

  s7_pointer x, y, obj;

  x = cadr(args);      

  if (!is_pair(x))
    {
      if (is_null(x)) 
	return(sc->F);
      CHECK_METHOD(sc, x, sc->ASSOC, args);
      return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(2), x, AN_ASSOCIATION_LIST));
    }
  if (!is_pair(car(x)))
    return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(2), x, AN_ASSOCIATION_LIST)); /* we're assuming caar below so it better exist */

  if (is_not_null(cddr(args))) 
    {
      s7_pointer eq_func;
      /* check third arg before second (trailing arg error check) */

      eq_func = caddr(args);
      if (!is_procedure(eq_func))
	return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(3), eq_func, A_CLOSURE));

      if (!s7_is_aritable(sc, eq_func, 2))
	return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(3), eq_func, 
					     make_protected_string(sc, "a procedure that can take 2 arguments")));
      /* now maybe there's a simple case */
      if (s7_list_length(sc, x) > 0)
	{
	  if ((is_safe_procedure(eq_func)) &&
	      (is_c_function(eq_func)))
	    {
	      s7_function func;
	      
	      func = c_function_call(eq_func);
	      car(sc->T2_1) = car(args);
	      for (; is_pair(x); x = cdr(x))
		{
		  if (is_pair(car(x)))
		    {
		      car(sc->T2_2) = caar(x);
		      if (is_true(sc, (*func)(sc, sc->T2_1)))
			return(car(x));
		      /* I wonder if the assoc equality function should get the cons, not just caar?
		       */
		    }
		  else return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(2), cadr(args), AN_ASSOCIATION_LIST));
		}
	      return(sc->F);
	    }
	}

      /* sc->value = sc->F; */
      y = cons(sc, args, sc->NIL);
      set_ecdr(y, x);
      set_fcdr(y, x);
      push_stack(sc, OP_ASSOC_IF, y, eq_func);
      push_stack(sc, OP_APPLY, list_2(sc, car(args), caar(x)), eq_func);
      return(sc->UNSPECIFIED);
    }

  x = cadr(args);
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->ASSOC, args);
      return(wrong_type_argument_with_type(sc, sc->ASSOC, small_int(2), x, AN_ASSOCIATION_LIST));
    }
  obj = car(args);

  if (is_simple(obj))
    return(s7_assq(sc, obj, x));

  y = x;
  if (is_string(obj))
    {
      s7_pointer val;
      while (true)
	{
	  if (is_pair(car(x)))
	    {
	      val = caar(x);
	      if ((val == obj) ||
		  ((is_string(val)) &&
		   (scheme_strings_are_equal(obj, val))))
		return(car(x));
	    }
	  x = cdr(x);
	  if (!is_pair(x)) return(sc->F);

	  if (is_pair(car(x)))
	    {
	      val = caar(x);
	      if ((val == obj) ||
		  ((is_string(val)) &&
		   (scheme_strings_are_equal(obj, val))))
		return(car(x));
	    }
	  x = cdr(x);
	  if (!is_pair(x)) return(sc->F);
      
	  y = cdr(y);
	  if (x == y) return(sc->F);
	}
      return(sc->F);
    }

  while (true)
    {
      if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}


/* ---------------- member, memv, memq ---------------- */

s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
{
  s7_pointer y;
  y = x;
  while (true)
    {
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F);
}


static s7_pointer 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?"
  s7_pointer x;

  x = cadr(args);
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->MEMQ, args);
      return(wrong_type_argument_with_type(sc, sc->MEMQ, small_int(2), x, A_LIST));
    }
  return(s7_memq(sc, car(args), x));
}

/* 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 memq_3, memq_4, memq_any;

static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, obj;
  x = cadr(args);
  obj = car(args);
  while (true)
    {
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, obj;
  x = cadr(args);
  obj = car(args);
  while (true)
    {
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args)
{
  /* no circular list check needed in this case */
  s7_pointer x, obj;
  x = cadr(args);
  obj = car(args);
  while (true)
    {
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F); /* every other pair check could be omitted */

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
    }
  return(sc->F);
}


static s7_pointer memq_car;
static s7_pointer g_memq_car(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, obj;

  obj = finder(sc, cadar(args));
  if (!is_pair(obj))
    {
      s7_pointer func;
      if ((has_methods(obj)) &&
	  ((func = find_method(sc, find_environment(sc, obj), sc->CAR)) != sc->UNDEFINED))
	obj = s7_apply_function(sc, func, list_1(sc, obj));
      if (!is_pair(obj))
	return(simple_wrong_type_argument(sc, sc->CAR, obj, T_PAIR));
    }
  obj = car(obj);
  x = cadr(cadr(args));

  while (true)
    {
      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if (obj == car(x)) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
    }
  return(sc->F);
}

static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((is_pair(caddr(expr))) &&
      (car(caddr(expr)) == sc->QUOTE) &&
      (is_pair(cadr(caddr(expr)))))
    {
      int len;

      if ((is_pair(cadr(expr))) &&
	  (is_optimized(cadr(expr))) &&
	  (optimize_data(cadr(expr)) == HOP_SAFE_C_S) &&
	  (c_call(cadr(expr)) == g_car))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(memq_car);
	}

      len = s7_list_length(sc, cadr(caddr(expr)));
      if (len > 0)
	{
	  if ((len % 4) == 0)
	    return(memq_4);
	  if ((len % 3) == 0)
	    return(memq_3);
	  return(memq_any);
	}
    }
  return(f);
}


static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer x)
{
  s7_pointer y;
  y = x;
  while (true)
    {
      if ((s7_is_number(car(x))) && (numbers_are_eqv(obj, car(x)))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      if ((s7_is_number(car(x))) && (numbers_are_eqv(obj, car(x)))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      if ((s7_is_number(car(x))) && (numbers_are_eqv(obj, car(x)))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      if ((s7_is_number(car(x))) && (numbers_are_eqv(obj, car(x)))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F);
}


static s7_pointer 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?"
  s7_pointer x, y, obj;

  x = cadr(args);
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->MEMV, args);
      return(wrong_type_argument_with_type(sc, sc->MEMV, small_int(2), x, A_LIST));
    }
  obj = car(args);

  if (is_simple(obj))
    return(s7_memq(sc, obj, x));

  if (s7_is_number(obj))
    return(memv_number(sc, obj, x));

  y = x;
  while (true)
    {
      if (s7_is_eqv(obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if (s7_is_eqv(obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}


static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x)
{
  s7_pointer y;

  y = x;
  if (is_string(obj))
    {
      while (true)
	{
	  if ((obj == car(x)) ||
	      ((is_string(car(x))) &&
	       (scheme_strings_are_equal(obj, car(x)))))
	    return(x);
	  x = cdr(x);
	  if (!is_pair(x)) return(sc->F);

	  if ((obj == car(x)) ||
	      ((is_string(car(x))) &&
	       (scheme_strings_are_equal(obj, car(x)))))
	    return(x);
	  x = cdr(x);
	  if (!is_pair(x)) return(sc->F);
      
	  y = cdr(y);
	  if (x == y) return(sc->F);
	}
      return(sc->F);
    }

  while (true)
    {
      if (s7_is_equal(sc, obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if (s7_is_equal(sc, obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if (s7_is_equal(sc, obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      if (s7_is_equal(sc, obj, car(x))) return(x);
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);
      
      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}


static s7_pointer g_member(s7_scheme *sc, s7_pointer args)
{
  #define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \
member uses equal?  If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"

  /* 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) =) ? -- for c_objects (ffi) we would need a substring equivalent
   *      and what would it do for a hash-table? or an environment?
   * also the 3 arg version can implement position, find, etc
   */

  s7_pointer x, y, obj;

  x = cadr(args);

  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->MEMBER, args);
      return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(2), x, A_LIST));
    }

  if (is_not_null(cddr(args))) 
    {
      s7_pointer eq_func;
      /* check third arg before second (trailing arg error check) */

      eq_func = caddr(args);
      if (!is_procedure(eq_func))
	return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(3), eq_func, A_CLOSURE));

      if (!s7_is_aritable(sc, eq_func, 2))
	return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(3), eq_func, 
					     make_protected_string(sc, "a procedure that can take 2 arguments")));
      /* now maybe there's a simple case */
      if (s7_list_length(sc, x) > 0)
	{
	  if ((is_safe_procedure(eq_func)) &&
	      (is_c_function(eq_func)))
	    {
	      s7_function func;

	      func = c_function_call(eq_func);
	      car(sc->T2_1) = car(args);

	      for (; is_pair(x); x = cdr(x))
		{
		  car(sc->T2_2) = car(x);
		  if (is_true(sc, (*func)(sc, sc->T2_1)))
		    return(x);
		}
	      return(sc->F);
	    }
	}

      y = cons(sc, args, sc->NIL); /* this could probably be handled with a counter cell (cdr here is unused) */
      set_ecdr(y, x);
      set_fcdr(y, x);
      push_stack(sc, OP_MEMBER_IF, y, eq_func);
      car(sc->T2_1) = car(args);
      car(sc->T2_2) = car(x);
      push_stack(sc, OP_APPLY, sc->T2_1, eq_func); 
      return(sc->UNSPECIFIED);
    }

  obj = car(args);

  if (is_simple(obj))
    return(s7_memq(sc, obj, x));

  /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer
   *   but all the other cases are unlikely.
   */

  if (s7_is_number(obj))
    return(memv_number(sc, obj, x));

  return(member(sc, obj, x));
}


static s7_pointer member_sq;
static s7_pointer g_member_sq(s7_scheme *sc, s7_pointer args)
{
  s7_pointer obj, lst;
  lst = cadr(cadr(args));
  obj = finder(sc, car(args));

  if (is_simple(obj))
    return(s7_memq(sc, obj, lst));

  if (s7_is_number(obj))
    return(memv_number(sc, obj, lst));

  return(member(sc, obj, lst));
}

static s7_pointer member_sym_s;
static s7_pointer g_member_sym_s(s7_scheme *sc, s7_pointer args)
{
  /* first arg is quoted symbol: (member 'a lst) */
  s7_pointer lst;

  lst = finder(sc, cadr(args));
  if (!is_pair(lst))
    {
      if (is_null(lst)) return(sc->F);
      CHECK_METHOD(sc, lst, sc->MEMBER, list_2(sc, cadar(args), lst));
      return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(2), lst, A_LIST));
    }
  return(s7_memq(sc, cadar(args), lst)); /* car(cadr(args)) removes the quote from (quote sym) */
}

static s7_pointer member_num_s;
static s7_pointer g_member_num_s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer lst;

  lst = finder(sc, cadr(args));
  if (!is_pair(lst))
    {
      if (is_null(lst)) return(sc->F);
      CHECK_METHOD(sc, lst, sc->MEMBER, list_2(sc, car(args), lst));
      return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(2), lst, A_LIST));
    }
  return(memv_number(sc, car(args), lst));
}

static s7_pointer member_ss;
static s7_pointer g_member_ss(s7_scheme *sc, s7_pointer args)
{
  s7_pointer obj, x;

  obj = finder(sc, car(args));
  x = finder(sc, cadr(args));
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      CHECK_METHOD(sc, x, sc->MEMBER, list_2(sc, obj, x));
      return(wrong_type_argument_with_type(sc, sc->MEMBER, small_int(2), x, A_LIST));
    }

  if (is_simple(obj))
    return(s7_memq(sc, obj, x));

  if (s7_is_number(obj))
    return(memv_number(sc, obj, x));

  return(member(sc, obj, x));
}

static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (is_symbol(caddr(expr)))
	{
	  if ((is_pair(cadr(expr))) &&
	      (car(cadr(expr)) == sc->QUOTE) &&
	      (is_symbol(cadr(cadr(expr)))))
	    {
	      /* (member 'a odd) */
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(member_sym_s);
	    }

	  if (s7_is_number(cadr(expr)))
	    {
	      /* (member 4 lst) */
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(member_num_s);
	    }

	  if (is_symbol(cadr(expr)))
	    {
	      /* (member obj lst) */
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(member_ss);
	    }
	}
      else
	{
	  if ((is_symbol(cadr(expr))) &&
	      (is_pair(caddr(expr))) &&
	      (car(caddr(expr)) == sc->QUOTE) &&
	      (is_pair(cadr(caddr(expr)))))
	    {
	      /* (member q '(quote lambda case)) */
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(member_sq);
	    }
	}
    }
  return(f);
}


static bool is_member(s7_pointer sym, s7_pointer lst)
{
  s7_pointer x;
  for (x = lst; is_pair(x); x = cdr(x))
    if (sym == car(x))
      return(true);
  return(false);
}


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"
  if (!is_symbol(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->PROVIDEDP, args);
      return(simple_wrong_type_argument(sc, sc->PROVIDEDP, car(args), T_SYMBOL));
    }
  return(make_boolean(sc, is_member(car(args), s7_symbol_value(sc, sc->S7_FEATURES))));
}


static s7_pointer g_provide(s7_scheme *sc, s7_pointer args)
{
  #define H_provide "(provide symbol) adds symbol to the *features* list"
  if (!is_symbol(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->PROVIDE, args);
      return(simple_wrong_type_argument(sc, sc->PROVIDE, car(args), T_SYMBOL));
    }

  if (!is_member(car(args), s7_symbol_value(sc, sc->S7_FEATURES)))
    s7_symbol_set_value(sc, 
			sc->S7_FEATURES,
			cons(sc, car(args), s7_symbol_value(sc, sc->S7_FEATURES)));
  return(car(args));
}


void s7_provide(s7_scheme *sc, const char *feature)
{
  g_provide(sc, cons(sc, s7_make_symbol(sc, feature), sc->NIL));
}


bool s7_is_provided(s7_scheme *sc, const char *feature)
{
  return(is_member(s7_make_symbol(sc, feature), s7_symbol_value(sc, sc->S7_FEATURES)));
}


static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_list(sc, cadr(args)))
    return(cadr(args));
  return(sc->ERROR);
}



static s7_pointer g_list(s7_scheme *sc, s7_pointer args)
{
  #define H_list "(list ...) returns its arguments in a list"

  return(args);
}


s7_pointer s7_list(s7_scheme *sc, int num_values, ...)
{
  int i;
  va_list ap;
  s7_pointer p;
  
  if (num_values == 0)
    return(sc->NIL);

  sc->w = sc->NIL;
  va_start(ap, num_values);
  for (i = 0; i < num_values; i++)
    sc->w = cons(sc, va_arg(ap, s7_pointer), sc->w);
  va_end(ap);

  p = sc->w;
  sc->w = sc->NIL;

  return(safe_reverse_in_place(sc, p));
}


static s7_pointer g_append(s7_scheme *sc, s7_pointer args)
{
  #define H_append "(append ...) returns its argument lists appended into one list"
  /* but weirdly (append '() 1) returns 1 
   */
  s7_pointer x, y;

  if (is_null(args)) 
    return(sc->NIL);

  if (is_null(cdr(args)))
    return(car(args)); 
  
  x = sc->NIL;
  for (y = args; is_not_null(y); y = cdr(y)) 
    {
      /* the original version used s7_append but that copies the arguments too many times if there are 3 or more lists */
      s7_pointer p;
      if (is_null(cdr(y)))
	return(reverse_in_place(sc, car(y), x)); /* i.e. tack car(y) onto end of x copied and reversed */

      p = car(y);
      if (!is_proper_list(sc, p))
	return(wrong_type_argument_n_with_type(sc, sc->APPEND, position_of(y, args), p, A_PROPER_LIST));
      /* is this error correct?
       *   (append '(3) '(1 . 2))
       *   '(3 1 . 2)
       * but
       *   (append '(1 . 2) '(3))
       *   gives this error
       */
      while (is_not_null(p))
	{
	  x = cons(sc, car(p), x);
	  p = cdr(p);
	}
    }
  return(x);
}


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);
  cdr(p) = b;
  return(a);
}



/* -------------------------------- vectors -------------------------------- */

bool s7_is_vector(s7_pointer p)    
{ 
  return(t_vector_p[type(p)]);
}


bool s7_is_float_vector(s7_pointer p)    
{ 
  return(type(p) == T_FLOAT_VECTOR);
}


bool s7_is_int_vector(s7_pointer p)    
{ 
  return(type(p) == T_INT_VECTOR);
}


static s7_pointer default_vector_setter(s7_scheme *sc, s7_pointer vec, s7_Int loc, s7_pointer val)
{
  vector_element(vec, loc) = val;
  return(val);
}

static s7_pointer default_vector_getter(s7_scheme *sc, s7_pointer vec, s7_Int loc) 
{
  return(vector_element(vec, loc));
}

static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_Int loc, s7_pointer val)
{
  int_vector_element(vec, loc) = s7_number_to_integer(sc, val);
  return(val);
}

static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_Int loc) 
{
  return(s7_make_integer(sc, int_vector_element(vec, loc)));
}

static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_Int loc, s7_pointer val)
{
  float_vector_element(vec, loc) = s7_number_to_real(sc, val);
  return(val);
}

static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_Int loc) 
{
  return(s7_make_real(sc, float_vector_element(vec, loc)));
}


#define FILLED true
#define NOT_FILLED false

static s7_pointer make_vector_1(s7_scheme *sc, s7_Int len, bool filled, int typ) 
{
  s7_pointer x;
  if (len > 134217728)
    {
      /* len is an "int" currently */
      float ilog2;

      ilog2 = log((double)len) / log(2.0);
      if (sizeof(size_t) > 4)
	{
	  if (ilog2 > 56.0)
	    return(out_of_range(sc, sc->MAKE_VECTOR, small_int(1), make_integer(sc, len), "should be less than about 2^56 probably"));
	}
      else
	{
	  if (ilog2 > 28.0)
	    return(out_of_range(sc, sc->MAKE_VECTOR, small_int(1), make_integer(sc, len), "should be less than about 2^28 probably"));
	}
    }
  if (len == 0) typ = T_VECTOR; /* all empty vectors are the same type */

  /* this has to follow the error checks!  (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */
  NEW_CELL(sc, x);                     
  vector_length(x) = 0;
  vector_elements(x) = NULL;
  set_type(x, typ | T_SAFE_PROCEDURE); /* (v 0) as vector-ref is safe */

  if (len > 0)
    {
      if (typ == T_VECTOR)
	{
	  vector_elements(x) = (s7_pointer *)malloc(len * sizeof(s7_pointer));
	  vector_getter(x) = default_vector_getter;
	  vector_setter(x) = default_vector_setter;
	}
      else
	{
	  if (typ == T_INT_VECTOR)
	    {
	      int_vector_elements(x) = (s7_Int *)malloc(len * sizeof(s7_Int));
	      vector_getter(x) = int_vector_getter;
	      vector_setter(x) = int_vector_setter;
	    }
	  else 
	    {
	      float_vector_elements(x) = (s7_Double *)malloc(len * sizeof(s7_Double));
	      vector_getter(x) = float_vector_getter;
	      vector_setter(x) = float_vector_setter;
	    }
	}
      if (!(vector_elements(x)))
	return(s7_error(sc, make_symbol(sc, "out-of-memory"), 
			list_1(sc, make_protected_string(sc, "make-vector allocation failed!"))));

      vector_length(x) = len;
      /* make_hash_table assumes nil as the default value */
      if (filled) s7_vector_fill(sc, x, ((typ == T_VECTOR) ? sc->NIL : ((typ == T_INT_VECTOR) ? small_int(0) : real_zero)));
    }

  vector_dimension_info(x) = NULL;
  add_vector(sc, x);
  return(x);
}


s7_pointer s7_make_vector(s7_scheme *sc, s7_Int len)
{
  return(make_vector_1(sc, len, FILLED, T_VECTOR));
}


static s7_vdims_t *make_vdims(s7_scheme *sc, bool elements_allocated, int dims, s7_Int *dim_info)
{
  s7_vdims_t *v;
  int i;
  s7_Int offset = 1;

  v = (s7_vdims_t *)malloc(sizeof(s7_vdims_t));
  v->ndims = dims;
  v->elements_allocated = elements_allocated;
  v->dimensions_allocated = true;
  v->original = sc->F;
  v->dims = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));
  v->offsets = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));

  for (i = 0; i < dims; i++)
    v->dims[i] = dim_info[i];
  for (i = v->ndims - 1; i >= 0; i--)
    {
      v->offsets[i] = offset;
      offset *= v->dims[i];
    }
  
  return(v);
}


s7_pointer s7_make_int_vector(s7_scheme *sc, s7_Int len, int dims, s7_Int *dim_info)
{
  s7_pointer p;
  p = make_vector_1(sc, len, FILLED, T_INT_VECTOR);
  if (dim_info)
    vector_dimension_info(p) = make_vdims(sc, true, dims, dim_info);
  return(p);
}


s7_pointer s7_make_float_vector(s7_scheme *sc, s7_Int len, int dims, s7_Int *dim_info)
{
  s7_pointer p;
  p = make_vector_1(sc, len, FILLED, T_FLOAT_VECTOR);
  if (dim_info)
    vector_dimension_info(p) = make_vdims(sc, true, dims, dim_info);
  return(p);
}

s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_Int len, s7_Double *data, int dims, s7_Int *dim_info)
{
  /* this wraps up a C-allocated/freed double array as an s7 vector.
   */
  s7_pointer x;

  NEW_CELL(sc, x);                     
  set_type(x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
  float_vector_elements(x) = data;
  vector_getter(x) = float_vector_getter;
  vector_setter(x) = float_vector_setter;
  vector_length(x) = len;
  if (dim_info)
    vector_dimension_info(x) = make_vdims(sc, false, dims, dim_info);
  else vector_dimension_info(x) = NULL;
  add_vector(sc, x);

  return(x);
}


s7_Int s7_vector_length(s7_pointer vec)
{
  return(vector_length(vec));
}


s7_Int s7_vector_print_length(s7_scheme *sc)
{
  return(s7_integer(slot_value(sc->vector_print_length)));
}


s7_Int s7_set_vector_print_length(s7_scheme *sc, s7_Int new_len)
{
  s7_Int old_len;
  old_len = s7_integer(slot_value(sc->vector_print_length));
  slot_set_value(sc->vector_print_length, make_integer(sc, new_len));
  return(old_len);
}


static s7_pointer g_vector_print_length_set(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_integer(cadr(args)))
    {
      s7_Int len;
      len = s7_integer(cadr(args));
      if (len >= 0)
	return(cadr(args));
    }
  return(sc->ERROR);
}


#if (!WITH_GMP)
void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
#else
static void vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
#endif
{
  s7_Int len, i, left;

  len = vector_length(vec);
  if (len == 0) return;
  left = len - 8;
  i = 0;

  if (is_int_vector(vec))
    {
      s7_Int k;
      k = s7_number_to_integer(sc, obj);
      if (k == 0)
	memset((void *)int_vector_elements(vec), 0, len * sizeof(s7_Int));
      else
	{
	  s7_Int* orig;
	  orig = int_vector_elements(vec);
	  while (i <= left)
	    {
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	      orig[i++] = k;
	    }
	  for (; i< len; i++)
	    orig[i] = k;
	}
    }
  else
    {
      if (is_float_vector(vec))
	{
	  s7_Double x;
	  x = s7_number_to_real(sc, obj);
	  if (x == 0.0)
	    memset((void *)float_vector_elements(vec), 0, len * sizeof(s7_Double));
	  else
	    {
	      s7_Double *orig;
	      orig = float_vector_elements(vec);
	      while (i <= left)
		{
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		  orig[i++] = x;
		}
	      for (; i< len; i++)
		orig[i] = x;
	    }
	}
      else
	{
	  s7_pointer *orig;
	  orig = vector_elements(vec);
	  while (i <= left)
	    {
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	      orig[i++] = obj;
	    }
	  for (; i< len; i++)
	    orig[i] = obj;
	}
    }
}


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"
  s7_pointer x, fill;
  s7_Int start = 0, end;

  x = car(args);
  if (!s7_is_vector(x))
    {
      CHECK_METHOD(sc, x, sc->VECTOR_FILL, args);
      return(wrong_type_argument(sc, sc->VECTOR_FILL, small_int(1), x, T_VECTOR));
    }

  fill = cadr(args);
  end = vector_length(x);
  if (end == 0) return(fill);

  if (!is_null(cddr(args)))
    {
      start_and_end(sc, sc->VECTOR_FILL, cddr(args), 3, &start, &end);
      if (start == end) return(fill);
    }

  if ((start == 0) && (end == vector_length(x)))
    s7_vector_fill(sc, x, fill);
  else
    {
      s7_Int i;
      for (i = start; i < end; i++)
	vector_element(x, i) = fill;
    }
  return(fill);
}


s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_Int index) 
{
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), make_integer(sc, index), "should be less than vector length"));

  return(vector_getter(vec)(sc, vec, index));
}


s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_Int index, s7_pointer a) 
{
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_SET, small_int(2), make_integer(sc, index), "should be less than vector length"));

  vector_setter(vec)(sc, vec, index, a);
  return(a);
}


s7_pointer *s7_vector_elements(s7_pointer vec)
{
  return(vector_elements(vec));
}


s7_Int *s7_int_vector_elements(s7_pointer vec)
{
  return(int_vector_elements(vec));
}


s7_Double *s7_float_vector_elements(s7_pointer vec)
{
  return(float_vector_elements(vec));
}


s7_Int *s7_vector_dimensions(s7_pointer vec)
{
  s7_Int *dims;
  if (vector_dimension_info(vec))
    return(vector_dimensions(vec));
  dims = (s7_Int *)malloc(sizeof(s7_Int));
  dims[0] = vector_length(vec);
  return(dims);
}


s7_Int *s7_vector_offsets(s7_pointer vec)
{
  s7_Int *offs;
  if (vector_dimension_info(vec))
    return(vector_offsets(vec));
  offs = (s7_Int *)malloc(sizeof(s7_Int));
  offs[0] = 1;
  return(offs);
}


static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
{
  #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments."
  s7_Int i = 0, j, len = 0, source_len;
  s7_pointer p, v, x;
  int result_type = -1;

  if (is_null(args))
    return(make_vector_1(sc, 0, false, T_VECTOR));

  for (p = args; is_pair(p); p = cdr(p))
    {
      x = car(p);
      if (!s7_is_vector(x))
	{
	  CHECK_METHOD(sc, x, sc->VECTOR_APPEND, args);
	  return(wrong_type_argument_n(sc, sc->VECTOR_APPEND, position_of(p, args), x, T_VECTOR));
	}
      len += vector_length(x);
      if (result_type == -1)
	result_type = type(x);
      else
	{
	  if (result_type != type(x))
	    result_type = T_VECTOR;
	}
    }
  
  v = make_vector_1(sc, len, false, result_type);
  if (result_type == T_VECTOR)
    {
      s7_pointer *dest;
      dest = vector_elements(v);
      for (p = args; is_pair(p); p = cdr(p))
	{
	  x = car(p);
	  source_len = vector_length(x);
	  for (j = 0; j < source_len; j++, i++)
	    dest[i] = vector_getter(x)(sc, x, j);
	}
    }
  else
    {
      if (result_type == T_INT_VECTOR)
	{
	  s7_Int *dest, *source;
	  dest = int_vector_elements(v);
	  for (p = args; is_pair(p); p = cdr(p))
	    {
	      x = car(p);
	      source = int_vector_elements(x);
	      source_len = vector_length(x);
	      for (j = 0; j < source_len; j++, i++)
		dest[i] = source[j];
	    }
	}
      else
	{
	  s7_Double *dest, *source;
	  dest = float_vector_elements(v);
	  for (p = args; is_pair(p); p = cdr(p))
	    {
	      x = car(p);
	      source = float_vector_elements(x);
	      source_len = vector_length(x);
	      for (j = 0; j < source_len; j++, i++)
		dest[i] = source[j];
	    }
	}
    }

  return(v);
}


s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, int indices, ...)
{
  /* from s7.html */
  int ndims;

  ndims = s7_vector_rank(vector);
  if (ndims == indices)
    {
      va_list ap;
      s7_Int index = 0;
      va_start(ap, indices);

      if (ndims == 1)
	{
	  index = va_arg(ap, s7_Int);
	  va_end(ap);
	  return(s7_vector_ref(sc, vector, index));
	}
      else
	{
	  int i;
	  s7_Int *offsets, *dimensions;

	  dimensions = s7_vector_dimensions(vector);
	  offsets = s7_vector_offsets(vector);

	  for (i = 0; i < indices; i++)
	    {
	      int ind;
	      ind = va_arg(ap, int);
	      if ((ind < 0) ||
		  (ind >= dimensions[i]))
		{
		  va_end(ap);
		  return(s7_out_of_range_error(sc, "s7_vector_ref_n", i, s7_make_integer(sc, ind), "index should be between 0 and the dimension size"));
		}
	      index += (ind * offsets[i]);
	    }
	  va_end(ap);
	  return(vector_getter(vector)(sc, vector, index));
	}
    }
  return(s7_wrong_number_of_args_error(sc, "s7_vector_ref_n: wrong number of indices: ~A", s7_make_integer(sc, indices)));
}



s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, int indices, ...)
{
  int ndims;

  ndims = s7_vector_rank(vector);
  if (ndims == indices)
    {
      va_list ap;
      s7_Int index = 0;
      va_start(ap, indices);

      if (ndims == 1)
	{
	  index = va_arg(ap, s7_Int);
	  va_end(ap);
	  s7_vector_set(sc, vector, index, value);
	  return(value);
	}
      else
	{
	  int i;
	  s7_Int *offsets, *dimensions;

	  dimensions = s7_vector_dimensions(vector);
	  offsets = s7_vector_offsets(vector);

	  for (i = 0; i < indices; i++)
	    {
	      int ind;
	      ind = va_arg(ap, int);
	      if ((ind < 0) ||
		  (ind >= dimensions[i]))
		{
		  va_end(ap);
		  return(s7_out_of_range_error(sc, "s7_vector_set_n", i, s7_make_integer(sc, ind), "index should be between 0 and the dimension size"));
		}
	      index += (ind * offsets[i]);
	    }
	  va_end(ap);
	  vector_setter(vector)(sc, vector, index, value);
	  return(value);
	}
    }
  return(s7_wrong_number_of_args_error(sc, "s7_vector_set_n: wrong number of indices: ~A", s7_make_integer(sc, indices)));
}



s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect)
{
  s7_Int i, len;
  s7_pointer p;

  len = vector_length(vect);
  if (len == 0) return(sc->NIL);

  if (len < (sc->free_heap_top - sc->free_heap))
    {
      sc->w = cons(sc, vector_getter(vect)(sc, vect, len - 1), sc->NIL);
      for (i = len - 2; i >= 0; i--)
	sc->w = cons_unchecked(sc, vector_getter(vect)(sc, vect, i), sc->w);
    }
  else
    {
      sc->w = sc->NIL;
      for (i = len - 1; i >= 0; i--)
	sc->w = cons(sc, vector_getter(vect)(sc, vect, i), sc->w);
    }
  p = sc->w;
  sc->w = sc->NIL;
  return(p);
}


static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args)
{
  s7_Int i, start = 0, end;
  s7_pointer p, vec;
  #define H_vector_to_list "(vector->list v start end) returns the elements of the vector v as a list; (map values v)"

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_TO_LIST, args);
      return(simple_wrong_type_argument(sc, sc->VECTOR_TO_LIST, vec, T_VECTOR));
    }

  end = vector_length(vec);
  if (!is_null(cdr(args)))
    {
      start_and_end(sc, sc->VECTOR_TO_LIST, cdr(args), 2, &start, &end);
      if (start == end) return(sc->NIL);
    }
  if ((start == 0) && (end == vector_length(vec)))
    return(s7_vector_to_list(sc, vec));

  sc->w = sc->NIL;
  for (i = end - 1; i >= start; i--)
    sc->w = cons(sc, vector_getter(vec)(sc, vec, i), sc->w);
  p = sc->w;
  sc->w = sc->NIL;
  return(p);
}


s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_Int len, s7_pointer fill)
{
  s7_pointer vect;
  vect = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
  s7_vector_fill(sc, vect, fill);
  return(vect);
}


static s7_pointer g_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_vector "(vector ...) returns a vector whose elements are the arguments"
  s7_Int i, len;
  s7_pointer vec;
  
  len = s7_list_length(sc, args);
  vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
  if (len > 0)
    {
      s7_pointer x;
      for (x = args, i = 0; is_pair(x); x = cdr(x), i++) 
	vector_element(vec, i) =  car(x);
    }
  return(vec);
}


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)"
  
  if (is_null(car(args)))
    return(s7_make_vector(sc, 0));

  if (!is_proper_list(sc, car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->LIST_TO_VECTOR, args);
      return(simple_wrong_type_argument_with_type(sc, sc->LIST_TO_VECTOR, car(args), A_PROPER_LIST));
    }
  return(g_vector(sc, car(args)));
}


static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec;
  #define H_vector_length "(vector-length v) returns the length of vector v"

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_LENGTH, args);
      return(simple_wrong_type_argument(sc, sc->VECTOR_LENGTH, vec, T_VECTOR));
    }
  return(make_integer(sc, vector_length(vec)));
}


static s7_pointer make_shared_vector(s7_scheme *sc, s7_pointer vect, int skip_dims, s7_Int index)
{
  s7_pointer x;
  s7_vdims_t *v;

  /* (let ((v #2d((1 2) (3 4)))) (v 1)) 
   * (let ((v (make-vector '(2 3 4) 0))) (v 1 2))
   * (let ((v #3d(((0 1 2 3) (4 5 6 7) (8 9 10 11)) ((12 13 14 15) (16 17 18 19) (20 21 22 23))))) (v 0 1))
   */

  NEW_CELL(sc, x);
  vector_length(x) = 0;
  vector_elements(x) = NULL;
  set_type(x, type(vect) | T_SAFE_PROCEDURE);
  vector_getter(x) = vector_getter(vect);
  vector_setter(x) = vector_setter(vect);

  v = (s7_vdims_t *)malloc(sizeof(s7_vdims_t));
  v->ndims = vector_ndims(vect) - skip_dims;
  v->dims = (s7_Int *)(vector_dimensions(vect) + skip_dims);
  v->offsets = (s7_Int *)(vector_offsets(vect) + skip_dims);
  v->original = vect;
  v->elements_allocated = false;
  v->dimensions_allocated = false;
  vector_dimension_info(x) = v;

  if (skip_dims > 0)
    vector_length(x) = vector_offset(vect, skip_dims - 1);
  else vector_length(x) = vector_length(vect);

  if (is_int_vector(vect))
    int_vector_elements(x) = (s7_Int *)(int_vector_elements(vect) + index);
  else
    {
      if (is_float_vector(vect))
	float_vector_elements(x) = (s7_Double *)(float_vector_elements(vect) + index);
      else vector_elements(x) = (s7_pointer *)(vector_elements(vect) + index);
    }
  add_vector(sc, x);
  return(x);
}


static s7_pointer g_make_shared_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_shared_vector "(make-shared-vector original-vector new-dimensions) returns \
a vector that points to the same elements as the original-vector but with different dimensional info."

  /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (make-shared-vector v1 '(6)))) v2)) -> #(1 2 3 4 5 6)
   * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (make-shared-vector v1 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6))
   * this is most useful in generic functions -- they can still use (v n) as the accessor.
   *
   * do we want an offset from the origin also?
   */
  s7_pointer orig, dims, y, x;
  s7_vdims_t *v;
  int i;
  s7_Int offset = 1;

  orig = car(args);
  if (!s7_is_vector(orig))
    {
      CHECK_METHOD(sc, orig, sc->MAKE_SHARED_VECTOR, args);
      return(wrong_type_argument(sc, sc->MAKE_SHARED_VECTOR, small_int(1), orig, T_VECTOR));
    }

  dims = cadr(args);
  if (!is_pair(dims))
    return(wrong_type_argument(sc, sc->MAKE_SHARED_VECTOR, small_int(2), dims, T_PAIR));
  
  v = (s7_vdims_t *)malloc(sizeof(s7_vdims_t));
  v->ndims = safe_list_length(sc, dims);
  v->dims = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));
  v->offsets = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));
  v->dimensions_allocated = true;
  v->elements_allocated = false;
  v->original = orig;

  for (i = 0, y = dims; is_pair(y); i++, y = cdr(y))
    v->dims[i] = s7_integer(car(y));

  for (i = v->ndims - 1; i >= 0; i--)
    {
      v->offsets[i] = offset;
      offset *= v->dims[i];
    }

  if (offset > vector_length(orig))
    {
      free(v->dims);
      free(v->offsets);
      free(v);
      return(out_of_range(sc, sc->MAKE_SHARED_VECTOR, small_int(2), dims, "a shared vector has to fit in the original vector"));
    }

  NEW_CELL(sc, x);
  set_type(x, type(orig) | T_SAFE_PROCEDURE);
  vector_dimension_info(x) = v;
  vector_length(x) = offset;                 /* might be less than original length */
  vector_getter(x) = vector_getter(orig);
  vector_setter(x) = vector_setter(orig);
  if (is_int_vector(orig))
    int_vector_elements(x) = int_vector_elements(orig);
  else
    {
      if (is_float_vector(orig))
	float_vector_elements(x) = float_vector_elements(orig);
      else vector_elements(x) = vector_elements(orig);
    }
  add_vector(sc, x);

  return(x);
}


static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices)
{
  s7_Int index = 0;
  if (vector_length(vect) == 0)
    return(out_of_range(sc, sc->VECTOR_REF, small_int(1), vect, "this vector has no elements, so vector-ref is hopeless"));

  if (vector_is_multidimensional(vect))
    {
      unsigned int i;
      s7_pointer x;
      for (x = indices, i = 0; (is_not_null(x)) && (i < vector_ndims(vect)); x = cdr(x), i++)
	{
	  s7_Int n;
	  if (!s7_is_integer(car(x)))
	    return(wrong_type_argument_n(sc, sc->VECTOR_REF, i + 2, car(x), T_INTEGER));

	  n = s7_integer(car(x));
	  if ((n < 0) || 
	      (n >= vector_dimension(vect, i)))
	    return(out_of_range(sc, sc->VECTOR_REF, make_integer(sc, i + 2), car(x), "index should be between 0 and the dimension size"));

	  index += n * vector_offset(vect, i);
	}
      if (is_not_null(x))
	return(implicit_index(sc, vector_element(vect, index), x));

      /* if not enough indices, return a shared vector covering whatever is left */
      if (i < vector_ndims(vect))
	return(make_shared_vector(sc, vect, i, index));
    }
  else 
    {
      /* (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(car(indices)))
	return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), car(indices), T_INTEGER));

      index = s7_integer(car(indices));
      if ((index < 0) ||
	  (index >= vector_length(vect)))
	return(out_of_range(sc, sc->VECTOR_REF, small_int(2), car(indices), "should be between 0 and the vector length"));
      
      if (is_not_null(cdr(indices)))                /* (let ((L '#(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */
	return(implicit_index(sc, vector_element(vect, index), cdr(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.  If v \
is a multidimensional vector, you can also use (vector-ref v ...) where the trailing args \
are the indices, or omit 'vector-ref': (v ...)."

  s7_pointer vec;

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_REF, args);
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec, T_VECTOR));
    }

  return(vector_ref_1(sc, vec, cdr(args)));
}


static s7_pointer vector_ref_ic;
static s7_pointer g_vector_ref_ic(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec;
  s7_Int index;

  vec = finder(sc, car(args));
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_REF, args);
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec, T_VECTOR));
    }

  index = s7_integer(cadr(args));
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), "should be less than vector length"));

  if (vector_is_multidimensional(vec))
    return(make_shared_vector(sc, vec, 1, index));

  return(vector_getter(vec)(sc,vec, index));
}

static s7_pointer vector_ref_gs;
static s7_pointer g_vector_ref_gs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, vec;
  s7_Int index;

  vec = SYMBOL_TO_VALUE(sc, car(args));
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_REF, args);
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec, T_VECTOR));
    }

  x = finder(sc, cadr(args));
  if (!s7_is_integer(x))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), x, T_INTEGER));
  index = s7_integer(x);
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), "should be between 0 and the vector length"));

  if (vector_is_multidimensional(vec))
    return(make_shared_vector(sc, vec, 1, index));

  return(vector_getter(vec)(sc, vec, index));
}

/* this is marginal */
static s7_pointer vector_ref_ggs;
static s7_pointer g_vector_ref_ggs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, vec1, vec2;
  s7_Int index;

  vec1 = SYMBOL_TO_VALUE(sc, car(args));
  if (!s7_is_vector(vec1))
    {
      CHECK_METHOD(sc, vec1, sc->VECTOR_REF, args);
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec1, T_VECTOR));
    }

  vec2 = SYMBOL_TO_VALUE(sc, cadr(cadr(args)));
  if (!s7_is_vector(vec2))
    {
      CHECK_METHOD(sc, vec2, sc->VECTOR_REF, args);
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec2, T_VECTOR));
    }

  if (vector_is_multidimensional(vec2))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec2, T_VECTOR));

  x = finder(sc, caddr(cadr(args)));
  if (!s7_is_integer(x))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), x, T_INTEGER));
  index = s7_integer(x);
  if ((index < 0) ||
      (index >= vector_length(vec2)))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), "should be between 0 and the vector length"));

  x = vector_getter(vec2)(sc, vec2, index);
  if (!s7_is_integer(x))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), x, T_INTEGER));
  index = s7_integer(x);
  if ((index < 0) ||
      (index >= vector_length(vec1)))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), "should be between 0 and the vector length"));

  if (vector_is_multidimensional(vec1))
    return(make_shared_vector(sc, vec1, 1, index));

  return(vector_getter(vec1)(sc, vec1, index));
}

static s7_pointer vector_ref_add1;
static s7_pointer g_vector_ref_add1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, x, func = sc->UNDEFINED;
  s7_Int index;

  vec = finder(sc, car(args));
  if (!s7_is_vector(vec))
    {
      if ((!has_methods(vec)) ||
	  ((func = find_method(sc, find_environment(sc, vec), sc->VECTOR_REF)) == sc->UNDEFINED))
	return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec, T_VECTOR));
    }
  x = finder(sc, cadr(cadr(args)));
  if (!s7_is_integer(x))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), x, T_INTEGER));

  index = s7_integer(x) + 1;
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), cadr(args), "should be between 0 and the vector length"));

  if (vector_is_multidimensional(vec))
    return(make_shared_vector(sc, vec, 1, index));

  if (func != sc->UNDEFINED)
    return(s7_apply_function(sc, func, list_2(sc, vec, s7_make_integer(sc, index))));
  return(vector_getter(vec)(sc, vec, index));
}

static s7_pointer vector_ref_2;
static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, ind;
  s7_Int index;

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_REF, args); /* should be ok because we go to g_vector_ref below */
      return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), vec, T_VECTOR));
    }
  if (vector_is_multidimensional(vec))
    return(g_vector_ref(sc, args));
  
  ind = cadr(args);
  if (!s7_is_integer(ind))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), ind, T_INTEGER));
  index = s7_integer(ind);
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), ind, "should be between 0 and the vector length"));

  return(vector_getter(vec)(sc, vec, index));
}


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.  If 'v' is \
multidimensional you can also use (vector-set! v ... val) where the ellipsis refers to the indices.  You \
can also use 'set!' instead of 'vector-set!': (set! (v ...) val) -- I find this form much easier to read."

  s7_pointer vec, val;
  s7_Int index;

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_SET, args);
      return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(1), vec, T_VECTOR));
    }
  if (vector_length(vec) == 0)
    return(out_of_range(sc, sc->VECTOR_SET, small_int(1), vec, "this vector has no elements, so vector-set! is hopeless"));
  
  if (vector_is_multidimensional(vec))
    {
      unsigned int i;
      s7_pointer x;
      index = 0;
      for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++)
	{
	  s7_Int n;
	  if (!s7_is_integer(car(x)))
	    return(wrong_type_argument_n(sc, sc->VECTOR_SET, i + 2, car(x), T_INTEGER));

	  n = s7_integer(car(x));
	  if ((n < 0) || 
	      (n >= vector_dimension(vec, i)))
	    return(out_of_range(sc, sc->VECTOR_SET, make_integer(sc, i + 2), car(x), "index should be between 0 and the dimension size"));

	  index += n * vector_offset(vec, i);
	}

      if (is_not_null(cdr(x)))
	return(s7_wrong_number_of_args_error(sc, "too many args for vector-set!: ~S", args));
      if (i != vector_ndims(vec))
	return(s7_wrong_number_of_args_error(sc, "not enough args for vector-set!: ~S", args));

      val = car(x);
    }
  else
    {
      if (!s7_is_integer(cadr(args)))
	return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(2), cadr(args), T_INTEGER));

      index = s7_integer(cadr(args));
      if ((index < 0) ||
	  (index >= vector_length(vec)))
	return(out_of_range(sc, sc->VECTOR_SET, small_int(2), cadr(args), "should be between 0 and the vector length"));

      if (is_not_null(cdddr(args)))
	{
	  car(sc->temp_cell_4) = vector_getter(vec)(sc, vec, index);
	  cdr(sc->temp_cell_4) = cddr(args);
	  return(g_vector_set(sc, sc->temp_cell_4));
	}
      val = caddr(args);
    }
  
  vector_setter(vec)(sc, vec, index, val);
  return(val);
}


static s7_pointer vector_set_ic;
static s7_pointer g_vector_set_ic(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, val;
  s7_Int index;

  vec = finder(sc, car(args));
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_SET, list_3(sc, vec, cadr(args), finder(sc, caddr(args)))); /* the list_3 happens only if we find the method */
      return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(1), vec, T_VECTOR));
    }
  if (vector_is_multidimensional(vec))
    return(g_vector_set(sc, list_3(sc, vec, cadr(args), finder(sc, caddr(args)))));

  index = s7_integer(cadr(args));
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_SET, small_int(2), cadr(args), "should be less than vector length"));

  val = finder(sc, caddr(args));
  vector_setter(vec)(sc, vec, index, val);
  return(val);
}

static s7_pointer vector_set_vref;
static s7_pointer g_vector_set_vref(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, val;
  s7_Int index1, index2;

  vec = finder(sc, car(args));
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_SET, list_3(sc, vec, cadr(args), finder(sc, caddr(args)))); /* the list_3 happens only if we find the method */
      return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(1), vec, T_VECTOR));
    }
  if (vector_is_multidimensional(vec))
    return(g_vector_set(sc, list_3(sc, vec, cadr(args), finder(sc, caddr(args)))));

  val = finder(sc, cadr(args));
  if (!s7_is_integer(val))
    return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(2), val, T_INTEGER));
  index1 = s7_integer(val);
  if (index1 >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_SET, small_int(2), val, "should be less than vector length"));

  val = finder(sc, caddr(caddr(args)));
  if (!s7_is_integer(val))
    return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(2), val, T_INTEGER));
  index2 = s7_integer(val);
  if (index2 >= vector_length(vec))
    return(out_of_range(sc, sc->VECTOR_REF, small_int(2), val, "should be less than vector length"));

  vector_setter(vec)(sc, vec, index1, vector_getter(vec)(sc, vec, index2));
  return(val);
}

static s7_pointer vector_set_3;
static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, ind, val;
  s7_Int index;

  vec = car(args);
  if (!s7_is_vector(vec))
    {
      CHECK_METHOD(sc, vec, sc->VECTOR_SET, args);
      return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(1), vec, T_VECTOR));
    }
  if (vector_is_multidimensional(vec))
    return(g_vector_set(sc, args));
  
  ind = cadr(args);
  if (!s7_is_integer(ind))
    return(wrong_type_argument(sc, sc->VECTOR_SET, small_int(2), ind, T_INTEGER));
  index = s7_integer(ind);
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->VECTOR_SET, small_int(2), ind, "should be between 0 and the vector length"));

  val = caddr(args);
  vector_setter(vec)(sc, vec, index, val);
  return(val);
}

static s7_pointer vector_set_ssc;
static s7_pointer g_vector_set_ssc(s7_scheme *sc, s7_pointer args)
{
  /* this is just a placeholder */
  return(g_vector_set(sc, list_3(sc, finder(sc, car(args)), finder(sc, cadr(args)), caddr(args))));
}


static s7_pointer vector_set_ssc_looped;
static s7_pointer g_vector_set_ssc_looped(s7_scheme *sc, s7_pointer args)
{
  s7_pointer vec, ind, val;
  s7_Int pos, end;
  s7_pointer stepper;

  /* incoming args: (0 vect i #f) */
  vec = finder(sc, cadr(args));
  if ((!s7_is_vector(vec)) ||
      (vector_is_multidimensional(vec)))
    return(NULL);

  stepper = car(args);
  ind = s7_slot(sc, caddr(args));
  if (slot_value(ind) != stepper)
    return(NULL);

  pos = numerator(stepper);
  end = denominator(stepper);
  if ((pos < 0) ||
      (end > vector_length(vec)))
    return(out_of_range(sc, sc->VECTOR_SET, small_int(2), ind, "should be less than the vector length"));

  val = cadddr(args);
  if (is_int_vector(vec))
    {
      s7_Int k;
      k = s7_number_to_integer(sc, val);
      for (; pos < end; pos++)
	int_vector_element(vec, pos) = k;
    }
  else
    {
      if (is_float_vector(vec))
	{
	  s7_Double x;
	  x = s7_number_to_real(sc, val);
	  for (; pos < end; pos++)
	    float_vector_element(vec, pos) = x;
	}
      else
	{
	  for (; pos < end; pos++)
	    vector_element(vec, pos) = val;
	}
    }
  numerator(stepper) = end;

  return(val);
}


/* other standard cases (fft-related): (+|- (vector-ref ...) s) -- actually (vector-set! v i (+|- (vector-ref v i) s))
 *                                     (+|- (* s (vector-ref ...)) (* s (vector-ref ...)))
 * (vset v i s)
 * (vset v (+ i 1) (vref v (+ j 1)))
 * (vset v (+ i 1) s)
 */



#define MAX_VECTOR_DIMENSIONS 512

static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_vector "(make-vector len (value #f) (homogenous #f)) 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.  If homogenous is #t, and value is either an integer \
or a real, the vector can only hold numbers of that type (s7_Int or s7_Double)."

  s7_Int len;
  s7_pointer x, fill, vec;
  int result_type = T_VECTOR;

  fill = sc->UNSPECIFIED;

  x = car(args);
  if (s7_is_integer(x))
    {
      len = s7_integer(x);
      if (len < 0)
	return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(1), x, A_NON_NEGATIVE_INTEGER));
    }
  else
    {
      s7_pointer y;
      if (!(is_pair(x)))
	{
	  CHECK_METHOD(sc, x, sc->MAKE_VECTOR, args);
	  return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(1), x, 
					       make_protected_string(sc, "an integer or a list of integers")));
	}
      if (!s7_is_integer(car(x)))
	return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(1), car(x), 
					     make_protected_string(sc, "each dimension should be an integer")));
      if (is_null(cdr(x)))
	len = s7_integer(car(x));
      else
	{
	  int dims;

	  dims = s7_list_length(sc, x);
	  if (dims <= 0)                /* 0 if circular, negative if dotted */
	    return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(1), x, A_PROPER_LIST));
	  if (dims > MAX_VECTOR_DIMENSIONS)
	    return(out_of_range(sc, sc->MAKE_VECTOR, small_int(1), x, "less than 512 dimensions"));

	  for (len = 1, y = x; is_not_null(y); y = cdr(y))
	    {
	      if (!s7_is_integer(car(y)))
		return(wrong_type_argument_n(sc, sc->MAKE_VECTOR, position_of(y, x), car(y), T_INTEGER));
	      len *= s7_integer(car(y));
	      if (len < 0)
		return(wrong_type_argument_n_with_type(sc, sc->MAKE_VECTOR, position_of(y, x), car(y), A_NON_NEGATIVE_INTEGER));
	    }
	}
    }

  if (is_not_null(cdr(args)))
    {
      fill = cadr(args);
      if (is_not_null(cddr(args)))
	{
	  if (caddr(args) == sc->T)
	    {
	      if (s7_is_integer(fill))
		result_type = T_INT_VECTOR;
	      else
		{
		  if (s7_is_real(fill))
		    result_type = T_FLOAT_VECTOR;
		  else return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(2), fill,
							    make_protected_string(sc, "an integer or a real since 'homogenous' is #t")));
		}
	    }
	  else 
	    {
	      if (caddr(args) != sc->F)
		return(wrong_type_argument_with_type(sc, sc->MAKE_VECTOR, small_int(3), caddr(args), make_protected_string(sc, "a boolean")));
	    }
	}
    }

  vec = make_vector_1(sc, len, NOT_FILLED, result_type);
  if (len > 0) s7_vector_fill(sc, vec, fill);

  if ((is_pair(x)) &&
      (is_pair(cdr(x))))
    {
      int i;
      s7_Int offset = 1;
      s7_pointer y;
      s7_vdims_t *v;

      v = (s7_vdims_t *)malloc(sizeof(s7_vdims_t));
      v->ndims = safe_list_length(sc, x);
      v->dims = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));
      v->offsets = (s7_Int *)malloc(v->ndims * sizeof(s7_Int));
      v->original = sc->F;
      v->dimensions_allocated = true;
      v->elements_allocated = (len > 0);

      for (i = 0, y = x; is_not_null(y); i++, y = cdr(y))
	v->dims[i] = s7_integer(car(y));

      for (i = v->ndims - 1; i >= 0; i--)
	{
	  v->offsets[i] = offset;
	  offset *= v->dims[i];
	}
      vector_dimension_info(vec) = v;
    }

  return(vec);
}


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"
  CHECK_BOOLEAN_METHOD(sc, car(args), s7_is_vector, sc->VECTORP, args);
}


int s7_vector_rank(s7_pointer vect)
{
  return(vector_rank(vect));
}


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.  In srfi-63 terms:\n\
    (define array-dimensions vector-dimensions)\n\
    (define (array-rank v) (length (vector-dimensions v)))"

  s7_pointer x;

  x = car(args);
  if (!s7_is_vector(x))
    {
      CHECK_METHOD(sc, x, sc->VECTOR_DIMENSIONS, args);
      return(simple_wrong_type_argument(sc, sc->VECTOR_DIMENSIONS, x, T_VECTOR));
    }

  if (vector_is_multidimensional(x))
    {
      int i;
      sc->w = sc->NIL;
      for (i = vector_ndims(x) - 1; i >= 0; i--)
	sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w);
      x = sc->w;
      sc->w = sc->NIL;
      return(x);
    }
  
  return(list_1(sc, make_integer(sc, vector_length(x))));
}


#define MV_TOO_MANY_ELEMENTS -1
#define MV_NOT_ENOUGH_ELEMENTS -2

static int traverse_vector_data(s7_scheme *sc, s7_pointer vec, int flat_ref, int dimension, int dimensions, int *sizes, s7_pointer lst)
{
  /* we're filling vec, we're currently looking for element (flat-wise) 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)))
   */
  int i;
  s7_pointer x;

  for (i = 0, x = lst; i < sizes[dimension]; i++, x = cdr(x))
    {
      if (!is_pair(x))
	return(MV_NOT_ENOUGH_ELEMENTS);

      if (dimension == (dimensions - 1))
	vector_setter(vec)(sc, vec, flat_ref++, car(x));
      else 
	{
	  flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x));
	  if (flat_ref < 0) return(flat_ref);
	}
    }

  if (is_not_null(x))
    return(MV_TOO_MANY_ELEMENTS);
  return(flat_ref);
}


static s7_pointer s7_multivector_error(s7_scheme *sc, const char *message, s7_pointer data)
{
  return(s7_error(sc, sc->READ_ERROR,
		  list_3(sc, 
			 make_protected_string(sc, "reading constant vector, ~A: ~A"),
			 make_protected_string(sc, message),
			 data)));
}


static s7_pointer g_multivector(s7_scheme *sc, s7_Int dims, s7_pointer data)
{
  /* get the dimension bounds from data, make the new vector, fill it from data 
   *
   * dims needs to be s7_Int so we can at least give correct error messages.
   * also should we let an empty vector have any number of dimensions? currently ndims is an int.
   */
  s7_pointer vec, x;
  int i, vec_loc, err;
  int *sizes;
  
  /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1
   * (#2d((1 2 3) (4 5 6)) 0 1) -> 2
   * (#2d((1 2 3) (4 5 6)) 1 1) -> 5
   * (#3D(((1 2) (3 4)) ((5 6) (7 8))) 0 0 0) -> 1
   * (#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 int this is negative] */
    return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, make_integer(sc, dims), "must be 1 or more"));

  sc->w = sc->NIL;
  if (is_null(data))  /* dims are already 0 (calloc above) */
    return(g_make_vector(sc, list_1(sc, make_list(sc, dims, small_int(0)))));

  sizes = (int *)calloc(dims, sizeof(int));
  for (x = data, i = 0; i < dims; i++)
    {
      sizes[i] = safe_list_length(sc, x);
      sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w);
      x = car(x);
      if ((i < (dims - 1)) && 
	  (!is_pair(x)))
	{
	  free(sizes);
	  return(s7_multivector_error(sc, "we need a list that fully specifies the vector's elements", data));
	}
    }

  vec = g_make_vector(sc, list_1(sc, safe_reverse_in_place(sc, sc->w)));
  vec_loc = s7_gc_protect(sc, vec);
  sc->w = sc->NIL;

  /* 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) 
    return(s7_multivector_error(sc, (err == MV_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data));

  return(vec);
}


static s7_pointer g_qq_multivector(s7_scheme *sc, s7_pointer args)
{
  /* `#2d((1 2) ,(list 3 4)) */
  #define H_qq_multivector "quasiquote internal support for multidimensional vector constants"
  return(g_multivector(sc, s7_integer(car(args)), cdr(args)));
}


s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect)
{
  s7_Int len;
  s7_pointer new_vect;

  len = vector_length(old_vect);
  if (is_int_vector(old_vect))
    {
      if (vector_is_multidimensional(old_vect))
	new_vect = g_make_vector(sc, list_3(sc, g_vector_dimensions(sc, list_1(sc, old_vect)), small_int(0), sc->T));
      else new_vect = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
      memcpy((void *)(int_vector_elements(new_vect)), (void *)(int_vector_elements(old_vect)), len * sizeof(s7_Int));
    }
  else
    {
      if (is_float_vector(old_vect))
	{
	  if (vector_is_multidimensional(old_vect))
	    new_vect = g_make_vector(sc, list_3(sc, g_vector_dimensions(sc, list_1(sc, old_vect)), real_zero, sc->T));
	  else new_vect = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR);
	  memcpy((void *)(float_vector_elements(new_vect)), (void *)(float_vector_elements(old_vect)), len * sizeof(s7_Double));
	}
      else
	{
	  if (vector_is_multidimensional(old_vect))
	    new_vect = g_make_vector(sc, list_1(sc, g_vector_dimensions(sc, list_1(sc, old_vect))));
	  else new_vect = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);

	  /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_list also) */
	  memcpy((void *)(vector_elements(new_vect)), (void *)(vector_elements(old_vect)), len * sizeof(s7_pointer));
	}
    }
  return(new_vect);
}





/* -------- sort! -------- */

#if WITH_GCC

#define c_function_is_ok(Sc, X) \
  ({ s7_pointer _X_;  _X_ = X;						\
    ((ecdr(_X_)) &&							\
     ({s7_pointer _p_; _p_ = SYMBOL_TO_VALUE(Sc, car(_X_));		\
       ((_p_ == ecdr(_X_)) ||						\
	((is_c_function(_p_)) && (is_c_function(ecdr(_X_))) &&		\
	 (c_function_class(_p_) == c_function_class(ecdr(_X_))))); })); })
#else

static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) 
{
  if (ecdr(x))
    {
      s7_pointer p;
      p = SYMBOL_TO_VALUE(sc, car(x));
      return((p == ecdr(x)) ||
	     ((is_c_function(p)) &&
	      (c_function_class(p) == c_function_class(ecdr(x)))));
    }
  return(false);
}
#endif


static bool arglist_has_accessed_symbol(s7_pointer args)
{
  /* rest arg if any not checked */
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    if (((is_symbol(car(p))) && (symbol_has_accessor(car(p)))) ||
	((is_pair(car(p))) && (symbol_has_accessor(caar(p)))))
      return(true);
  return(false);
}


static bool arglist_has_keyword(s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    if (is_keyword(car(p)))
      return(true);
  return(false);
}


static s7_function end_dox_eval(s7_scheme *sc, s7_pointer code);
static s7_pointer end_dox_or_not_ic(s7_scheme *sc, s7_pointer code);
static s7_pointer end_dox_or_not_ss(s7_scheme *sc, s7_pointer code);

static void initialize_dox_end_vars(s7_scheme *sc, s7_pointer end)
{
  switch (optimize_data(end))
    {
    case HOP_SAFE_C_C:
      break;
      
    case HOP_SAFE_C_S:
    case HOP_SAFE_C_SC:
    case HOP_SAFE_C_S_opCq:
      environment_dox1(sc->envir) = find_symbol(sc, cadr(end));
      break;
      
    case HOP_SAFE_C_CS:
    case HOP_SAFE_C_QS:
      environment_dox1(sc->envir) = find_symbol(sc, caddr(end));
      break;
      
    case HOP_SAFE_C_SS:
      environment_dox1(sc->envir) = find_symbol(sc, cadr(end));
      environment_dox2(sc->envir) = find_symbol(sc, caddr(end));
      break;
      
    case HOP_SAFE_C_opSq_S:
      environment_dox1(sc->envir) = find_symbol(sc, cadr(cadr(end)));
      environment_dox2(sc->envir) = find_symbol(sc, caddr(end));
      break;
      
    case HOP_SAFE_C_S_opSq:
    case HOP_SAFE_C_S_opSCq:
    case HOP_SAFE_C_S_opSSq:
      environment_dox1(sc->envir) = find_symbol(sc, cadr(end));
      environment_dox2(sc->envir) = find_symbol(sc, ecdr(cdr(end)));
      break;

    case HOP_SAFE_C_opSq_opSq:
      environment_dox1(sc->envir) = find_symbol(sc, cadr(cadr(end)));
      environment_dox2(sc->envir) = find_symbol(sc, cadr(caddr(end)));
      break;
    }
}


static s7_scheme *compare_sc;
static s7_function compare_func;
static s7_pointer compare_args;

static int vector_compare(const void *v1, const void *v2)
{
  car(compare_args) = (*(s7_pointer *)v1);
  cadr(compare_args) = (*(s7_pointer *)v2);
  if (is_true(compare_sc, (*(compare_func))(compare_sc, compare_args)))
    return(-1);
  return(1);
}

static int dox_compare(const void *v1, const void *v2)
{
  /* here v1 and v2 are the lambda args.  We need to place these in the current env slots,
   *   then call compare_func with the expression as its argument. So compare_args in this
   *   case is expr.
   */
  slot_set_value(environment_slots(compare_sc->envir), (*(s7_pointer *)v1));
  slot_set_value(next_slot(environment_slots(compare_sc->envir)), (*(s7_pointer *)v2));
  if (is_true(compare_sc, (*(compare_func))(compare_sc, compare_args)))
    return(-1);
  return(1);
}


static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
{
  #define H_sort "(sort! list-or-vector less?) sorts a list or vector using the function 'less?' to compare elements.\
If its first argument is a list, the list is copied (despite the '!')."

  s7_pointer data, lessp;
  s7_Int len = 0, n, k;
  int (*sort_func)(const void *v1, const void *v2);

  sort_func = vector_compare;
  data = car(args);
  if (is_null(data)) 
    {
      /* (apply sort! () #f) should be an error I think 
       */
      lessp = cadr(args);
      if ((!is_procedure(lessp)) ||
	  (!s7_is_aritable(sc, lessp, 2)))
	return(wrong_type_argument_with_type(sc, sc->SORT, small_int(2), lessp, 
					     make_protected_string(sc, "a function of 2 arguments")));
      return(sc->NIL);
    }

  if ((!is_pair(data)) && 
      (!s7_is_vector(data)) &&
      (!has_methods(data)))
    {
      CHECK_METHOD(sc, data, sc->SORT, args);
      return(wrong_type_argument_with_type(sc, sc->SORT, small_int(1), data, 
					   make_protected_string(sc, "a vector or a list")));
    }

  lessp = cadr(args);
  if (!is_procedure(lessp))
    return(wrong_type_argument_with_type(sc, sc->SORT, small_int(2), lessp, A_CLOSURE));
  if ((is_continuation(lessp)) || is_goto(lessp))
    return(wrong_type_argument_with_type(sc, sc->SORT, small_int(2), lessp, 
					 make_protected_string(sc, "a normal procedure (not a continuation)")));
  if (!s7_is_aritable(sc, lessp, 2))
    return(wrong_type_argument_with_type(sc, sc->SORT, small_int(2), lessp, 
					 make_protected_string(sc, "a procedure that can take 2 arguments")));

  compare_func = NULL;
  compare_args = sc->T2_1;
  compare_sc = sc;

  /* (define (hi a) (sort! a (lambda (x y) (< x y))))
   */
  if ((is_safe_procedure(lessp)) &&
      (is_c_function(lessp)))
    compare_func = c_function_call(lessp);
  else
    {
      /* an experiment. other similar cases are assoc/member (and for-each/map but they never happen in this context -- see op_for_each_ls_2 below)
       */
      if ((is_closure(lessp)) &&
	  (is_null(cdr(closure_body(lessp)))) &&
	  (is_optimized(car(closure_body(lessp)))))
	{
	  /* 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.
	   *   So, treat it as if it were a dox end expression, creating a frame and using dox1|2 for
	   *   any symbols. This way we can handle slightly tricky cases like (lambda (a b) (< (car b) a))
	   *   without any extra work up front.  compare_func needs to be a dox-like-version of c_call(expr)
	   *   where the 2 args are placed in dox1|2 before calling the actual function.
	   */
	  s7_pointer expr, args;
	  s7_function sort_f;
	  expr = car(closure_body(lessp));
	  args = closure_args(lessp);

	  if ((is_pair(args)) &&
	      (!arglist_has_accessed_symbol(args)) &&
	      (((optimize_data(expr) & 1) != 0) ||
	       (c_function_is_ok(sc, expr))))
	    {
	      int orig_data;
	      orig_data = optimize_data(expr);
	      optimize_data(expr) |= 1;
	      sort_f = end_dox_eval(sc, expr);
	      if (sort_f)
		{
		  NEW_FRAME_WITH_TWO_SLOTS(sc, closure_environment(lessp), sc->envir, car(args), sc->F, cadr(args), sc->F);
		  initialize_dox_end_vars(sc, expr);
		  compare_func = sort_f;
		  sort_func = dox_compare;
		  compare_args = expr;
		}
	      optimize_data(expr) = orig_data;
	    }
	}
    }

  switch (type(data))
    {
    case T_PAIR:
      len = s7_list_length(sc, data);            /* nil disposed of above, so 0 here == infinite */
      if (len <= 0)
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "sort! argument 1 should be a proper list: ~S"), data)));
      if (len < 2) return(data);
      if (len == 2)
	{
	  push_stack(sc, OP_SORT_TWO, data, args);  /* this will return a list -- was sc->args  */
	  push_stack(sc, OP_APPLY, data, lessp);
	  return(sc->F);
	}

      if (compare_func)
	{
	  int gc_loc;
	  s7_pointer vec;
	  vec = g_vector(sc, data);
	  gc_loc = s7_gc_protect(sc, vec);
	  qsort((void *)s7_vector_elements(vec), len, sizeof(s7_pointer), sort_func);
	  vec = s7_vector_to_list(sc, vec);
	  s7_gc_unprotect_at(sc, gc_loc);
	  return(vec);
	}

      push_stack(sc, OP_SORT4, args, sc->code);    /* gc protect the original list, OP_SORT4 calls s7_vector_to_list, was sc->args */
      car(args) = g_vector(sc, data);
      break;

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
      len = vector_length(data);
      if (compare_func)
	{
	  int i, gc_loc;
	  s7_pointer vec;
	  vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
	  gc_loc = s7_gc_protect(sc, vec);	  
	  for (i = 0; i < len; i++)
	    vector_element(vec, i) = vector_getter(data)(sc, data, i);
	  qsort((void *)s7_vector_elements(vec), len, sizeof(s7_pointer), sort_func);
	  s7_gc_unprotect_at(sc, gc_loc);
	  return(vec);
	}
      break;

    case T_VECTOR:
      len = vector_length(data);
      if (compare_func)
	{
	  qsort((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func);
	  return(data);
	}
      break;

    default:
      CHECK_METHOD(sc, data, sc->SORT, args);
      return(wrong_type_argument_with_type(sc, sc->SORT, small_int(1), data, make_protected_string(sc, "a vector or a list")));
    }

  if (len < 2) return(data);
  n = len - 1;
  k = ((int)(n / 2)) + 1;

  sc->x = s7_make_vector(sc, (sc->safety == 0) ? 4 : 6); 
  vector_element(sc->x, 0) = make_mutable_integer(sc, n);
  vector_element(sc->x, 1) = make_mutable_integer(sc, k);
  vector_element(sc->x, 2) = make_mutable_integer(sc, 0);
  vector_element(sc->x, 3) = make_mutable_integer(sc, 0);
  if (sc->safety != 0)
    {
      vector_element(sc->x, 4) = make_mutable_integer(sc, 0);
      vector_element(sc->x, 5) = make_integer(sc, n * n);
    }

  push_stack(sc, OP_SORT, args, sc->x);
  sc->x = sc->NIL;
  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.
   */
}




/* -------- hash tables -------- */

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"
  CHECK_BOOLEAN_METHOD(sc, car(args), is_hash_table, sc->HASH_TABLEP, args);
}


static s7_pointer g_hash_table_size(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_size "(hash-table-size obj) returns the size of the hash-table obj"
  if (!is_hash_table(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->HASH_TABLE_SIZE, args);
      return(simple_wrong_type_argument(sc, sc->HASH_TABLE_SIZE, car(args), T_HASH_TABLE));
    }
  return(make_integer(sc, hash_table_length(car(args))));
}


static int hash_float_location(s7_Double x)
{
  if ((is_inf(x)) || (is_NaN(x)))
    return(0);

  if (x < 0.0)
    return(0.5 - x);
  return(x + 0.5);
}


static int hash_loc(s7_scheme *sc, s7_pointer key)
{
  int loc = 0;
  const char *c; 

  switch (type(key))
    {
    case T_STRING:
      if (string_hash(key) != 0)
	return(string_hash(key));
      for (c = string_value(key); *c; c++)
	loc = *c + loc * HASH_MULT;
      string_hash(key) = loc;
      return(loc);

    case T_INTEGER:
      loc = (int)integer(key); /* overflow possible! */
      if (loc < 0) return(-loc);
      return(loc);

    case T_REAL:
      return(hash_float_location(real(key)));
      /* currently 1e300 goes to most-negative-fixnum! -> 0 after logand size, I hope 
       *
       * we need round, not floor for the location calculation in the real/complex cases else
       *    1-eps doesn't match 1.0, but 1+eps does.  And what if round(val) is too big for int?
       *    lrint is complex and requires special compiler flags to get any speed (-fno-math-errno).
       *    all we need is (int)(val+0.5) -- all the other stuff is pointless in this context
       */

    case T_RATIO:
      return(denominator(key)); /* overflow possible */

    case T_COMPLEX:
      return(hash_float_location(real_part(key)));

    case T_SYMBOL:
      return(symbol_hash(key));

    case T_SYNTAX:
      return(symbol_hash(slot_symbol(global_slot(key))));

    case T_CHARACTER:
      return(character(key));

    case T_HASH_TABLE:
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(vector_length(key));

    case T_PAIR:
      loc = (int)s7_list_length(sc, key);
      if (loc > 0)
	return(loc + hash_loc(sc, car(key)));
      return(0);

    default:
      break;
    }

  return(type(key));
}


static s7_pointer g_hash_table_index(s7_scheme *sc, s7_pointer args)
{
  return(make_integer(sc, hash_loc(sc, car(args))));
}


static s7_pointer hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(sc->NIL);
}


static s7_pointer hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (s7_is_integer(key))
    {
      s7_Int keyval;
      s7_pointer x;
      unsigned int hash_len, loc;

      hash_len = (int)hash_table_length(table) - 1;
      keyval = integer(key);
      if (keyval < 0)
	loc = (-keyval) & hash_len;
      else loc = keyval & hash_len;

      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if (integer(fcdr(x)) == keyval)
	  return(car(x));
    }
  return(sc->NIL);
}


static s7_pointer hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* cityhash and spookyhash are the top-of-the-line, but do we need that much power? 
   */
  if (is_string(key))
    {
      s7_pointer x;
      unsigned int hash_len, loc, orig;

      hash_len = (unsigned int)hash_table_length(table) - 1;
      loc = string_hash(key);
      if (loc == 0)
	{
	  const char *c; 
	  for (c = string_value(key); *c; c++) 
	    loc = *c + loc * HASH_MULT;
	  string_hash(key) = loc;
	}
      orig = loc;
      loc &= hash_len;
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if ((orig == string_hash(fcdr(x))) &&
	    (strings_are_equal(string_value(fcdr(x)), string_value(key))))
	  return(car(x));
    }
  return(sc->NIL);
}


static s7_pointer hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (s7_is_character(key))
    {
      s7_pointer x;
      int hash_len, loc;
      hash_len = (int)hash_table_length(table) - 1;
      loc = character(key) & hash_len;
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if (fcdr(x) == key)
	  return(car(x));
    }
  return(sc->NIL);
}


#define HASH_FLOAT_EPSILON 1.0e-12

static s7_pointer hash_float_1(s7_scheme *sc, s7_pointer table, int loc, s7_Double keyval)
{
  s7_pointer x;
  bool look_for_nan;
  look_for_nan = is_NaN(keyval);
  
  for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
    {
      s7_pointer y;
      y = fcdr(x);
      if (type(y) == T_REAL) /* we're possibly called from hash_equal, so keys might not be T_REAL */
	{
	  s7_Double val;
	  val = real(y);
	  if (look_for_nan)
	    {
	      if (is_NaN(val))
		return(car(x));
	    }
	  else
	    {
	      if ((val == keyval) ||   /* inf case */
		  (fabs(val - keyval) < HASH_FLOAT_EPSILON))
		return(car(x));
	    }
	}
    }
  return(sc->NIL);
}


static s7_pointer hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* give the equality check some room.  We only get here if key is T_REAL.
   *   also inf == inf and nan == nan
   */
  s7_Double keyval;
  int hash_len, loc;

  hash_len = (int)hash_table_length(table) - 1;
  keyval = real(key);
  loc = hash_float_location(keyval) & hash_len;

  return(hash_float_1(sc, table, loc, keyval));
}


static s7_pointer hash_complex_1(s7_scheme *sc, s7_pointer table, int loc, s7_pointer key)
{
  s7_pointer x;
  for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
    {
      s7_pointer y;
      y = fcdr(x);
      if ((type(y) == T_COMPLEX) &&
	  (s7_is_morally_equal_1(sc, y, key, NULL)))
	return(car(x));
    }
  return(sc->NIL);
}


static s7_pointer hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* there is a problem here if we hash mixed numeric types and floats are compared using float-epsilon.
   *   to remain consistent even in mixed cases, we need to trap the floats here before s7_is_equal.
   *   complex numbers are similar.
   *
   * morally-equal? can't be used here unless we use it even in hash_int and other such cases.
   *   otherwise, what matches depends on what else is in the hash, and on the order in which 
   *   they were placed there.  But I think the key 1 should not match the key 1.0+epsilon,
   *   and similarly for ratios, yet NaN should definitely match NaN (else it's a nutty no-op
   *   to use such a key). 
   *
   * yet another problem: hashing a closure can't work.  A closure is not necessarily equal to itself.
   */
  s7_pointer x;
  unsigned int hash_len, loc;

  hash_len = (int)hash_table_length(table) - 1;
  loc = hash_loc(sc, key) & hash_len;

  switch (type(key))
    {
    case T_REAL:
      return(hash_float_1(sc, table, loc, real(key)));

    case T_COMPLEX:
      return(hash_complex_1(sc, table, loc, key));

    case T_SYNTAX:
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if ((global_slot(fcdr(x))) && 
	    (slot_symbol(global_slot(fcdr(x))) == slot_symbol(global_slot(key))))
	  return(car(x));
      break;

    case T_HASH_TABLE:
    case T_SYMBOL:
    case T_CHARACTER:
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if (fcdr(x) == key)
	  return(car(x));
      break;
      
    default:
      /* we can get into an infinite loop here, but it requires 2 hash tables that are members of each other
       *    and key is one of them, so I changed the equality check above to use eq? -- not sure this is right.
       */
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if (s7_is_equal(sc, fcdr(x), key))
	  return(car(x));
    }
  return(sc->NIL);
}


static s7_pointer hash_eq_func(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_pointer x;
  int hash_len, loc;
  s7_function f;

  f = c_function_call(hash_table_eq_function(table));
  hash_len = (int)hash_table_length(table) - 1;
  loc = hash_loc(sc, key) & hash_len;

  car(sc->T2_1) = key;
  for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
    {
      car(sc->T2_2) = fcdr(x);
      if (is_true(sc, (*f)(sc, sc->T2_1)))
	return(car(x));
    }
  return(sc->NIL);
}


static s7_pointer hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_symbol(key))
    {
      s7_pointer x;
      int hash_len, loc;
      hash_len = (int)hash_table_length(table) - 1;
      loc = symbol_hash(key) & hash_len;
      for (x = hash_table_elements(table)[loc]; is_pair(x); x = cdr(x))
	if (fcdr(x) == key)
	  return(car(x));
    }
  return(sc->NIL);
}


#define DEFAULT_HASH_TABLE_SIZE 511
/* this may be too big -- smaller is faster in lint (even 31), but not in make-index.  Perhaps we need *hash-table-default-size*?
 *   another approach: bi-level tables where we index twice, and thereby skip over (sqrt n) (or whatever) at a time.  
 *   does this happen often? would it matter in the gc enough to warrant the code?
 * or perhaps combine the back-and-forth indexing to a hash-table, so we'd only have the sections we need
 *
 * also what about a simplified hash_table with just the keys => a set, similar to the memq/assq difference
 *   we could add T_SET just like T_BYTEVECTOR and specialize where necessary.
 *   vector->set->hash-table->environment->library
 */

s7_pointer s7_make_hash_table(s7_scheme *sc, s7_Int size)
{
  s7_pointer table;
  int i;
  /* size is rounded up to the next power of 2 */

  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);
      if (s7_int_bits > 31) /* this is either 31 or 63 */
	size |= (size >> 32);
    }
  size++;

  NEW_CELL(sc, table);
  hash_table_length(table) = size;
  hash_table_elements(table) = (s7_pointer *)malloc(size * sizeof(s7_pointer));
  if (!(hash_table_elements(table)))
    return(s7_error(sc, make_symbol(sc, "out-of-memory"), 
		    list_1(sc, make_protected_string(sc, "make-hash-table allocation failed!"))));
  for (i = 0; i < size; i++)
    hash_table_element(table, i) = sc->NIL;
  /* or use the vector fill stuff here, but that now just unrolls the loop */
  hash_table_function(table) = hash_empty;
  hash_table_eq_function(table) = NULL;
  hash_table_entries(table) = 0;
  set_type(table, T_HASH_TABLE | T_SAFE_PROCEDURE);
  add_hash_table(sc, table);

  return(table);
}


static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_make_hash_table "(make-hash-table (size 511) eq-func) or (make-hash-table eq-func (size 511)) returns a new hash table"
  s7_Int size = DEFAULT_HASH_TABLE_SIZE;

  if (is_not_null(args))
    {
      s7_pointer size_arg, eq_arg;
      if (s7_is_integer(car(args)))
	{
	  size_arg = car(args);
	  if (is_not_null(cdr(args)))
	    eq_arg = cadr(args);
	  else eq_arg = sc->NIL;
	}
      else
	{
	  eq_arg = car(args);
	  if (is_not_null(cdr(args)))
	    {
	      size_arg = cadr(args);
	      if (!s7_is_integer(size_arg))
		return(simple_wrong_type_argument(sc, sc->MAKE_HASH_TABLE, size_arg, T_INTEGER));
	    }
	  else size_arg = sc->NIL;
	}

      if (is_not_null(size_arg))
	{
	  size = s7_integer(size_arg);
	  if (size <= 0)                      /* we need s7_Int here to catch (make-hash-table most-negative-fixnum) etc */
	    return(simple_out_of_range(sc, sc->MAKE_HASH_TABLE, size_arg, "should be a positive integer"));
	  if (size > MAX_LIST_LENGTH)
	    return(simple_out_of_range(sc, sc->MAKE_HASH_TABLE, size_arg, "should be a reasonable integer"));
	}
      if (is_not_null(eq_arg))
	{
	  s7_pointer ht;
	  if (!is_procedure(eq_arg))
	    {
	      CHECK_METHOD(sc, eq_arg, sc->MAKE_HASH_TABLE, args);
	      return(simple_wrong_type_argument_with_type(sc, sc->MAKE_HASH_TABLE, eq_arg, A_PROCEDURE));
	    }
	  /* now try to deal with eq_arg -> hash_table_eq_func[tion]
	   */
	  if (is_c_function(eq_arg)) /* we need to restrict this function so that hash-table-ref|set! remain safe functions */
	    {
	      ht = s7_make_hash_table(sc, size);
	      hash_table_function(ht) = hash_eq_func;
	      hash_table_eq_function(ht) = eq_arg;
	      return(ht);
	    }
	}
    }
  
  return(s7_make_hash_table(sc, size));
}


s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_pointer x;
  x = (*hash_table_function(table))(sc, table, key);

  if (is_not_null(x))
    return(cdr(x));
  return(sc->F);
}


s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
{
  s7_pointer x;
  x = (*hash_table_function(table))(sc, table, key);

  if (is_not_null(x))
    cdr(x) = value;
  else
    {
      int hash_len, loc, typ;

      hash_len = hash_table_length(table) - 1;
      loc = hash_loc(sc, key) & hash_len;
      hash_table_entries(table)++;

      if (hash_table_function(table) != hash_eq_func)
	{
	  typ = type(key);
	  if (hash_table_function(table) == hash_empty)
	    {
	      switch (typ)
		{
		case T_STRING:
		  hash_table_function(table) = hash_string;
		  break;
		  
		case T_INTEGER:
		  hash_table_function(table) = hash_int;
		  break;
		  
		case T_REAL:
		  hash_table_function(table) = hash_float;
		  break;
		  
		case T_RATIO:
		case T_COMPLEX:
		  hash_table_function(table) = hash_equal;
		  break;
		  
		case T_SYMBOL:
		  hash_table_function(table) = hash_symbol;
		  break;
		  
		case T_CHARACTER:
		  hash_table_function(table) = hash_char;
		  break;
		  
		default:
		  hash_table_function(table) = hash_equal;
		  /* if every key structure is simple, we'd like to use a simple_equal checker (no circles),
		   *    but circles can sneak in!  lists (etc) are dangerous keys:
		   *
		   (let ((ht (make-hash-table))
		   (lst1 (list 1 2))
		   (lst2 (list 1 2)))
		   (set! (ht lst1) 32)
		   (let ((start (ht lst2)))
		   (set! (lst1 0) 3)
		   (list start (ht lst2))))
		   (32 #f)
		   *
		   * but this applies to all such variables, even strings.  Do other schemes copy the key?
		   */
		  break;
		}
	    }
	  else
	    {
	      switch (typ)
		{
		case T_STRING:
		  if (hash_table_function(table) != hash_string)
		    hash_table_function(table) = hash_equal;
		  break;
		  
		case T_INTEGER:
		  if (hash_table_function(table) != hash_int)
		    hash_table_function(table) = hash_equal;
		  break;
		  
		case T_REAL:
		  if (hash_table_function(table) != hash_float)
		    hash_table_function(table) = hash_equal;
		  break;
		  
		case T_RATIO:
		case T_COMPLEX:
		  hash_table_function(table) = hash_equal;
		  break;
		  
		case T_CHARACTER:
		  if (hash_table_function(table) != hash_char)
		    hash_table_function(table) = hash_equal;
		  break;
		  
		case T_SYMBOL:
		  if (hash_table_function(table) != hash_symbol)
		    hash_table_function(table) = hash_equal;
		  break;
		  
		default:
		  hash_table_function(table) = hash_equal;
		  break;
		}
	    }
	}

      x = cons_unchecked(sc, cons(sc, key, value), hash_table_elements(table)[loc]);
      hash_table_elements(table)[loc] = x;
      set_fcdr(x, key);
    }
  return(value);
}


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"
  s7_pointer table;

  table = car(args);
  
  if (!is_hash_table(table))
    {
      CHECK_METHOD(sc, table, sc->HASH_TABLE_REF, args);
      return(wrong_type_argument(sc, sc->HASH_TABLE_REF, small_int(1), table, T_HASH_TABLE));
    }
  /*
    (define (href H . args) 
      (if (null? (cdr args))
          (hash-table-ref H (car args))
          (apply href (hash-table-ref H (car args)) (cdr args))))
  */

  if (is_null(cddr(args)))
    return(s7_hash_table_ref(sc, table, cadr(args)));
  return(implicit_index(sc, s7_hash_table_ref(sc, table, cadr(args)), cddr(args)));
}


static s7_pointer hash_table_ref_2;
static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, table;
  table = car(args);
  
  if (!is_hash_table(table))
    {
      CHECK_METHOD(sc, table, sc->HASH_TABLE_REF, args);
      return(wrong_type_argument(sc, sc->HASH_TABLE_REF, small_int(1), table, T_HASH_TABLE));
    }
  if (hash_table_entries(table) == 0)
    return(sc->F);

  x = (*hash_table_function(table))(sc, table, cadr(args));
  if (is_not_null(x))
    return(cdr(x));
  return(sc->F);
}

static s7_pointer hash_table_ref_ss;
static s7_pointer g_hash_table_ref_ss(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, table;
  table = finder(sc, car(args));
  
  if (!is_hash_table(table))
    {
      CHECK_METHOD(sc, table, sc->HASH_TABLE_REF, list_2(sc, table, finder(sc, cadr(args))));
      return(wrong_type_argument(sc, sc->HASH_TABLE_REF, small_int(1), table, T_HASH_TABLE));
    }
  if (hash_table_entries(table) == 0)
    return(sc->F);

  x = (*hash_table_function(table))(sc, table, finder(sc, cadr(args)));
  if (is_not_null(x))
    return(cdr(x));
  return(sc->F);
}

static s7_pointer hash_table_ref_car;
static s7_pointer g_hash_table_ref_car(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y, table;
  table = finder(sc, car(args));
  
  if (!is_hash_table(table))
    {
      CHECK_METHOD(sc, table, sc->HASH_TABLE_REF, list_2(sc, table, car(finder(sc, cadadr(args)))));
      return(wrong_type_argument(sc, sc->HASH_TABLE_REF, small_int(1), table, T_HASH_TABLE));
    }
  if (hash_table_entries(table) == 0)
    return(sc->F);

  y = finder(sc, cadadr(args));
  if (!is_pair(y))
    return(simple_wrong_type_argument(sc, sc->CAR, y, T_PAIR));

  x = (*hash_table_function(table))(sc, table, car(y));
  if (is_not_null(x))
    return(cdr(x));
  return(sc->F);
}


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"
  s7_pointer table;

  table = car(args);
  
  if (!is_hash_table(table))
    {
      CHECK_METHOD(sc, table, sc->HASH_TABLE_SET, args);
      return(wrong_type_argument(sc, sc->HASH_TABLE_SET, small_int(1), table, T_HASH_TABLE));
    }
  /* how would (set! (ht a b) c) choose the inner table if (ht a b) is not found?
   *   I'm not sure the multi-index case makes sense here
   */

  return(s7_hash_table_set(sc, table, cadr(args), caddr(args)));
}


static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table "(hash-table ...) returns a hash-table containing the cons's passed as its arguments. \
That is, (hash-table '(\"hi\" . 3) (\"ho\" . 32)) returns a new hash-table with the two key/value pairs preinstalled."

  int len, ht_loc;
  s7_pointer x, ht;

  /* this accepts repeated keys: (hash-table '(a . 1) '(a . 1)) -- or just '(a) for that matter
   */

  for (len = 0, x = args; is_pair(x); x = cdr(x), len++)
    if ((!is_pair(car(x))) &&
	(!is_null(car(x))))
      return(wrong_type_argument(sc, sc->HASH_TABLE, make_integer(sc, position_of(x, args)), car(x), T_PAIR));

  ht = s7_make_hash_table(sc, (len > 512) ? 4095 : 511);
  if (len > 0)
    {
      ht_loc = s7_gc_protect(sc, ht); /* hash_table_set can cons, so we need to protect this */
      for (x = args; is_pair(x); x = cdr(x)) 
	{
	  if (is_pair(car(x)))
	    s7_hash_table_set(sc, ht, caar(x), cdar(x));
	}
      s7_gc_unprotect_at(sc, ht_loc);
    }
  return(ht);
}


static s7_pointer hash_list_copy(s7_scheme *sc, s7_pointer obj)
{
  if (is_pair(obj))
    {
      s7_pointer p;
      p = cons(sc, s7_copy(sc, car(obj)), hash_list_copy(sc, cdr(obj)));
      set_fcdr(p, caar(p));
      return(p);
    }
  return(obj);
}


static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash)
{
  /* this has to copy not only the lists but the cons's in the lists! */
  int i, len;
  s7_pointer new_hash;
  s7_pointer *old_lists, *new_lists;
  int gc_loc;

  len = hash_table_length(old_hash);
  new_hash = s7_make_hash_table(sc, len);
  gc_loc = s7_gc_protect(sc, new_hash);

  old_lists = hash_table_elements(old_hash);
  new_lists = hash_table_elements(new_hash);

  for (i = 0; i < len; i++)
    if (is_not_null(old_lists[i]))
      new_lists[i] = hash_list_copy(sc, old_lists[i]);

  hash_table_entries(new_hash) = hash_table_entries(old_hash);
  hash_table_function(new_hash) = hash_table_function(old_hash);
  hash_table_eq_function(new_hash) = hash_table_eq_function(old_hash);

  s7_gc_unprotect_at(sc, gc_loc);
  return(new_hash);
}


static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash)
{
  int i, len;
  s7_pointer new_hash;
  s7_pointer *old_lists;
  int gc_loc;

  len = hash_table_length(old_hash);
  new_hash = s7_make_hash_table(sc, len);
  gc_loc = s7_gc_protect(sc, new_hash);

  old_lists = hash_table_elements(old_hash);
  /* don't set entries or function -- s7_hash_table_set below will handle those (really?) */

  for (i = 0; i < len; i++)
    {
      s7_pointer x;
      for (x = old_lists[i]; is_not_null(x); x = cdr(x))
	s7_hash_table_set(sc, new_hash, cdar(x), caar(x));
    }

  if (hash_table_function(old_hash) == hash_eq_func)
    {
      hash_table_function(new_hash) = hash_eq_func;
      hash_table_eq_function(new_hash) = hash_table_eq_function(old_hash);
    }
    
  s7_gc_unprotect_at(sc, gc_loc);
  return(new_hash);
}


static s7_pointer hash_table_clear(s7_scheme *sc, s7_pointer table)
{
  int i, len;

  len = hash_table_length(table);
  for (i = 0; i < len; i++)
    hash_table_element(table, i) = sc->NIL;
  hash_table_entries(table) = 0;
  if (hash_table_function(table) != hash_eq_func)
    hash_table_function(table) = hash_empty;
  return(table);
}



/* ---------------- hash-table iterators ---------------- */

typedef struct {
  s7_pointer table, lst;
  int loc;
} ht_iter;

static int ht_iter_tag = 0;


static char *print_ht_iter(s7_scheme *sc, void *val)
{
  char *str;
  str = (char *)calloc(32, sizeof(char));
  snprintf(str, 32, "#<hash-table-iterator>");
  return(str);
}


static void free_ht_iter(void *val)
{
  free(val);
}


static bool equal_ht_iter(void *val1, void *val2)
{
  return(val1 == val2);
}


static void mark_ht_iter(void *val)
{
  ht_iter *iter = (ht_iter *)val;
  s7_mark_object(iter->table);
  s7_mark_object(iter->lst);
}


static char *write_ht_iter_readably(s7_scheme *sc, void *val)
{
  write_readably_error(sc, "a hash-table-iterator");
  return(NULL);
}


static s7_pointer copy_ht_iter(s7_scheme *sc, s7_pointer obj)
{
  ht_iter *new_iter, *old_iter;
  old_iter = (ht_iter *)s7_object_value(obj);
  
  new_iter = (ht_iter *)calloc(1, sizeof(ht_iter));
  new_iter->lst = old_iter->lst;
  new_iter->table = old_iter->table;
  new_iter->loc = old_iter->loc;

  return(s7_make_object(sc, ht_iter_tag, (void *)new_iter));
}


static s7_pointer g_make_hash_table_iterator(s7_scheme *sc, s7_pointer args)
{
  #define H_make_hash_table_iterator "(make-hash-table-iterator table) returns a function of no arguments that \
returns the next (key . value) pair in the hash-table each time it is called.  When there are no more pairs, it returns nil."

  ht_iter *iter;
  if (!is_hash_table(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->MAKE_HASH_TABLE_ITERATOR, args);
      return(simple_wrong_type_argument(sc, sc->MAKE_HASH_TABLE_ITERATOR, car(args), T_HASH_TABLE));
    }
  iter = (ht_iter *)calloc(1, sizeof(ht_iter));
  iter->lst = sc->NIL;
  iter->table = car(args);
  iter->loc = -1;

  return(s7_make_object(sc, ht_iter_tag, (void *)iter));
}


static s7_pointer g_is_hash_table_iterator(s7_scheme *sc, s7_pointer args)
{
  #define H_is_hash_table_iterator "(hash-table-iterator? obj) returns #t if obj is a hash-table iterator."
  s7_pointer obj;

  obj = car(args);
  if ((s7_is_object(obj)) && 
      (c_object_type(obj) == ht_iter_tag))
    return(sc->T);

  CHECK_METHOD(sc, obj, sc->HASH_TABLE_ITERATORP, args);
  return(sc->F);
}


static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer lst, table;
  ht_iter *iter;
  int loc, len;
  s7_pointer *elements;

  iter = (ht_iter *)s7_object_value(iterator);
  lst = iter->lst;
  if (is_pair(lst))
    {
      iter->lst = cdr(lst);
      return(car(lst));
    }

  table = iter->table;
  len = hash_table_length(table);
  elements = hash_table_elements(table);

  for (loc = iter->loc + 1; loc < len;  loc++)
    {
      s7_pointer x;
      x = elements[loc];
      if (is_not_null(x))
	{
	  iter->loc = loc;
	  iter->lst = cdr(x);
	  return(car(x));
	}
    }

  iter->loc = len;
  return(sc->NIL);
}


static s7_pointer ref_ht_iter(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  /* don't check args -- it's simpler in map/for-each to pass an int to all objects in this context
   */
  return(hash_table_iterate(sc, obj));
}

/* no obvious meaning for length of a hash-table-iterator, or set!, fill!, and reverse
 */





/* -------------------------------- objects and functions -------------------------------- */

bool s7_is_function(s7_pointer p)  
{ 
  return(is_c_function(p));
}


bool s7_is_object(s7_pointer p) 
{ 
  return(is_c_object(p));
}


void s7_function_set_step_safe(s7_pointer f)
{
  set_step_safe(f);
}

static unsigned int f_class = 0;

static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(f);
}


unsigned int s7_function_class(s7_pointer f)
{
  return(c_function_class(f));
}

void s7_function_set_class(s7_pointer f, s7_pointer base_f)
{
  c_function_class(f) = c_function_class(base_f);
  c_function_base(f) = base_f;
}


void s7_function_set_looped(s7_pointer f, s7_pointer c)
{
  c_function_looped(f) = c;
}


void s7_function_set_let_looped(s7_pointer f, s7_pointer c)
{
  c_function_let_looped(f) = c;
}


void s7_function_set_ex_parser(s7_pointer f, s7_ex *(*func)(s7_scheme *sc, s7_pointer expr))
{
  c_function_ex_parser(f) = func;
}

s7_ex *(*s7_function_ex_parser(s7_pointer f))(s7_scheme *sc, s7_pointer expr)
{
  return(c_function_ex_parser(f));
}



s7_pointer (*s7_function_chooser(s7_scheme *sc, s7_pointer fnc))(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(c_function_chooser(fnc));
}

void s7_function_set_chooser(s7_scheme *sc, s7_pointer fnc,  s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr))
{
  c_function_chooser(fnc) = chooser;
}


void *s7_function_chooser_data(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(expr)) &&
      (is_optimized(expr)) &&
      (is_symbol(car(expr))) &&
      (car(expr) != sc->QUOTE) &&
      (ecdr(expr)) &&
      (is_c_function(ecdr(expr))))
    return(c_function_chooser_data(ecdr(expr)));
  return(NULL);
}

void *s7_function_chooser_data_direct(s7_pointer f)
{
  if (is_c_function(f))
    return(c_function_chooser_data(f));
  return(NULL);
}

void s7_function_chooser_set_data(s7_scheme *sc, s7_pointer f, void *data)
{
  c_function_chooser_data(f) = data;
}


s7_function s7_function_choice(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(expr)) &&
      (is_optimized(expr)) &&
      (is_symbol(car(expr))) &&
      (car(expr) != sc->QUOTE) &&
      (ecdr(expr)) &&
      (is_c_function(ecdr(expr))))
    return(c_function_call(ecdr(expr)));
  return(NULL);
}

void s7_function_choice_set_direct(s7_scheme *sc, s7_pointer expr)
{
  set_optimize_data(expr, HOP_SAFE_C_C);
  clear_unsafe(expr);
}

bool s7_function_choice_is_direct(s7_scheme *sc, s7_pointer expr)
{
  return((is_optimized(expr)) && 
	 ((optimize_data(expr) == HOP_SAFE_C_C) ||
	  ((optimize_data(expr) == OP_SAFE_C_C) &&
	   (symbol_id(car(expr)) == 0))));
}

bool s7_function_choice_is_direct_to_real(s7_scheme *sc, s7_pointer expr)
{
  return((is_optimized(expr)) && 
	 (ecdr(expr)) &&
	 (returns_temp(ecdr(expr))) &&
	 ((optimize_data(expr) == HOP_SAFE_C_C) ||
	  ((optimize_data(expr) == OP_SAFE_C_C) &&
	   (symbol_id(car(expr)) == 0))));
}


s7_pointer s7_call_direct(s7_scheme *sc, s7_pointer expr)
{
  return(c_function_call(ecdr(expr))(sc, cdr(expr)));
}


s7_Double s7_call_direct_to_real_and_free(s7_scheme *sc, s7_pointer expr)
{
  s7_Double val;
  s7_pointer temp;

  temp = c_function_call(ecdr(expr))(sc, cdr(expr));
#if (!WITH_GMP)
  val = real(temp);
#else
  val = s7_real(temp);
#endif
  if (is_simple_real(temp)) /* i.e. not immutable, not integer or something else unexpected */
    {
      typeflag(temp) = 0;
      (*(sc->free_heap_top++)) = temp;
    }
  return(val);
}


s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function f, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  c_proc_t *ptr;
  int ftype = T_C_FUNCTION;
  s7_pointer x;

  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;

  ptr = (c_proc_t *)calloc(1, sizeof(c_proc_t));
  if (required_args == 0)
    {
      if (rest_arg)
	ftype = T_C_ANY_ARGS_FUNCTION;
      else 
	{
	  if (optional_args != 0)
	    ftype = T_C_OPT_ARGS_FUNCTION;
	  /* a thunk needs to check for no args passed */
	}
    }
  else
    {
      if (rest_arg)
	ftype = T_C_RST_ARGS_FUNCTION;
    }
  
  set_type(x, ftype | T_PROCEDURE);

  c_function_data(x) = ptr;
  c_function_call(x) = f;
  c_function_base(x) = x;
  c_function_setter(x) = sc->F;
  c_function_name(x) = name;   /* (procedure-name proc) => (format #f "~A" proc) */
  c_function_name_length(x) = safe_strlen(name);
  if (doc)
    c_function_documentation(x) = make_permanent_string(doc);

  c_function_required_args(x) = required_args;
  c_function_optional_args(x) = optional_args;
  c_function_has_rest_arg(x) = rest_arg;
  if (rest_arg)
    c_function_all_args(x) = MAX_ARITY;
  else c_function_all_args(x) = required_args + optional_args;

  c_function_class(x) = ++f_class;
  c_function_chooser(x) = fallback_chooser;
  c_function_chooser_data(x) = NULL;
  c_function_looped(x) = NULL;
  c_function_let_looped(x) = NULL;
  c_function_ex_parser(x) = NULL;

  return(x);
}


s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
{
  if (is_c_function(fnc))
    return(c_function_call(fnc)(sc, args));

  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
  sc->args = args;
  sc->code = fnc;
  eval(sc, OP_APPLY);
  return(sc->value);
}


bool s7_is_procedure(s7_pointer x)
{
  return(is_procedure(x)); /* this returns "is applicable" so it is true for applicable c_objects, macros, etc */
}


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"
  s7_pointer x;
  int typ;

  x = car(args);
  if (!is_procedure(x)) 
    {
      CHECK_METHOD(sc, x, sc->PROCEDUREP, args);
      return(sc->F);
    }
  typ = type(x);

  /* make_object sets the T_PROCEDURE bit if the object has an apply function,
   *   but we currently return (procedure? "hi") -> #f, so we can't simply use
   *   is_procedure. 
   * 
   * Unfortunately much C code depends on s7_is_procedure treating applicable
   *  objects and macros as procedures.  We can use arity = applicable?
   */
  return(make_boolean(sc,
		      (typ == T_CLOSURE)      || 
		      (typ == T_CLOSURE_STAR) ||
		      (typ >= T_C_FUNCTION)   ||
		      (typ == T_GOTO)         ||
		      (typ == T_CONTINUATION)));
}


static void s7_function_set_setter(s7_scheme *sc, const char *getter, const char *setter)
{
  /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice
   */
  c_function_setter(s7_name_to_value(sc, getter)) = s7_name_to_value(sc, setter);
}


s7_pointer s7_procedure_source(s7_scheme *sc, s7_pointer p)
{
  /* in this context, there's no way to distinguish between:
   *    (procedure-source (let ((b 1)) (lambda (a) (+ a b))))
   * and
   *    (let ((b 1)) (procedure-source (lambda (a) (+ a b))))
   * both become:
   * ((a) (+ a b)) (((b . 1)) #(() () () () () ((make-filtered-comb . make-filtered-comb)) () () ...))
   */
  
  if (is_closure(p) || is_closure_star(p) || is_macro(p) || is_bacro(p))
    {
      return(cons(sc, 
		  append_in_place(sc, 
				  list_2(sc, 
					 (is_closure_star(p)) ? sc->LAMBDA_STAR : sc->LAMBDA, 
					 closure_args(p)),
				  closure_body(p)),
		  closure_environment(p)));
    }
  
  return(sc->NIL);
}


static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
{
  /* make it look like a scheme-level lambda */
  s7_pointer p;
  
  #define H_procedure_source "(procedure-source func) tries to return the definition of func"
  
  p = car(args);

  if (is_symbol(p))
    {
      p = s7_symbol_value(sc, p);
      if (p == sc->UNDEFINED)
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "procedure-source arg, '~S, is unbound"), car(args))));
    }
  if (is_c_function(p))
    return(sc->NIL);

  if (is_c_macro(p))
    return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_SOURCE, p, make_protected_string(sc, "a scheme macro")));

  if ((!is_procedure(p)) &&
      (!is_macro(p)) &&
      (!is_bacro(p)))
    return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_SOURCE, car(args), make_protected_string(sc, "a procedure or a macro")));

  if (is_closure(p) || is_closure_star(p) || is_macro(p) || is_bacro(p))
    {
      s7_pointer body;
      body = closure_body(p);
      if (is_safe_closure(body))
	clear_safe_closure(body);
      return(append_in_place(sc, 
			     list_2(sc, 
				    (is_closure_star(p)) ? sc->LAMBDA_STAR : sc->LAMBDA, 
				    closure_args(p)),
			     body));
    }

  return(sc->NIL);
}


s7_pointer s7_procedure_environment(s7_scheme *sc, s7_pointer p)    
{ 
  if (is_closure(p) || is_closure_star(p) || is_macro(p) || is_bacro(p))
    return(closure_environment(p));
  return(sc->global_env);
}


static s7_pointer g_procedure_environment(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  #define H_procedure_environment "(procedure-environment func) tries to return func's environment"

  /* this procedure gives direct access to a function's closure -- see s7test.scm 
   *   for some wild examples.  At least it provides a not-too-kludgey way for several functions
   *   to share a closure.
   */ 
  
  p = car(args);
  if (is_symbol(p))
    {
      p = s7_symbol_value(sc, p);
      if (p == sc->UNDEFINED)
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "procedure-environment arg, '~S, is unbound"), car(args)))); /* not p here */
    }

  if (!is_procedure_or_macro(p))
    return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_ENVIRONMENT, car(args), make_protected_string(sc, "a procedure or a macro")));

  if ((is_closure(p) || is_closure_star(p) || is_macro(p) || is_bacro(p)) &&
      (is_not_null(closure_environment(p))))
    return(closure_environment(p));
  return(sc->global_env);
}


s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer func, sym;
  func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  sym = make_symbol(sc, name);
  s7_define(sc, sc->NIL, sym, func);
  return(sym);
}


s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer func, sym;
  func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  typeflag(func) |= T_SAFE_PROCEDURE;
  sym = make_symbol(sc, name);
  s7_define(sc, sc->NIL, sym, func);
  return(sym);
}


static s7_pointer s7_define_constant_function(s7_scheme *sc, const char *name, s7_function fnc, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer func, sym, p;
  sym = make_symbol(sc, name);
  func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  s7_define(sc, sc->NIL, sym, func);
  set_immutable(slot_symbol(global_slot(sym)));

  p = s7_symbol_value(sc, sym); /* make_symbol(sc, name)); */
  typeflag(p) &= ~(T_SAFE_PROCEDURE);
  return(p);
}


s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer func, sym;
  func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  set_type(func, T_C_MACRO | T_DONT_EVAL_ARGS); /* this used to include T_PROCEDURE */
  sym = make_symbol(sc, name);
  s7_define(sc, sc->NIL, sym, func);
  return(sym);
}

/* would define_bacro be useful in C?
 */


bool s7_is_macro(s7_scheme *sc, s7_pointer x)
{
  if ((is_macro(x)) || (is_bacro(x)) || (is_c_macro(x)))
    return(true);

  if (is_symbol(x))
    {
      x = s7_symbol_value(sc, x);
      return(is_macro(x) || is_bacro(x) || is_c_macro(x));
    }
  return(false);
}


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"
  s7_pointer p;
  p = car(args);
  if (s7_is_macro(sc, p)) return(sc->T);
  CHECK_METHOD(sc, p, sc->MACROP, args);
  return(sc->F);

  /* it would be more consistent (with procedure? for example) if this returned #f for a symbol,
   *   but fully-expand expects this version.
   */
}


static s7_pointer g_is_bacro(s7_scheme *sc, s7_pointer args)
{
  #define H_is_bacro "(bacro? arg) returns #t if 'arg' is a bacro"
  return(make_boolean(sc, is_bacro(car(args))));
}


void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
{
  /* make an internal function of any args that calls fnc, then wrap it in define* and use eval_c_string */
  /* should (does) this ignore :key and other such noise? */

  char *internal_function, *internal_arglist;
  int arglist_len, len, args;
  const char *local_sym;
  s7_pointer local_args;
  
  arglist_len = safe_strlen(arglist);
  internal_arglist = (char *)calloc(arglist_len + 64, sizeof(char));
  snprintf(internal_arglist, arglist_len + 64, "(map (lambda (arg) (if (symbol? arg) arg (car arg))) '(%s))", arglist);
  local_args = s7_eval_c_string(sc, internal_arglist);
  free(internal_arglist);
  
  args = safe_list_length(sc, local_args); /* since local_args is from map (above), I think it can't be improper */
  internal_arglist = s7_object_to_c_string(sc, local_args);
  /* this has an opening paren which we don't want */
  internal_arglist[0] = ' ';

  local_sym = symbol_name(s7_gensym(sc, "define*"));
  s7_define_function(sc, local_sym, fnc, args, 0, 0, NULL);

  len = 32 + 2 * arglist_len + safe_strlen(doc) + safe_strlen(name) + safe_strlen(local_sym);
  internal_function = (char *)calloc(len, sizeof(char));
  snprintf(internal_function, len, "(define* (%s %s) \"%s\" (%s %s)", name, arglist, doc, local_sym, internal_arglist);
  s7_eval_c_string(sc, internal_function);

  free(internal_function);
  free(internal_arglist);
}


const char *s7_procedure_documentation(s7_scheme *sc, s7_pointer x)
{
  static char *arglist = NULL;
  #define ARGLIST_SIZE 512
  if (is_symbol(x))
    x = s7_symbol_value(sc, x); /* this is needed by Snd */

  if ((s7_is_function(x)) ||
      (is_c_macro(x)))
    return((char *)c_function_documentation(x));
  
  if (((is_closure(x)) || 
       (is_closure_star(x))))
    {
      char *args;

      if (is_string(car(closure_body(x))))
	return(string_value(car(closure_body(x))));

      if (!arglist)
	arglist = (char *)calloc(ARGLIST_SIZE, sizeof(char));
      args = s7_object_to_c_string(sc, closure_args(x));
      if (args)
	{
	  snprintf(arglist, ARGLIST_SIZE, "args: %s", args);
	  free(args);
	  return(arglist);
	}
    }
  
  if ((s7_is_macro(sc, x)) &&
      (is_pair(closure_body(x))))
    {
      s7_pointer p;
      p = car(closure_body(x));
      if ((is_pair(p)) &&
	  (is_pair(cdr(p))) &&
	  (is_pair(cadr(p))) &&
	  (is_pair(cdadr(p))) &&
	  (is_pair(cddr(cadr(p)))) &&
	  (is_string(caddr(cadr(p)))))
	return(string_value(caddr(cadr(p))));
    }

  return(""); /* not NULL here so that (string=? "" (procedure-documentation no-doc-func)) -> #t */
}


static s7_pointer g_procedure_documentation(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_documentation "(procedure-documentation func) returns func's documentation string"
  s7_pointer p;

  p = car(args);
  if (is_symbol(p))
    p = s7_symbol_value(sc, p);

  if ((!is_procedure(p)) &&
      (!s7_is_macro(sc, p)))
    return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_DOCUMENTATION, car(args), A_PROCEDURE));
  return(s7_make_string(sc, s7_procedure_documentation(sc, p)));
}


const char *s7_help(s7_scheme *sc, s7_pointer obj)
{
  if (is_syntax(obj))
    {
      switch (syntax_opcode(obj))
	{
	case OP_QUOTE:
	  return("(quote obj) returns obj unevaluated.  'obj is an abbreviation for (quote obj).");
	  
	case OP_IF:
	  return("(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.");
	  
	case OP_BEGIN:
	  return("(begin ...) evaluates each form in its body, returning the value of the last one");

	case OP_SET:
	  return("(set! variable value) sets the value of variable to value.");

	case OP_LET:
	  return("(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 in the case of let (as opposed to let* for example), \
the variables are not available for use until all have been initialized.");

	case OP_LET_STAR:
	  return("(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 (unlike let, for example).");

	case OP_LETREC:
	  return("(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in \
its value (i.e. you can define local recursive functions)");

	case OP_COND:
	  return("(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.");

	case OP_AND:
	  return("(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.");

	case OP_OR:
	  return("(or expr expr ...) evaluates each of its argments in order, quitting as soon as \
one of them is not #f.  If all are #f, or returns #f.");

	case OP_CASE:
	  return("(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.");

	case OP_DO:
	  return("(do (vars...) (loop control and return value) ...) is a do-loop.");

	case OP_WITH_ENV:
	  return("(with-environment env ...) evaluates its body in the environment env.");

	case OP_WITH_BAFFLE:
	  return("(with-baffle ...) evaluates its body in a context that is safe from outside interference.");

	case OP_LAMBDA:
	  return("(lambda args ...) returns a function.");

	case OP_LAMBDA_STAR:
	  return("(lambda* args ...) returns a function; the args list can have default values, \
the parameters themselves can be accessed via keywords.");

	case OP_DEFINE:
	  return("(define var val) assigns val to the variable (symbol) var.  (define (func args) ...) is \
shorthand for (define func (lambda args ...))");

	case OP_DEFINE_STAR:
	  return("(define* (func args) ...) defines a function with optional/keyword arguments.");

	case OP_DEFINE_CONSTANT:
	  return("(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val.");

	case OP_DEFMACRO:
	  return("(defmacro mac (args) ...) defines mac to be a macro.");

	case OP_DEFMACRO_STAR:
	  return("(defmacro* mac (args) ...) defines mac to be a macro with optional/keyword arguments.");

	case OP_DEFINE_MACRO:
	  return("(define-macro (mac args) ...) defines mac to be a macro.");

	case OP_DEFINE_MACRO_STAR:
	  return("(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments.");

	case OP_DEFINE_EXPANSION:
	  return("(define-expansion (mac args) ...) defines mac to be a read-time macro.");

	case OP_DEFINE_BACRO:
	  return("(define-bacro (mac args) ...) defines mac to be a bacro.");

	case OP_DEFINE_BACRO_STAR:
	  return("(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments.");
	}
      
      return(NULL);

      /* others: macroexpand
            :(define-macro (hiho a) "a test" `(+ 1 ,a))
            hiho
            :(hiho 2)
            3
            :(s7-help hiho)
            "a test"
            with-sound #f etc -- all macros at least
       */
    }

  if (is_symbol(obj))
    {
      /* here look for name */
      obj = s7_symbol_value(sc, obj);
    }
  
  if (is_procedure_or_macro(obj))
    return(s7_procedure_documentation(sc, obj));

  /* if is string, apropos? (can scan symbol table)
   */
  /* here keep a table as in xen.c? need s7_help and s7_set_help in C + maybe s7_define_constant_with_documentation
   */

  return(NULL);
}


static s7_pointer g_help(s7_scheme *sc, s7_pointer args)
{
  #define H_help "(help obj) returns obj's documentation"
  const char *doc;

  CHECK_METHOD(sc, car(args), sc->HELP, args);

  doc = s7_help(sc, car(args));
  if (!doc)
    return(sc->F);
  return(s7_make_string(sc, doc));
}


static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure)
{
  /* this is used by the error handlers to get the current function name 
   */
  s7_pointer x;

  x = find_closure(sc, closure, sc->envir);
  if (is_symbol(x))
    return(x);

  if (is_pair(sc->cur_code))
    return(sc->cur_code);

  return(caar(closure)); /* desperation -- this is the parameter list */
}

/* (define* (hi (a 1) (b 2)) a) (hi :b 1 2) */
/* (let ((x (lambda* ((a 1) (b 2)) a))) (x :b 1 2)) */




/* -------------------------------- new types -------------------------------- */

static char *fallback_print(s7_scheme *sc, void *val) /* obj is c_object_value(s7_pointer_obj) */
{
  return(copy_string("#<unprintable object>"));
}

static void fallback_free(void *value)
{
}

static bool fallback_equal(void *val1, void *val2)
{
  return(val1 == val2);
}

static s7_pointer fallback_ref(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  return(apply_error(sc, obj, args));
}

static s7_pointer fallback_set(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  return(eval_error(sc, "attempt to set ~S?", obj));
}

static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj)
{
  return(eval_error(sc, "attempt to get length of ~S?", obj));
}


static s7_pointer g_internal_object_set_3(s7_scheme *sc, s7_pointer args)
{
  s7_pointer obj, index, value;
  obj = car(args);
  index = cadr(args);
  value = caddr(args);

  if ((c_object_has_array(obj)) &&
      (is_integer(index)) &&
      (integer(index) >= 0) &&
      (type(value) == T_REAL) &&
      (integer(index) < c_object_array_length(obj)))
    {
      c_object_array(obj)[integer(index)] = real(value);
      return(value);
    }

  return((*(c_object_set_3(obj)))(sc, c_object_value(obj), index, value));
}

static s7_pointer g_internal_object_set(s7_scheme *sc, s7_pointer args)
{
  return((*(c_object_set(car(args))))(sc, car(args), cdr(args)));
}


int s7_new_type(const char *name, 
		char *(*print)(s7_scheme *sc, void *value), 
		void (*free)(void *value), 
		bool (*equal)(void *val1, void *val2),
		void (*gc_mark)(void *val),
                s7_pointer (*apply)(s7_scheme *sc, s7_pointer obj, s7_pointer args),
                s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_pointer args))
{
  int tag;
  tag = num_types++;
  if (tag >= object_types_size)
    {
      if (object_types_size == 0)
	{
	  object_types_size = 8;
	  object_types = (c_object_t **)calloc(object_types_size, sizeof(c_object_t *));
	}
      else
	{
	  object_types_size = tag + 8;
	  object_types = (c_object_t **)realloc((void *)object_types, object_types_size * sizeof(c_object_t *));
	}
    }
  object_types[tag] = (c_object_t *)calloc(1, sizeof(c_object_t));
  object_types[tag]->type = tag;
  object_types[tag]->name = copy_string(name);

  if (free)
    object_types[tag]->free = free;
  else object_types[tag]->free = fallback_free;

  if (print)
    object_types[tag]->print = print;
  else object_types[tag]->print = fallback_print;

  if (equal)
    object_types[tag]->equal = equal;
  else object_types[tag]->equal = fallback_equal;

  object_types[tag]->gc_mark = gc_mark;

  if (apply)
    object_types[tag]->ref = apply;
  else object_types[tag]->ref = fallback_ref;

  if (set)
    object_types[tag]->set = set;
  else object_types[tag]->set = fallback_set;

  object_types[tag]->length = fallback_length;
  object_types[tag]->copy = NULL;
  object_types[tag]->reverse = NULL;
  object_types[tag]->fill = NULL;
  
  object_types[tag]->ref_2 = NULL;
  object_types[tag]->set_3 = NULL;

  object_types[tag]->min_args = 0;
  object_types[tag]->max_args = MAX_ARITY;

  return(tag);
}


int s7_new_type_x(const char *name, 
		  char *(*print)(s7_scheme *sc, void *value), 
		  void (*free)(void *value), 
		  bool (*equal)(void *val1, void *val2),
		  void (*gc_mark)(void *val),
		  s7_pointer (*apply)(s7_scheme *sc, s7_pointer obj, s7_pointer args),
		  s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_pointer args),
		  s7_pointer (*length)(s7_scheme *sc, s7_pointer obj),
		  s7_pointer (*copy)(s7_scheme *sc, s7_pointer obj),
		  s7_pointer (*reverse)(s7_scheme *sc, s7_pointer obj),
		  s7_pointer (*fill)(s7_scheme *sc, s7_pointer obj, s7_pointer val))
{
  int tag;
  tag = s7_new_type(name, print, free, equal, gc_mark, apply, set);

  if (length)
    object_types[tag]->length = length;
  else object_types[tag]->length = fallback_length;

  object_types[tag]->copy = copy;
  object_types[tag]->reverse = reverse;
  object_types[tag]->fill = fill;
  return(tag);
}


static void free_object(s7_pointer a)
{
  (*(c_object_free(a)))(c_object_value(a));
}


static bool objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  if (c_object_type(a) == c_object_type(b))
    {
      if (c_object_equal(a))
	return((*(c_object_equal(a)))(c_object_value(a), c_object_value(b)));
      return(a == b);
    }
  return(false);
}


static void mark_embedded_objects(s7_pointer a) /* called by gc, calls c_obj's mark func */
{
  if (c_object_mark(a))
    (*(c_object_mark(a)))(c_object_value(a));
}


void *s7_object_value(s7_pointer obj)
{
  return(c_object_value(obj));
}


void *s7_object_value_checked(s7_pointer obj, int type)
{
  if ((is_c_object(obj)) &&
      (c_object_type(obj) == type))
    return(c_object_value(obj));
  return(NULL);
}


void s7_set_object_ref_2(int type, s7_pointer (*ref_2)(s7_scheme *sc, void *val, s7_pointer index))
{
  object_types[type]->ref_2 = ref_2;
}


void s7_set_object_set_3(int type, s7_pointer (*set_3)(s7_scheme *sc, void *val, s7_pointer index, s7_pointer value))
{
  object_types[type]->set_3 = set_3;
}


void s7_set_object_print_readably(int type, char *(*printer)(s7_scheme *sc, void *val))
{
  object_types[type]->print_readably = printer;
}


void s7_set_object_array_info(int type, size_t length_loc, size_t data_loc)
{
  object_types[type]->length_loc = length_loc;
  object_types[type]->data_loc = data_loc;
  object_types[type]->has_array = true;
}


void s7_set_object_ref_arity(int type, unsigned int min_args, unsigned int max_args)
{
  object_types[type]->min_args = min_args;
  object_types[type]->max_args = max_args;
}


int s7_object_type(s7_pointer obj)
{
  if (is_c_object(obj))
    return(c_object_type(obj));
  return(-1);
}


s7_pointer s7_make_object(s7_scheme *sc, int type, void *value)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  
  /* c_object_info(x) = &(object_types[type]); */
  /* that won't work because 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!
   */

  c_object_type(x) = type;
  c_object_value(x) = value;
  c_object_environment(x) = sc->NIL;
  if (object_types[type]->has_array)
    {
      if ((c_object_ref(x)) && (c_object_ref(x) != fallback_ref))
	set_type(x, T_C_OBJECT | T_PROCEDURE | T_SAFE_PROCEDURE | T_GENSYM);
      else set_type(x, T_C_OBJECT | T_GENSYM); 
      c_object_array(x) = c_object_data(x);
      c_object_array_length(x) = c_object_data_length(x);
    }
  else
    {
      if ((c_object_ref(x)) && (c_object_ref(x) != fallback_ref))
	set_type(x, T_C_OBJECT | T_PROCEDURE | T_SAFE_PROCEDURE);
      else set_type(x, T_C_OBJECT); 
    }

  add_c_object(sc, x);

  return(x);
}


s7_pointer s7_object_environment(s7_pointer obj)
{
  return(c_object_environment(obj));
}


s7_pointer s7_object_set_environment(s7_pointer obj, s7_pointer e)
{
  c_object_environment(obj) = e;
  return(e);
}


static s7_pointer g_object_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_object_environment "(object-environment obj) returns the environment associated with obj."
  s7_pointer obj;
  obj = car(args);
  if (!is_c_object(obj))
    return(simple_wrong_type_argument_with_type(sc, sc->OBJECT_ENVIRONMENT, obj, make_protected_string(sc, "a c object (created by s7_make_object)")));
  return(c_object_environment(obj));
}


static s7_pointer object_length(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_has_array(obj))
    return(make_integer(sc, c_object_array_length(obj)));

  if (c_object_length(obj))
    return((*(c_object_length(obj)))(sc, obj));
  return(eval_error(sc, "attempt to get length of ~S?", obj));
}


static s7_Int object_length_to_int(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer res;
  if (c_object_has_array(obj))
    return(c_object_array_length(obj));
  if (c_object_length(obj))
    {
      res = (*(c_object_length(obj)))(sc, obj);
      if (s7_is_integer(res))
	return(s7_integer(res));
    }
  return(-1);
}


static s7_pointer object_copy(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_copy(obj))
    return((*(c_object_copy(obj)))(sc, obj));
  return(eval_error(sc, "attempt to copy ~S?", obj));
}


static s7_pointer object_reverse(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_reverse(obj))
    return((*(c_object_reverse(obj)))(sc, obj));
  return(eval_error(sc, "attempt to reverse ~S?", obj));
}


/* -------- procedure-with-setter -------- */

s7_pointer s7_make_procedure_with_setter(s7_scheme *sc, 
					 const char *name,
					 s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), 
					 int get_req_args, int get_opt_args,
					 s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
					 int set_req_args, int set_opt_args,
					 const char *documentation)
{
  s7_pointer get_func, set_func;
  char *internal_set_name;
  int len;

  len = 16 + safe_strlen(name);
  internal_set_name = (char *)calloc(len, sizeof(char));
  snprintf(internal_set_name, len, "[set-%s]", name);

  get_func = s7_make_function(sc, name, getter, get_req_args, get_opt_args, false, documentation); 
  typeflag(get_func) |= T_SAFE_PROCEDURE; 

  /* this is slightly dangerous -- the C function might call a hook for example.
   *   an unsafe procedure-with-setter might be defined via
   *   s7_define_c_function followed by s7_procedure_set_setter.
   */

  s7_define(sc, sc->NIL, make_symbol(sc, name), get_func);
  set_func = s7_make_function(sc, internal_set_name, setter, set_req_args, set_opt_args, false, documentation); 
  /* typeflag(set_func) |= T_SAFE_PROCEDURE; */
  s7_define(sc, sc->NIL, make_symbol(sc, internal_set_name), set_func);
  c_function_setter(get_func) = set_func;

  return(get_func);
}
  

bool s7_is_procedure_with_setter(s7_pointer obj)
{
  return(((is_c_function(obj)) &&
	  (is_c_function(c_function_setter(obj)))) ||
	 (((is_closure(obj)) || 
	   (is_closure_star(obj))) &&
	  (is_procedure(closure_setter(obj)))));
}


s7_pointer s7_procedure_setter(s7_scheme *sc, s7_pointer obj)
{
  if (is_c_function(obj)) 
    return(c_function_setter(obj));

  return(closure_setter(obj));
}


s7_pointer s7_procedure_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter)
{
  /* setter can be #f to clear an old setting */
  if (is_c_function(obj))
    {
      c_function_setter(obj) = setter;
      if ((is_closure(setter)) ||
	  (is_closure_star(setter)))
	mark_function[type(obj)] = mark_c_proc;
    }
  else closure_setter(obj) = setter;
  return(setter);
}


static s7_pointer g_procedure_setter(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_setter "(procedure-setter obj) returns the setter associated with obj, or #f"
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_MACRO:
    case T_BACRO:
      /* macros are closures internally */
    case T_CLOSURE:
    case T_CLOSURE_STAR:
      return(closure_setter(p));

    case T_C_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
      return(c_function_setter(p));

    case T_C_MACRO:
      return(c_macro_setter(p));

    case T_GOTO:
    case T_CONTINUATION:
      return(sc->F);
    }

  return(s7_wrong_type_arg_error(sc, "procedure-setter", 0, p, "a procedure or a reasonable facsimile thereof"));
}


static s7_pointer g_procedure_set_setter(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, setter;

  p = car(args);
  if (!is_procedure_or_macro(p))
    return(s7_wrong_type_arg_error(sc, "set! procedure-setter procedure", 1, p, "a procedure"));

  setter = cadr(args);
  if ((setter != sc->F) &&
      (!is_procedure_or_macro(setter)))
    return(s7_wrong_type_arg_error(sc, "set! procedure-setter setter", 2, setter, "a procedure or #f"));

  /* should we check that p != setter?
   *
   * :(set! (procedure-setter <) <)
   * <
   * :(set! (< 3 2) 3)
   * #f
   * :(set! (< 1) 2)
   * #t
   *
   * can this make sense?
   */

  switch (type(p))
    {
    case T_MACRO:
    case T_BACRO:
    case T_CLOSURE:
    case T_CLOSURE_STAR:
      closure_setter(p) = setter;
      break;

    case T_C_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
      c_function_setter(p) = setter;
      if ((is_closure(setter)) ||
	  (is_closure_star(setter)))
	mark_function[type(p)] = mark_c_proc;
      break;

    case T_C_MACRO:
      if ((is_closure(setter)) ||
	  (is_closure_star(setter)))
	mark_function[T_C_MACRO] = mark_c_proc;
      c_macro_setter(p) = setter;
      break;

    case T_GOTO:
    case T_CONTINUATION:
      return(s7_wrong_type_arg_error(sc, "set! procedure-setter", 1, p, "a normal procedure (not a continuation)"));
    }

  return(setter);
}


void s7_define_function_with_setter(s7_scheme *sc, const char *name, s7_function get_fnc, s7_function set_fnc, int req_args, int opt_args, const char *doc)
{
  s7_make_procedure_with_setter(sc, name, get_fnc, req_args, opt_args, set_fnc, req_args + 1, opt_args, doc);
}


const char *s7_procedure_name(s7_scheme *sc, s7_pointer proc)
{
  int nlen = 0;
  switch (type(proc))
    {
    case T_CLOSURE:
    case T_CLOSURE_STAR:
      return(c_closure_name(sc, proc, &nlen));
  
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION:
      return(c_function_name(proc));

    case T_C_MACRO:
      return(c_macro_name(proc));

    case T_SYMBOL:
      {
	s7_pointer slot; 
	slot = find_symbol(sc, proc);           /* we don't want unbound-variable errors here */
	if ((is_slot(slot)) &&
	    (proc != slot_value(slot)) &&       /* (procedure-name :hi) -> infinite loop */
	    (is_procedure(slot_value(slot))))   /* a symbol -> symbol -> back to first?? */
	  return(s7_procedure_name(sc, slot_value(slot)));
	return(NULL);
      }

      /* T_MACRO et all don't have an easily accessible name -- I suppose we could
       *   search the current environment?
       */
    }
  return(NULL);
}


static s7_pointer g_procedure_name(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_name "(procedure-name proc) returns the name of the procedure or closure proc, if it can be found."
  s7_pointer p;
  p = car(args);
  if ((is_procedure_or_macro(p)) ||
      (is_symbol(p)))
    return(s7_make_string(sc, s7_procedure_name(sc, p)));
  return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_NAME, p, A_PROCEDURE));
}



/* -------------------------------- arity -------------------------------- */

s7_pointer s7_procedure_arity(s7_scheme *sc, s7_pointer x)
{
  if (is_c_function(x))
    return(list_3(sc, 
		  make_integer(sc, c_function_required_args(x)),
		  make_integer(sc, c_function_optional_args(x)),
		  make_boolean(sc, c_function_has_rest_arg(x))));
  /* this was optimized to be a permanent immutable list, but makes a mess of all the setters,
   *   and then there are cases like: (fill! (append (list 1) (procedure-arity abs)) 0)
   */

  if ((is_closure(x)) ||
      (is_closure_star(x)))
    {
      int len;
      
      if (is_pair(x))
	len = s7_list_length(sc, closure_args(x));
      else 
	{
	  if (is_symbol(closure_args(x)))
	    return(list_3(sc, small_int(0), small_int(0), sc->T));
	  len = s7_list_length(sc, closure_args(x));
	}

      if (is_closure_star(x))
	{
	  s7_pointer tmp;        /* make sure we aren't counting :optional and friends as arguments */
	  int opts = 0;

	  if (is_pair(x))
	    tmp = car(x);
	  else tmp = closure_args(x);

	  for (; is_pair(tmp); tmp = cdr(tmp))
	    {
	      if (car(tmp) == sc->KEY_ALLOW_OTHER_KEYS)
		opts++;
	      else
		{
		  if (car(tmp) == sc->KEY_REST)
		    {
		      opts += 2;     /* both :rest and the arg name are not counted as optional args */
		      if (len > 0) len = -len;
		    }
		}
	    }
	  return(list_3(sc, small_int(0), make_integer(sc, abs(len) - opts), make_boolean(sc, len < 0)));
	}

      return(list_3(sc, make_integer(sc, abs(len)), small_int(0), make_boolean(sc, len < 0)));
    }

  if (is_c_object(x))
    return(list_3(sc, 
		  make_integer(sc, c_object_min_args(x)),
		  (c_object_max_args(x) == MAX_ARITY) ? small_int(0) : make_integer(sc, c_object_max_args(x) - c_object_min_args(x)),
		  make_boolean(sc, c_object_max_args(x) == MAX_ARITY)));
  
  if ((is_continuation(x)) ||
      (is_goto(x)))
    return(list_3(sc, small_int(0), small_int(0), sc->T));

  return(sc->NIL);
}


static s7_pointer g_procedure_arity(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_arity "(procedure-arity func) returns a list describing func's arguments: '(required optional rest)"
  s7_pointer p;

  p = car(args);
  if (is_symbol(p))
    {
      p = s7_symbol_value(sc, p);
      if (p == sc->UNDEFINED)
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "procedure-arity arg, '~S, is unbound"), car(args))));
    }

  if (!is_procedure(p))
    return(simple_wrong_type_argument_with_type(sc, sc->PROCEDURE_ARITY, car(args), A_PROCEDURE));
  return(s7_procedure_arity(sc, p));
}


static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
{
  /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition
   */
  int len;

  if (is_symbol(x_args))                    /* any number of args is ok */
    return(s7_cons(sc, small_int(0), s7_make_integer(sc, MAX_ARITY)));
	
  if (closure_arity(x) == CLOSURE_ARITY_NOT_SET)
    closure_arity(x) = s7_list_length(sc, x_args);
  len = closure_arity(x);
  if (len < 0)                               /* dotted list => rest arg, (length '(a b . c)) is -2 */
    return(s7_cons(sc, s7_make_integer(sc, -len), s7_make_integer(sc, MAX_ARITY)));
  return(s7_cons(sc, s7_make_integer(sc, len), s7_make_integer(sc, len)));
}


static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
{
  if (is_symbol(x_args))
    return(s7_cons(sc, small_int(0), s7_make_integer(sc, MAX_ARITY)));

  if (closure_arity(x) == CLOSURE_ARITY_NOT_SET)
    {
      s7_pointer p;
      int i;
      for (i = 0, p = x_args; is_pair(p); p = cdr(p))
	{
	  s7_pointer arg;
	  arg = car(p);
	  if ((arg == sc->KEY_REST) ||
	      (arg == sc->KEY_ALLOW_OTHER_KEYS))
	    break;
	  i++;
	}
      if (is_null(p))
	closure_arity(x) = i;
      else closure_arity(x) = -1; /* see below */
    }

  if (closure_arity(x) == -1)
    return(s7_cons(sc, small_int(0), s7_make_integer(sc, MAX_ARITY)));
  return(s7_cons(sc, small_int(0), s7_make_integer(sc, closure_arity(x))));
}


static int closure_arity_to_int(s7_scheme *sc, s7_pointer x)
{
  /* not lambda* here */
  if (closure_arity(x) == CLOSURE_ARITY_NOT_SET)
    {
      int i;
      s7_pointer b;
      for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) {};
      if (is_null(b))
	closure_arity(x) = i;
      else closure_arity(x) = -i - 1;
    }
  return(closure_arity(x));
}


static int closure_star_arity_to_int(s7_scheme *sc, s7_pointer x)
{
  /* not lambda here */
  if (closure_arity(x) == CLOSURE_ARITY_NOT_SET)
    {
      s7_pointer p;
      int i;
      for (i = 0, p = closure_args(x); is_pair(p); p = cdr(p))
	{
	  s7_pointer arg;
	  arg = car(p);
	  if ((arg == sc->KEY_REST) ||
	      (arg == sc->KEY_ALLOW_OTHER_KEYS))
	    break;
	  i++;
	}
      if (is_null(p))
	closure_arity(x) = i;
      else closure_arity(x) = -1;
    }
  return(closure_arity(x));
}


static s7_pointer g_arity(s7_scheme *sc, s7_pointer args)
{
  #define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f."
  s7_pointer x;

  x = car(args);
  switch (type(x))
    {
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
    case T_C_FUNCTION:
      return(s7_cons(sc, s7_make_integer(sc, c_function_required_args(x)), s7_make_integer(sc, c_function_all_args(x))));

    case T_CLOSURE:
      return(closure_arity_to_cons(sc, x, closure_args(x)));

    case T_CLOSURE_STAR:
      return(closure_star_arity_to_cons(sc, x, closure_args(x)));

    case T_C_MACRO:
      return(s7_cons(sc, s7_make_integer(sc, c_macro_required_args(x)), s7_make_integer(sc, c_macro_all_args(x))));

    case T_MACRO:
    case T_BACRO:
      if (car(cadr(car(closure_body(x)))) == sc->LAMBDA)
	return(closure_arity_to_cons(sc, x, cadr(cadr(car(closure_body(x))))));
      return(closure_star_arity_to_cons(sc, x, cadr(cadr(car(closure_body(x))))));

    case T_GOTO:
    case T_CONTINUATION:
      return(s7_cons(sc, small_int(0), s7_make_integer(sc, MAX_ARITY)));

    case T_STRING:
      if (string_length(x) == 0)
	return(sc->F);

    case T_ENVIRONMENT:
      return(s7_cons(sc, small_int(1), small_int(1)));
      
    case T_C_OBJECT:
      if (is_procedure(x))
	return(s7_cons(sc, make_integer(sc, c_object_min_args(x)), make_integer(sc, c_object_max_args(x))));
      return(sc->F);

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      if (vector_length(x) == 0)
	return(sc->F);

    case T_PAIR:
    case T_HASH_TABLE:
      return(s7_cons(sc, small_int(1), s7_make_integer(sc, MAX_ARITY)));

    case T_SYNTAX:
      switch (syntax_opcode(x))
	{
	case OP_QUOTE:
	  return(s7_cons(sc, small_int(1), small_int(1)));
	  
	case OP_IF:
	  return(s7_cons(sc, small_int(2), small_int(3)));

	case OP_SET:
	  return(s7_cons(sc, small_int(3), small_int(3)));

	case OP_COND:
	case OP_WITH_ENV:
	  return(s7_cons(sc, small_int(1), s7_make_integer(sc, MAX_ARITY)));

	case OP_LET:
	case OP_LET_STAR:
	case OP_LETREC:
	case OP_CASE:
	case OP_LAMBDA:
	case OP_LAMBDA_STAR:
	case OP_DEFINE:
	case OP_DEFINE_STAR:
	case OP_DEFINE_CONSTANT:
	case OP_DEFINE_MACRO:
	case OP_DEFINE_MACRO_STAR:
	case OP_DEFINE_EXPANSION:
	case OP_DEFINE_BACRO:
	case OP_DEFINE_BACRO_STAR:
	  return(s7_cons(sc, small_int(2), s7_make_integer(sc, MAX_ARITY)));

	case OP_DO:
	case OP_DEFMACRO:
	case OP_DEFMACRO_STAR:
	  return(s7_cons(sc, small_int(3), s7_make_integer(sc, MAX_ARITY)));

	default:
	  return(s7_cons(sc, small_int(0), s7_make_integer(sc, MAX_ARITY)));
	}
    }

  return(sc->F);
}


static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int args)
{
  /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition
   */
  int len;
  if (is_symbol(x_args))                    /* any number of args is ok */
    return(true);
	
  len = closure_arity(x);
  if (len == CLOSURE_ARITY_NOT_SET)
    {
      len = s7_list_length(sc, x_args);
      closure_arity(x) = len;
    }
  if (len < 0)                               /* dotted list => rest arg, (length '(a b . c)) is -2 */
    return((-len) <= args);                  /*   so we have enough to take care of the required args */
  return(args == len);                       /* in a normal lambda list, there are no other possibilities */
}


static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int args)
{
  if (is_symbol(x_args))
    return(true);

  if (closure_arity(x) == CLOSURE_ARITY_NOT_SET)
    {
      /* The lambda* list can contain the pure noise words :key and :optional,
       *   :rest = any number ok, :allow-other-keywords = any number of key/value pairs
       * but all args are optional, so here arity reflects the max args possible, min is always 0.
       * arity = mx or -1
       */
      s7_pointer p;
      int i;
      for (i = 0, p = x_args; is_pair(p); p = cdr(p))
	{
	  s7_pointer arg;
	  arg = car(p);
	  if ((arg == sc->KEY_REST) ||
	      (arg == sc->KEY_ALLOW_OTHER_KEYS))
	    break;
	  i++;
	}
      if (is_null(p))
	closure_arity(x) = i;
      else closure_arity(x) = -1;
    }

  return((closure_arity(x) == -1) ||
	 (args <= closure_arity(x)));
}


bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args)
{
  switch (type(x))
    {
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
    case T_C_FUNCTION:
      return(((int)c_function_required_args(x) <= args) &&
	     ((int)c_function_all_args(x) >= args));

    case T_CLOSURE:
      return(closure_is_aritable(sc, x, closure_args(x), args));

    case T_CLOSURE_STAR:
      return(closure_star_is_aritable(sc, x, closure_args(x), args));

    case T_C_MACRO:
      return(((int)c_macro_required_args(x) <= args) &&
	     ((int)c_macro_all_args(x) >= args));

    case T_MACRO:
    case T_BACRO:
      /* we need to look at the embedded lambda to choose between closure and closure_star 
       *   closure_body here is of the form: ((apply (lambda (a b) ...) (cdr {defmac}-14)))
       *   so car is                          (apply (lambda (a b) ...) (cdr {defmac}-14))
       *      cadr(car) is                           (lambda (a b) ...)
       */
      if (car(cadr(car(closure_body(x)))) == sc->LAMBDA)
	return(closure_is_aritable(sc, x, cadr(cadr(car(closure_body(x)))), args));
      return(closure_star_is_aritable(sc, x, cadr(cadr(car(closure_body(x)))), args));

    case T_GOTO:
    case T_CONTINUATION:
      return(true);

    case T_STRING:
    case T_ENVIRONMENT:
      return(args == 1);
      
    case T_C_OBJECT:
      return((is_procedure(x)) &&
	     ((int)c_object_min_args(x) <= args) &&
	     ((int)c_object_max_args(x) >= args));

    case T_HASH_TABLE:
    case T_PAIR:
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(args > 0);

    case T_SYNTAX:
      switch (syntax_opcode(x))
	{
	case OP_QUOTE:
	  return(args == 1);
	  
	case OP_IF:
	  return((args == 2) || (args == 3));

	case OP_SET:
	  return(args == 3);

	case OP_COND:
	case OP_WITH_ENV:
	  return(args > 0);

	case OP_LET:
	case OP_LET_STAR:
	case OP_LETREC:
	case OP_CASE:
	case OP_LAMBDA:
	case OP_LAMBDA_STAR:
	case OP_DEFINE:
	case OP_DEFINE_STAR:
	case OP_DEFINE_CONSTANT:
	case OP_DEFINE_MACRO:
	case OP_DEFINE_MACRO_STAR:
	case OP_DEFINE_EXPANSION:
	case OP_DEFINE_BACRO:
	case OP_DEFINE_BACRO_STAR:
	  return(args > 1);

	case OP_DO:
	case OP_DEFMACRO:
	case OP_DEFMACRO_STAR:
	  return(args > 2);

	default:
	  return(true); /* and begin etc */
	}
    }
  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."
  s7_pointer n;
  s7_Int num;

  n = cadr(args);
  if (!s7_is_integer(n)) /* remember gmp case! */
    return(wrong_type_argument(sc, sc->ARITABLEP, small_int(2), n, T_INTEGER));

  num = s7_integer(n);
  if (num < 0)
    return(out_of_range(sc, sc->ARITABLEP, small_int(2), n, "should be a non-negative integer"));
  if (num > MAX_ARITY) num = MAX_ARITY;

  return(make_boolean(sc, s7_is_aritable(sc, car(args), (int)num)));
}


static s7_pointer is_aritable_ic;
static s7_pointer g_is_aritable_ic(s7_scheme *sc, s7_pointer args)
{
  return(make_boolean(sc, s7_is_aritable(sc, car(args), (int)integer(cadr(args)))));
}

static s7_pointer is_aritable_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (s7_is_integer(cadr(expr))) &&
      (s7_integer(cadr(expr)) < MAX_ARITY) &&
      (s7_integer(cadr(expr)) >= 0))
    return(is_aritable_ic);
  return(f);
}


static bool is_thunk(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_C_FUNCTION:
      return(c_function_all_args(x) == 0);

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      return(is_null(closure_args(x)));
    }
  return(false);
}


static bool is_thunkable(s7_scheme *sc, s7_pointer x)
{
  /* can be called with 0 args.
   *    don't use is_aritable here because this needs to be restricted to procedures
   */
  switch (type(x))
    {
    case T_C_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
      return(c_function_required_args(x) == 0);

    case T_CLOSURE:
      return(!(is_pair(closure_args(x))));
      
    case T_CLOSURE_STAR:
      return(true);
    }
  return(false);
}




/* -------------------------------- symbol-access ------------------------------------------------ */
/*
 * originally in Snd I wanted notification when a variable was set, and use it as a variable, not a procedure.
 *
 * these are in the same realm:
 *   typed var: restrict set! to the desired type or do auto-conversions
 *   constant: disallow set!
 *   traced var: report set!
 *   keywords: can't set or bind
 */


s7_pointer s7_symbol_access(s7_scheme *sc, s7_pointer sym)
{
  if (symbol_has_accessor(sym))
    return(s7_gc_protected_at(sc, symbol_accessor(sym)));
  return(sc->F);
}


s7_pointer s7_symbol_set_access(s7_scheme *sc, s7_pointer symbol, s7_pointer funcs)
{
  if (symbol_has_accessor(symbol))
    {
      if (is_immutable(s7_gc_protected_at(sc, symbol_accessor(symbol))))
	return(funcs); 

      s7_gc_unprotect_at(sc, symbol_accessor(symbol));
      symbol_accessor(symbol) = -1;
    }

  if (is_pair(funcs))
    {
      s7_pointer x;
      for (x = funcs; is_pair(x); x = cdr(x))
	if (car(x) != sc->F)                      /* if any field is not #f, reset symbol_accessor */
	  {
	    symbol_accessor(symbol) = s7_gc_protect(sc, funcs);
	    break;
	  }
    }
  return(funcs); /* or perhaps the new symbol-accessor? */
}


static s7_pointer g_symbol_get_access(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_access "(symbol-access sym) is a procedure that adds or removes controls on how a \
symbol accesses its current binding."

  if (!is_symbol(car(args)))
    return(simple_wrong_type_argument(sc, sc->SYMBOL_ACCESS, car(args), T_SYMBOL));
  return(s7_symbol_access(sc, car(args)));
}


static s7_pointer g_symbol_set_access(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym, funcs;
  sym = car(args);
  if (!is_symbol(sym))
    return(s7_wrong_type_arg_error(sc, "set! symbol-access", 1, sym, "a symbol"));

  funcs = cadr(args);
  if (funcs != sc->F)
    {
      if ((!is_pair(funcs)) ||
	  (s7_list_length(sc, funcs) < 3))
	return(s7_wrong_type_arg_error(sc, "set! symbol-access", 2, funcs, "a list of 3 or more items"));	
      if ((is_procedure(cadr(funcs))) && (!s7_is_aritable(sc, cadr(funcs), 2)))
	return(s7_wrong_type_arg_error(sc, "set! symbol-access set function", 2, cadr(funcs), "a procedure of 2 arguments"));	
      if ((is_procedure(caddr(funcs))) && (!s7_is_aritable(sc, caddr(funcs), 2)))
	return(s7_wrong_type_arg_error(sc, "set! symbol-access bind function", 2, caddr(funcs), "a procedure of 2 arguments"));	
    }
  return(s7_symbol_set_access(sc, sym, funcs));
}


static s7_pointer call_symbol_bind(s7_scheme *sc, s7_pointer symbol, s7_pointer new_value)
{
  s7_pointer func;
  func = caddr(s7_gc_protected_at(sc, symbol_accessor(symbol)));
  if (is_procedure(func))
    {
      s7_pointer old_value;
      old_value = new_value;

      /* this happens in contexts that are tricky to implement with a clean use of the evaluator stack (as in
       *   the parallel symbol set case), so we need to use s7_call.  But if an uncaught error
       *   occurs in s7_call, the error handler marches up the stack looking for a catch, unwinding the stack
       *   past the point of the call.  In the worst case, we can segfault because any subsequent pop_stack
       *   (i.e. an unchecked goto START), walks off the start of the stack. 
       */
      
      if (is_c_function(func))
	{
	  car(sc->T2_1) = symbol;
	  car(sc->T2_2) = new_value;
      	  new_value = c_function_call(func)(sc, sc->T2_1);
	}
      else
	{
	  bool old_off;
	  old_off = sc->gc_off;
	  sc->gc_off = true;
	  new_value = s7_apply_function(sc, func, list_2(sc, symbol, new_value));
	  sc->gc_off = old_off;
	}
      if (new_value == sc->ERROR)
	return(s7_error(sc, sc->ERROR,
			list_3(sc, make_protected_string(sc, "can't bind ~S to ~S"), symbol, old_value)));
    }
  return(new_value);
}


static s7_pointer bind_accessed_symbol(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value)
{
  s7_pointer func;
  func = caddr(s7_gc_protected_at(sc, symbol_accessor(symbol)));
  if (is_procedure(func))
    {
      if (is_c_function(func))
	{
	  s7_pointer old_value;
	  old_value = new_value;
	  car(sc->T2_1) = symbol;
	  car(sc->T2_2) = new_value;
	  new_value = c_function_call(func)(sc, sc->T2_1);
	  if (new_value == sc->ERROR)
	    return(s7_error(sc, sc->ERROR,
			    list_3(sc, make_protected_string(sc, "can't bind ~S to ~S"), symbol, old_value)));
	}
      else
	{
	  sc->args = list_2(sc, symbol, new_value);
	  push_stack(sc, op, sc->args, sc->code);
	  sc->code = func;
	  return(sc->NO_VALUE);
	}
    }
  return(new_value);
}

static s7_pointer find_safe_do_symbol_or_bust(s7_scheme *sc, s7_pointer sym);

static void set_safe_do_level(s7_scheme *sc, int new_val)
{
  if (new_val < -10)
    finder = find_safe_do_symbol_or_bust; 
  /* this never happens of course, but by including this crazy code, we get about 10% speed up overall in gcc 4.4 and 4.7 */
  else finder = find_symbol_or_bust;
}



/* -------------------------------- hooks -------------------------------- */

s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook)
{
  return(s7_symbol_local_value(sc, sc->BODY, closure_environment(hook)));
}


s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions)
{
  if (s7_is_list(sc, functions))
    s7_environment_set(sc, closure_environment(hook), sc->BODY, functions);
  return(functions);
}




/* -------------------------------- eq etc -------------------------------- */

bool s7_is_eq(s7_pointer obj1, s7_pointer obj2)
{
  return(obj1 == obj2); /* so floats and NaNs might be eq? but not eqv? */
}


bool s7_is_eqv(s7_pointer a, s7_pointer b) 
{
  if ((a == b) && (!is_number(a)))
    return(true);
  
#if WITH_GMP
  if (big_numbers_are_eqv(a, b))
    return(true);                                     /* T_INTEGER != T_BIG_INTEGER etc */
#endif

  if (type(a) != type(b)) 
    return(false);
  
  if (is_string(a)) 
    return(string_value(a) == string_value(b));
  
  if (s7_is_number(a))
    return(numbers_are_eqv(a, b));
  
  if ((has_no_value(a)) && (has_no_value(b)))
    return(true);

  return(false);
}


/* -------- structure equality -------- 
 *
 * equal? examines the entire structure (possibly a tree etc), which might contain
 *   cycles (vector element is the vector etc), so list/vector/hash-table equality
 *   needs to carry along a list of pointers seen so far.
 */

static bool structures_are_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci);

static bool s7_is_equal_tracking_circles(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  if ((x == y) && (!is_number(x))) /* this needs to be just like the g_is_equal outer test: (equal? '(1/0) '(1/0)) */
    return(true);
  
#if WITH_GMP
  if (big_numbers_are_eqv(x, y))
    return(true);
#endif

  if (type(x) != type(y)) 
    return(false);
  
  switch (type(x))
    {
    case T_STRING:
      return(scheme_strings_are_equal(x, y));

    case T_C_OBJECT:
      return(objects_are_equal(sc, x, y));

    case T_INTEGER:
    case T_RATIO:
    case T_REAL:
    case T_COMPLEX:
      return(numbers_are_eqv(x, y));

    case T_COUNTER:
      return(counter_count(x) == counter_count(y)); /* ?? not in s7_is_equal because it only occurs in a structure?? */

    case T_ENVIRONMENT:
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
    case T_HASH_TABLE:
    case T_PAIR:
      return(structures_are_equal(sc, x, y, ci));

    case T_C_POINTER:       /* might have a list of these for example */
      return(raw_pointer(x) == raw_pointer(y));
    }

  return(false); /* we already checked that x != y (port etc) */
}


static bool hash_tables_are_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  s7_pointer *lists;
  int i, len;

  if (hash_table_entries(x) != hash_table_entries(y))
    return(false);
  if (hash_table_entries(x) == 0)
    return(true);
  if (hash_table_function(x) != hash_table_function(y))
    return(false);
  if (hash_table_eq_function(x) != hash_table_eq_function(y))
    return(false);

  len = hash_table_length(x);
  lists = hash_table_elements(x);

  for (i = 0; i < len; i++)
    {
      s7_pointer p;
      for (p = lists[i]; is_not_null(p); p = cdr(p))
	{
	  s7_pointer key, x_val, y_val;

	  key = caar(p);
	  x_val = cdar(p);
	  y_val = (*hash_table_function(y))(sc, y, key);

	  if (is_null(y_val))
	    return(false);
	  if (!s7_is_equal_tracking_circles(sc, x_val, cdr(y_val), ci))
	    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??
   */

  return(true);
}


static bool structures_are_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  /* here we know x and y are pointers to the same type of structure */
  int ref_x, ref_y;

  if (ci)
    {
      ref_x = peek_shared_ref(ci, x);
      ref_y = peek_shared_ref(ci, y);

      if ((ref_x != 0) && (ref_y != 0))
	return(ref_x == ref_y);
  
      if ((ref_x != 0) || (ref_y != 0))
	{
	  /* 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 add_shared_ref(ci, x, ref_y);
	}
      else add_equal_ref(ci, x, y);
    }

  /* now compare the elements of the structures. */
  switch (type(x))
    {
    case T_PAIR:
      return((s7_is_equal_tracking_circles(sc, car(x), car(y), ci)) &&
	     (s7_is_equal_tracking_circles(sc, cdr(x), cdr(y), ci)));

    case T_HASH_TABLE:
      return(hash_tables_are_equal(sc, x, y, ci));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      {
	s7_Int i, len;
	int x_dims = 1, y_dims = 1, j;

	len = vector_length(x);
	if (len != vector_length(y)) return(false);

	/* there's one special case: shared vectors can have 1 dimension but include the dimension info */
	if (vector_is_multidimensional(x))
	  x_dims = vector_ndims(x);
	if (vector_is_multidimensional(y))
	  y_dims = vector_ndims(y);
	    
	if (x_dims != y_dims)
	  return(false);
	    
	if (x_dims > 1)
	  for (j = 0; j < x_dims; j++)
	    if (vector_dimension(x, j) != vector_dimension(y, j))
	      return(false);

	if (is_int_vector(x))
	  {
	    for (i = 0; i < len; i++)
	      if (int_vector_element(x, i) != int_vector_element(y, i))
		return(false);
	    return(true);
	  }

	if (is_float_vector(x))
	  {
	    s7_Double z;
	    for (i = 0; i < len; i++)
	      {
		z = float_vector_element(x, i);
		if ((is_NaN(z)) ||
		    (z != float_vector_element(y, i)))
		  return(false);
	      }
	    return(true);
	  }

	for (i = 0; i < len; i++)
	  if (!(s7_is_equal_tracking_circles(sc, vector_element(x, i), vector_element(y, i), ci)))
	    return(false);
	return(true);
      }

    case T_ENVIRONMENT:
      {
	/*
	  (let ((e1 #f) (e2 #f))
	    (let ((a 1)) (set! e1 (current-environment)))
            (let ((a 1)) (set! e2 (current-environment))) 
            (equal? e1 e2))
	*/
	s7_pointer ex, ey;

	for (ex = x, ey = y; is_environment(ex) && is_environment(ey); ex = next_environment(ex), ey = next_environment(ey))
	  {
	    s7_pointer px, py;

	    if (ex == ey)
	      return(true);

	    if ((ex == sc->global_env) ||
		(ey == sc->global_env))
	      return(false);

	    /* currently order matters, unlike hash-tables */
	    for (px = environment_slots(ex), py = environment_slots(ey); is_slot(px) && is_slot(py); px = next_slot(px), py = next_slot(py))
	      if ((slot_symbol(px) != slot_symbol(py)) ||
		  (!(s7_is_equal_tracking_circles(sc, slot_value(px), slot_value(py), ci))))
		return(false);

	    if ((is_slot(px)) ||
		(is_slot(py)))
	      return(false);
	  }
	if ((is_environment(ex)) ||
	    (is_environment(ey)))
	  return(false);

	return(true);
      }
    }
  return(true);
}


bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if ((x == y) && (!is_number(x)))  /* (equal? 1/0 1/0) should be #f */
    return(true);

#if WITH_GMP
  if (big_numbers_are_eqv(x, y))
    return(true);
#endif

  if (type(x) != type(y)) 
    return(false);
  
  switch (type(x))
    {
    case T_UNIQUE: 
      /* we checked x == y above, and know x and y are T_UNIQUE
       */
      if (x == sc->UNSPECIFIED) return(y == sc->NO_VALUE);
      if (x == sc->NO_VALUE) return(y == sc->UNSPECIFIED);
      return(false);

    case T_STRING:
      return(scheme_strings_are_equal(x, y));

    case T_C_OBJECT:
      return(objects_are_equal(sc, x, y));

    case T_INTEGER:
    case T_RATIO:
    case T_REAL:
    case T_COMPLEX:
      return(numbers_are_eqv(x, y));

    case T_SYNTAX:
      return(slot_symbol(global_slot(x)) == slot_symbol(global_slot(y)));

    case T_ENVIRONMENT:
      if (has_methods(x))
	{
	  if (has_methods(y))
	    {
	      s7_pointer equal_func;
	      equal_func = find_method(sc, x, sc->EQUALP);
	      if (equal_func != sc->UNDEFINED)
		return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
	    }
	  else return(false);
	}
      return(structures_are_equal(sc, x, y, new_shared_info(sc)));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if ((has_methods(x)) &&
	  (has_methods(y)))
	{
	  s7_pointer equal_func;
	  equal_func = find_method(sc, closure_environment(x), sc->EQUALP);
	  if (equal_func != sc->UNDEFINED)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
	}
      return(false);

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return((vector_length(x) == vector_length(y)) &&
	     (structures_are_equal(sc, x, y, (type(x) == T_VECTOR) ? new_shared_info(sc) : NULL)));

    case T_HASH_TABLE:
      return(hash_tables_are_equal(sc, x, y, new_shared_info(sc)));

    case T_PAIR:
#if (!WITH_GMP)
      return((type(car(x)) == type(car(y))) &&
	     (structures_are_equal(sc, x, y, new_shared_info(sc))));
#else
      return(structures_are_equal(sc, x, y, new_shared_info(sc)));
#endif

    case T_C_POINTER:
      return(raw_pointer(x) == raw_pointer(y));
    }
  return(false); /* we already checked that x != y (port etc) */
}


static s7_pointer g_booleans_are_eq(s7_scheme *sc, s7_pointer args)
{
  #define H_booleans_are_eq "(eq? bool1 bool2 ...) returns #t if all args are either all #f or all #t."
  s7_pointer p, x;

  x = car(args);
  if (!s7_is_boolean(x))
    return(sc->F);

  for (p = cdr(args); is_pair(p); p = cdr(p))
    if (car(p) != x)
      return(sc->F);
  return(sc->T);
}


static s7_pointer g_symbols_are_eq(s7_scheme *sc, s7_pointer args)
{
  #define H_symbols_are_eq "(eq? sym1 sym2 ...) returns #t if all args are the same symbol."
  s7_pointer p, x;

  x = car(args);
  if (!is_symbol(x))
    return(sc->F);

  for (p = cdr(args); is_pair(p); p = cdr(p))
    if (car(p) != x)
      return(sc->F);
  return(sc->T);
}


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"
  return(make_boolean(sc, ((car(args) == cadr(args)) ||
			   ((has_no_value(car(args))) && (has_no_value(cadr(args)))))));
  /* (eq? (apply apply apply values '(())) #<unspecified>) should return #t
   */
}


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"
  return(make_boolean(sc, s7_is_eqv(car(args), cadr(args))));
}


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"
  return(make_boolean(sc, s7_is_equal(sc, car(args), cadr(args))));
}


static bool hash_tables_are_morally_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  s7_pointer *lists;
  int i, len;

  if (hash_table_entries(x) != hash_table_entries(y))
    return(false);
  if (hash_table_entries(x) == 0)
    return(true);
  /* can't precheck the function here (2 != 2.0) */

  len = hash_table_length(x);
  lists = hash_table_elements(x);

  for (i = 0; i < len; i++)
    {
      s7_pointer p;
      for (p = lists[i]; is_not_null(p); p = cdr(p))
	{
	  s7_pointer key, x_val, y_val;

	  key = caar(p);
	  x_val = cdar(p);
	  y_val = (*hash_table_function(y))(sc, y, key);

	  if (is_null(y_val))
	    return(false);
	  if (!s7_is_morally_equal_1(sc, x_val, cdr(y_val), ci))
	    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??
   */

  return(true);
}


#define FLOATING_EPSILON 1e-15

static bool floats_are_morally_equal(s7_Double x, s7_Double y)
{
  if (is_NaN(x))
    return(is_NaN(y));

  return((!is_NaN(y)) &&
	 ((x == y) ||
	  (fabs(x - y) <= FLOATING_EPSILON)));
}

/* TODO: (morally-equal? (make-vector 3 0 #t) (make-vector 3 0)) -> #f
 *   but perhaps it should be #t?
 */

static bool structures_are_morally_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  /* here we know x and y are pointers to the same type of structure */
  int ref_x, ref_y;

  ref_x = peek_shared_ref(ci, x);
  ref_y = peek_shared_ref(ci, y);

  if ((ref_x != 0) && (ref_y != 0))
    return(ref_x == ref_y);
  
  if ((ref_x != 0) || (ref_y != 0))
    {
      /* 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 add_shared_ref(ci, x, ref_y);
    }
  else add_equal_ref(ci, x, y);
  
  /* now compare the elements of the structures. */
  switch (type(x))
    {
    case T_PAIR:
      return((s7_is_morally_equal_1(sc, car(x), car(y), ci)) &&
	     (s7_is_morally_equal_1(sc, cdr(x), cdr(y), ci)));

    case T_HASH_TABLE:
      return(hash_tables_are_morally_equal(sc, x, y, ci));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      {
	s7_Int i, len;
	int x_dims = 1, y_dims = 1, j;

	len = vector_length(x);
	if (len != vector_length(y)) return(false);
	if (len == 0) return(true);

	if (vector_is_multidimensional(x))
	  x_dims = vector_ndims(x);
	if (vector_is_multidimensional(y))
	  y_dims = vector_ndims(y);
	    
	if (x_dims != y_dims)
	  return(false);
	    
	if (x_dims > 1)
	  for (j = 0; j < x_dims; j++)
	    if (vector_dimension(x, j) != vector_dimension(y, j))
	      return(false);

	if (is_int_vector(x))
	  {
	    for (i = 0; i < len; i++)
	      if (int_vector_element(x, i) != int_vector_element(y, i))
		return(false);
	    return(true);
	  }
	if (is_float_vector(x))
	  {
	    for (i = 0; i < len; i++)
	      if (!floats_are_morally_equal(float_vector_element(x, i), int_vector_element(y, i)))
		return(false);
	    return(true);
	  }

	for (i = 0; i < len; i++)
	  if (!(s7_is_morally_equal_1(sc, vector_element(x, i), vector_element(y, i), ci)))
	    return(false);
	return(true);
      }

    case T_ENVIRONMENT:
      {
	/*
	  (let ((e1 #f) (e2 #f))
	    (let ((a 1)) (set! e1 (current-environment)))
            (let ((a 1)) (set! e2 (current-environment))) 
            (equal? e1 e2))
	*/
	s7_pointer ex, ey;
	for (ex = x, ey = y; is_environment(ex) && is_environment(ey); ex = next_environment(ex), ey = next_environment(ey))
	  {
	    s7_pointer px, py;
	    if (ex == ey)
	      return(true);
	    if ((ex == sc->global_env) ||
		(ey == sc->global_env))
	      return(false);
	    /* currently order matters, unlike hash-tables */
	    for (px = environment_slots(ex), py = environment_slots(ey); is_slot(px) && is_slot(py); px = next_slot(px), py = next_slot(py))
	      if ((slot_symbol(px) != slot_symbol(py)) ||
		  (!(s7_is_morally_equal_1(sc, slot_value(px), slot_value(py), ci))))
		return(false);
	    if ((is_slot(px)) ||
		(is_slot(py)))
	      return(false);
	  }
	if ((is_environment(ex)) ||
	    (is_environment(ey)))
	  return(false);
	return(true);
      }
    }
  return(true);
}


static bool s7_is_morally_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
  if (x == y) 
    return(true);

  if ((type(x) != type(y)) &&
      (!is_number(x)) && 
      (!is_big_number(x)))
    return(false);

  switch (type(x))
    {
    case T_UNIQUE: 
      /* we checked x == y above, and know x and y are T_UNIQUE
       */
      if (x == sc->UNSPECIFIED) return(y == sc->NO_VALUE);
      if (x == sc->NO_VALUE) return(y == sc->UNSPECIFIED);
      return(false);

    case T_STRING:
      return(scheme_strings_are_equal(x, y));

    case T_C_OBJECT:
      return(objects_are_equal(sc, x, y)); /* perhaps a slot for this? */

    case T_C_POINTER:
      return(raw_pointer(x) == raw_pointer(y));

    case T_INPUT_PORT:
      return((port_is_closed(x)) &&     /* closed ports of same type are morally equal */
	     (port_type(x) == port_type(y)) &&
	     (port_is_closed(y)));
  
    case T_OUTPUT_PORT:
      return((port_is_closed(x)) &&
	     (port_type(x) == port_type(y)) &&
	     (port_is_closed(y)));

    case T_HASH_TABLE:
      return(hash_tables_are_morally_equal(sc, x, y, (ci) ? ci : new_shared_info(sc))); 

    case T_ENVIRONMENT:
      if (has_methods(x))
	{
	  if (has_methods(y))
	    {
	      s7_pointer equal_func;
	      equal_func = find_method(sc, x, sc->MORALLY_EQUALP);
	      if (equal_func != sc->UNDEFINED)
		return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
	    }
	  else return(false);
	}
      /* if the environment contains a function whose environment is the current environment, infinite loop?
       *    so we pass the ci arg in the macro/function cases below
       */
      return(structures_are_morally_equal(sc, x, y, (ci) ? ci : new_shared_info(sc)));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      if (vector_length(x) == vector_length(y))
	{
	  if (vector_length(x) == 0)   /* all empty vectors are morally equal */
	    return(true);
	  return(structures_are_morally_equal(sc, x, y, (ci) ? ci : ((type(x) == T_VECTOR) ? new_shared_info(sc) : NULL)));
	}
      return(false);

    case T_PAIR:
      return(structures_are_morally_equal(sc, x, y, (ci) ? ci : new_shared_info(sc)));

#if WITH_GMP
      /* not sure how to handle these cases -- what should the "float-epsilon" be?
       */
    case T_BIG_INTEGER:
    case T_BIG_RATIO:
    case T_BIG_REAL:
    case T_BIG_COMPLEX:
      return(big_equal(sc, list_2(sc, x, y)) != sc->F);
#endif

    case T_INTEGER:
      switch (type(y))
	{
#if WITH_GMP
	case T_BIG_INTEGER:
	case T_BIG_REAL:
	case T_BIG_COMPLEX:
	case T_BIG_RATIO:
	  return(big_equal(sc, list_2(sc, x, y)) != sc->F);
#endif
	  
	case T_INTEGER:
	  return(integer(x) == integer(y));

	case T_RATIO:
	  return(fabs(integer(x) - fraction(y)) <= FLOATING_EPSILON);

	case T_REAL:
	  return((!is_NaN(real(y))) &&
		 (fabs(integer(x) - real(y)) <= FLOATING_EPSILON));

	case T_COMPLEX:
	  return((!is_NaN(real_part(y))) &&
		 (!is_NaN(imag_part(y))) &&
		 (fabs(integer(x) - real_part(y)) <= FLOATING_EPSILON) &&
		 (fabs(imag_part(y)) <= FLOATING_EPSILON));

	default:
	  return(false);
	}

    case T_RATIO:
      switch (type(y))
	{
#if WITH_GMP
	case T_BIG_INTEGER:
	case T_BIG_REAL:
	case T_BIG_COMPLEX:
	case T_BIG_RATIO:
	  return(big_equal(sc, list_2(sc, x, y)) != sc->F);
#endif
	  
	case T_INTEGER:
	  return(fabs(fraction(x) - integer(y)) <= FLOATING_EPSILON);

	case T_RATIO:
	  return(fabs(fraction(x) - fraction(y)) <= FLOATING_EPSILON);

	case T_REAL:
	  return(floats_are_morally_equal(fraction(x), real(y)));

	case T_COMPLEX:
	  return((!is_NaN(real_part(y))) &&
		 (!is_NaN(imag_part(y))) &&
		 (fabs(fraction(x) - real_part(y)) <= FLOATING_EPSILON) &&
		 (fabs(imag_part(y)) <= FLOATING_EPSILON));

	default:
	  return(false);
	}

    case T_REAL:
      switch (type(y))
	{
#if WITH_GMP
	case T_BIG_INTEGER:
	case T_BIG_REAL:
	case T_BIG_COMPLEX:
	case T_BIG_RATIO:
	  return(big_equal(sc, list_2(sc, x, y)) != sc->F);
#endif
	  
	case T_INTEGER:
	  return((!is_NaN(real(x))) &&
		 (fabs(real(x) - integer(y)) <= FLOATING_EPSILON));

	case T_RATIO:
	  return((!is_NaN(real(x))) &&
		 (fabs(real(x) - fraction(y)) <= FLOATING_EPSILON));

	case T_REAL:
	  return(floats_are_morally_equal(real(x), real(y)));

	case T_COMPLEX:
	  if (is_NaN(real(x)))
	    return((is_NaN(real_part(y))) &&
		   (fabs(imag_part(y)) <= FLOATING_EPSILON));

	  return((!is_NaN(real(x))) &&
		 (!is_NaN(real_part(y))) &&
		 (!is_NaN(imag_part(y))) &&
		 ((real(x) == real_part(y)) ||
		  (fabs(real(x) - real_part(y)) <= FLOATING_EPSILON)) &&
		 (fabs(imag_part(y)) <= FLOATING_EPSILON));

	default:
	  return(false);
	}

    case T_COMPLEX:
      switch (type(y))
	{
#if WITH_GMP
	case T_BIG_INTEGER:
	case T_BIG_REAL:
	case T_BIG_COMPLEX:
	case T_BIG_RATIO:
	  return(big_equal(sc, list_2(sc, x, y)) != sc->F);
#endif
	  
	case T_INTEGER:
	  return((!is_NaN(real_part(x))) &&
		 (!is_NaN(imag_part(x))) &&
		 (fabs(real_part(x) - integer(y)) <= FLOATING_EPSILON) &&
		 (fabs(imag_part(x)) <= FLOATING_EPSILON));

	case T_RATIO:
	  return((!is_NaN(real_part(x))) &&
		 (!is_NaN(imag_part(x))) &&
		 (fabs(real_part(x) - fraction(y)) <= FLOATING_EPSILON) &&
		 (fabs(imag_part(x)) <= FLOATING_EPSILON));

	case T_REAL:
	  if ((is_NaN(real_part(x))) ||
	      (is_NaN(imag_part(x))) ||
	      (is_NaN(real(y))))
	    return(false);
	  return(((real_part(x) == real(y)) ||
		  (fabs(real_part(x) - real(y)) <= FLOATING_EPSILON)) &&
		 (fabs(imag_part(x)) <= FLOATING_EPSILON));

	case T_COMPLEX:
	  if (is_NaN(real_part(x)))
	    return((is_NaN(real_part(y))) &&
		   (((is_NaN(imag_part(x))) && (is_NaN(imag_part(y)))) ||
		    (imag_part(x) == imag_part(y)) ||
		    (fabs(imag_part(x) - imag_part(y)) <= FLOATING_EPSILON)));

	  if (is_NaN(imag_part(x)))
	    return((is_NaN(imag_part(y))) &&
		   ((real_part(x) == real_part(y)) ||
		    (fabs(real_part(x) - real_part(y)) <= FLOATING_EPSILON)));
		   
	  if ((is_NaN(real_part(y))) ||
	      (is_NaN(imag_part(y))))
	    return(false);

	  return(((real_part(x) == real_part(y)) ||
		  (fabs(real_part(x) - real_part(y)) <= FLOATING_EPSILON)) &&
		 ((imag_part(x) == imag_part(y)) ||
		  (fabs(imag_part(x) - imag_part(y)) <= FLOATING_EPSILON)));

	default:
	  return(false);
	}

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (type(x) != type(y))
	return(false);
      if ((has_methods(x)) &&
	  (has_methods(y)))
	{
	  s7_pointer equal_func;
	  equal_func = find_method(sc, closure_environment(x), sc->MORALLY_EQUALP);
	  if (equal_func != sc->UNDEFINED)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
	}
      return((s7_is_morally_equal_1(sc, closure_args(x), closure_args(y), ci)) &&
	     (s7_is_morally_equal_1(sc, closure_environment(x), closure_environment(y), ci)) &&
	     (s7_is_morally_equal_1(sc, closure_body(x), closure_body(y), ci)));

    case T_MACRO:
    case T_BACRO:
      /* these are hard to check because the body has the gensymmed arg name
       *
       * args:   ({defmac}-16) 
       *         ({defmac}-17)
       * bodies: ((apply (lambda (a) ({list} '+ 1 a)) (cdr {defmac}-16))) 
       *         ((apply (lambda (a) ({list} '+ 1 a)) (cdr {defmac}-17)))
       * 
       * the "args" and "body" are not relevant: we create these shells internally, so the true args are in the applied lambda
       * so ignore args, and check (cadr (car body)) => (lambda (a) ({list} '+ 1 a))
       *
       * if the "ci" arg is omitted, this hangs:
       *    (morally-equal? 
       *      (let () 
       *        (define-macro* (a_func (an_arg (lambda () #t))) 
       *          `,an_arg) 
       *        (a_func)) 
       *      (let () 
       *        (define-macro (a_func an_arg) 
       *          `,an_arg) 
       *        (a_func (lambda () #t))))
       */
      return((type(y) == type(x)) &&
	     (s7_is_morally_equal_1(sc, closure_environment(x), closure_environment(y), ci)) &&
	     (s7_is_morally_equal_1(sc, cadr(car(closure_body(x))), cadr(car(closure_body(y))), ci)));

    }
  return(false);
}


static s7_pointer g_is_morally_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_is_morally_equal "(morally-equal? obj1 obj2) returns #t if obj1 is close enough to obj2."
  return(make_boolean(sc, s7_is_morally_equal_1(sc, car(args), cadr(args), NULL)));
}




/* ---------------------------------------- length, copy, fill ---------------------------------------- */

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, 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."

  s7_pointer lst;
  lst = car(args);

  switch (type(lst))
    {
    case T_PAIR:
      {
	int len;
	len = s7_list_length(sc, lst);
	/* len < 0 -> dotted and (abs len) is length not counting the final cdr
	 * len == 0, circular so length is infinite
	 */
	if (len == 0)
	  return(make_real(sc, INFINITY));
	return(make_integer(sc, len));
      }

    case T_NIL:
      return(small_int(0));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(make_integer(sc, vector_length(lst)));

    case T_STRING:
      return(make_integer(sc, string_length(lst)));

    case T_HASH_TABLE:
      return(make_integer(sc, hash_table_length(lst)));

    case T_C_OBJECT:
      return(object_length(sc, lst));

    case T_ENVIRONMENT:
      return(make_integer(sc, environment_length(sc, lst)));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(lst))
	return(make_integer(sc, closure_length(sc, lst)));

    default:
      return(simple_wrong_type_argument_with_type(sc, sc->LENGTH, lst, make_protected_string(sc, "a list, vector, string, or hash-table")));
    }
  
  return(small_int(0));
}

/* what about (length file)?  input port, read_file gets the file length, so perhaps save it
 *   but we're actually looking at the port, so its length is what remains to be read? (if input port)
 */


s7_pointer s7_copy(s7_scheme *sc, s7_pointer obj)
{
  switch (type(obj))
    {
    case T_STRING:
      {
	s7_pointer ns;
	ns = s7_make_string_with_length(sc, string_value(obj), string_length(obj));
	if (is_bytevector(obj))
	  set_bytevector(ns);
	return(ns);
      }

    case T_C_OBJECT:
      return(object_copy(sc, obj));

    case T_HASH_TABLE:              /* this has to copy nearly everything */
      return(hash_table_copy(sc, obj));
      
    case T_ENVIRONMENT:             /* this copies only the local env and points to outer envs */
      return(environment_copy(sc, obj));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      CHECK_METHOD(sc, obj, sc->COPY, list_1(sc, obj));
      return(obj);

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(s7_vector_copy(sc, obj)); /* "shallow" copy */

    case T_PAIR:                    /* top level only, as in the other cases, last arg checks for circles */
      return(cons(sc, car(obj), list_copy(sc, cdr(obj), obj, true))); 

#if WITH_GMP
    case T_BIG_INTEGER:
      return(mpz_to_big_integer(sc, big_integer(obj)));

    case T_BIG_RATIO:
      return(mpq_to_big_ratio(sc, big_ratio(obj)));

    case T_BIG_REAL:
      return(mpfr_to_big_real(sc, big_real(obj)));

    case T_BIG_COMPLEX:
      return(mpc_to_big_complex(sc, big_complex(obj)));
#endif
    }
  return(obj);
}


/* an experiment */

static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_Int loc, s7_pointer val) 
{
  if (s7_is_character(val))
    {
      string_value(str)[loc] = s7_character(val); 
      return(val);
    }
  return(wrong_type_argument(sc, sc->STRING_SET, small_int(3), val, T_CHARACTER));
}

static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_Int loc) 
{
  return(s7_make_character(sc, (unsigned char)(string_value(str)[loc]))); /* cast needed else (copy (string (integer->char 255))...) is trouble */
}

static s7_pointer list_setter(s7_scheme *sc, s7_pointer lst, s7_Int loc, s7_pointer val)
{
  int i;
  s7_pointer p;
  for (p = lst, i = 0; i < loc; i++, p = cdr(p));
  car(p) = val;
  return(val);
}

static s7_pointer list_getter(s7_scheme *sc, s7_pointer lst, s7_Int loc) 
{
  int i;
  s7_pointer p;
  for (p = lst, i = 0; i < loc; i++, p = cdr(p));
  return(car(p));
}

static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_Int loc, s7_pointer val)
{
  if ((c_object_has_array(obj)) &&
      (is_real(val)))
    {
      c_object_array(obj)[loc] = s7_number_to_real(sc, val);
      return(val);
    }

  if (c_object_set_3(obj))
    return((*(c_object_set_3(obj)))(sc, c_object_value(obj), make_integer(sc, loc), val));

  car(sc->T2_1) = make_integer(sc, loc);
  car(sc->T2_2) = val;
  return((*(c_object_set(obj)))(sc, obj, sc->T2_1));
} 

static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_Int loc)
{
  if (c_object_has_array(obj))
    return(make_real(sc, c_object_array(obj)[loc]));

  if (c_object_ref_2(obj))
    return((*(c_object_ref_2(obj)))(sc, c_object_value(obj), make_integer(sc, loc)));
  
  car(sc->T1_1) = make_integer(sc, loc);
  return((*(c_object_ref(obj)))(sc, obj, sc->T1_1));
}


/* hash_table? -- not so good because what is the key? 
 * environment? -- same problem here -- what is the symbol?
 *   it might make sense to support env/ht -> vector/list but then you'd expect the reverse to work as well (ambiguous?)
 */

static s7_pointer g_copy(s7_scheme *sc, 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 COPY_CIRCLE_LEN 2147483641
  s7_pointer source, dest;
  s7_Int i, j, dest_len, start = 0, end, source_len;
  s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_Int loc, s7_pointer val);
  s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_Int loc);
  bool have_indices;

  if (is_null(cdr(args)))                /* (copy obj) -- this works for environments, hash-tables and bignums */
    return(s7_copy(sc, car(args)));
  have_indices = (is_pair(cddr(args)));

  /* (do ((i 0 (+ i 1))) ((= i (min (length src) (length dest))) dest) (set! (dest i) (src i)))
   */

  source = car(args);
  dest = cadr(args);
  if ((source == dest) && (!have_indices))
    return(dest);

  switch (type(source))
    {
    case T_PAIR:     
      get = list_getter;     
      end = s7_list_length(sc, source); 
      if (end == 0) end = COPY_CIRCLE_LEN; /* end == 0 -> circular */
      if (end < 0) end = -end; 
      break; 

    case T_INT_VECTOR:   
    case T_FLOAT_VECTOR: 
    case T_VECTOR:       get = vector_getter(source); end = vector_length(source);            break;
    case T_STRING:       get = string_getter;         end = string_length(source);            break;
    case T_C_OBJECT:     get = c_object_getter;       end = object_length_to_int(sc, source); break;
    default: 
      if (!is_null(cddr(args))) /* (copy () () ()) */
	{
	  if (!s7_is_integer(caddr(args)))
	    return(wrong_type_argument_n(sc, sc->COPY, 3, caddr(args), T_INTEGER));
	  if ((!is_null(cdddr(args))) &&
	      (!s7_is_integer(cadddr(args))))
	    return(wrong_type_argument_n(sc, sc->COPY, 4, cadddr(args), T_INTEGER));
	}
      return(dest);
    }

  if (have_indices)
    start_and_end(sc, sc->COPY, cddr(args), 3, &start, &end);

  if ((start == 0) && (source == dest))
    return(dest);
  source_len = end - start;
  if (source_len == 0)
    return(dest);

  switch (type(dest))
    {
    case T_PAIR:     
      set = list_setter;     
      dest_len = s7_list_length(sc, dest); 
      if (dest_len == 0) dest_len = COPY_CIRCLE_LEN; 
      if (dest_len < 0) dest_len = -dest_len;
      break;

    case T_INT_VECTOR:   
    case T_FLOAT_VECTOR: 
    case T_VECTOR:       set = vector_setter(dest); dest_len = vector_length(dest);            break;
    case T_STRING:       set = string_setter;       dest_len = string_length(dest);            break;
    case T_C_OBJECT:     set = c_object_setter;     dest_len = object_length_to_int(sc, dest); break;
    default: return(dest);
    }
  
  if (dest_len == 0)
    return(dest);
  if (dest_len < source_len) 
    end = dest_len - start;

  if ((source != dest) &&
      (type(source) == type(dest)))
    {
      switch (type(source))
	{
	case T_PAIR:
	  {
	    s7_pointer slow, ps, pd;

	    ps = source;
	    for (i = 0; i < start; i++)
	      ps = cdr(ps);
	    slow = ps;

	    pd = dest;
	    for (; (i < end) && is_pair(ps) && is_pair(pd); i++)
	      {
		car(pd) = car(ps);
		ps = cdr(ps);
		pd = cdr(pd);
		if ((!is_pair(ps)) || (!is_pair(pd))) return(dest);

		car(pd) = car(ps);
		ps = cdr(ps);
		pd = cdr(pd);

		slow = cdr(slow);
		if (slow == ps) return(dest);
	      }
	    return(dest);
	  }

	case T_VECTOR:
	  /* ignore possible dimensional mismatch */
	  for (i = start, j = 0; i < end; i++, j++)
	    vector_element(dest, j) = vector_element(source, i);
	  return(dest);

	case T_INT_VECTOR:
	  /* ignore possible dimensional mismatch */
	  for (i = start, j = 0; i < end; i++, j++)
	    int_vector_element(dest, j) = int_vector_element(source, i);
	  return(dest);

	case T_FLOAT_VECTOR:
	  /* ignore possible dimensional mismatch */
	  for (i = start, j = 0; i < end; i++, j++)
	    float_vector_element(dest, j) = float_vector_element(source, i);
	  return(dest);

	case T_STRING:
	  for (i = start, j = 0; i < end; i++, j++)
	    string_value(dest)[j] = string_value(source)[i];
	  return(dest);
	  
	case T_C_OBJECT:
	  if ((c_object_has_array(source)) &&
	      (c_object_has_array(dest)))
	    {
	      for (i = start, j = 0; i < end; i++, j++)
		c_object_array(dest)[j] = c_object_array(source)[i];
	      return(dest);
	    }
	  break;

	default:
	  return(dest);
	}
    }

  /* if source == dest here, we're moving data backwards, so this is safe in either case */

  for (i = start, j = 0; i < end; i++, j++)
    set(sc, dest, j, get(sc, source, i));

  return(dest);
}



/* old form:
static s7_pointer g_copy(s7_scheme *sc, s7_pointer args)
{
  #define H_copy "(copy obj) returns a copy of obj"
  return(s7_copy(sc, car(args)));
}
*/


#if 0
static s7_pointer complete_environment_copy(s7_scheme *sc, s7_pointer env)
{
  /* copy entire chain of envs */
  s7_pointer x, new_e;
  bool old_off;
  old_off = sc->gc_off;
  sc->gc_off = true;

  if (is_null(next_environment(env)))
    new_e = sc->NIL;
  else new_e = complete_environment_copy(sc, next_environment(env));

  new_e = new_frame_in_env(sc, new_e);
  for (x = environment_slots(env); is_slot(x); x = next_slot(x))
    ADD_SLOT(new_e, slot_symbol(x), slot_value(x));
  environment_slots(new_e) = reverse_slots(sc, environment_slots(new_e));

  sc->gc_off = old_off;
  return(new_e);
}
#endif


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."
  s7_pointer p, np;
  
  p = car(args);
  np = sc->NIL;

  switch (type(p))
    {
    case T_NIL:
      return(sc->NIL);

    case T_PAIR:
      return(s7_reverse(sc, p));
      /* if (is_null(np)) return(simple_wrong_type_argument_with_type(sc, sc->REVERSE, p, A_PROPER_LIST)); */
      break;

    case T_STRING:
      {
	int i, j, len;
	len = string_length(p);
	np = make_empty_string(sc, len, 0);
	if (len > 0)
	  for (i = 0, j = len - 1; i < len; i++, j--)
	    string_value(np)[i] = string_value(p)[j];
	if (is_bytevector(p))
	  set_bytevector(np);
      }
      break;

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      {
	s7_Int i, j, len;
	len = vector_length(p);
	if (vector_is_multidimensional(p))
	  np = g_make_vector(sc, list_1(sc, g_vector_dimensions(sc, list_1(sc, p))));
	else np = make_vector_1(sc, len, NOT_FILLED, type(p));
	if (len > 0)
	  {
	    if (is_int_vector(p))
	      {
		for (i = 0, j = len - 1; i < len; i++, j--)
		  int_vector_element(np, i) = int_vector_element(p, j);
	      }
	    else
	      {
		if (is_float_vector(p))
		  {
		    for (i = 0, j = len - 1; i < len; i++, j--)
		      float_vector_element(np, i) = float_vector_element(p, j);
		  }
		else
		  {
		    for (i = 0, j = len - 1; i < len; i++, j--)
		      vector_element(np, i) = vector_element(p, j);
		  }
	      }
	  }
      }
      break;

    case T_HASH_TABLE:
      return(hash_table_reverse(sc, p));

    case T_C_OBJECT:
      return(object_reverse(sc, p));

    default:
      CHECK_METHOD(sc, p, sc->REVERSE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->REVERSE, p, make_protected_string(sc, "a list, string, vector, or hash-table")));
    }
  
  return(np);
}



static s7_pointer list_fill(s7_scheme *sc, s7_pointer obj, s7_pointer val)
{
  /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */
  s7_pointer x, y;

  x = obj;
  y = obj;

  while (true)
    {
      if (!is_pair(x)) return(val);
      car(x) = val;
      if (is_pair(cdr(x)))
	{
	  x = cdr(x);
	  car(x) = val;
	  if (is_pair(cdr(x)))
	    {
	      x = cdr(x);
	      y = cdr(y);
	      if (x == y) return(val);
	    }
	  else
	    {
	      if (is_not_null(cdr(x)))
		cdr(x) = val;
	      return(val);
	    }
	}
      else
	{
	  if (is_not_null(cdr(x)))
	    cdr(x) = val;
	  return(val);
	}
    }
  return(val);
}


static s7_pointer g_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_fill "(fill! obj val) fills obj with the value val"
  s7_pointer p;
  
  p = car(args);
  switch (type(p))
    {
    case T_STRING:
      return(g_string_fill(sc, args)); /* redundant type check here and below */

    case T_HASH_TABLE:
      if (is_not_null(cadr(args)))
	return(wrong_type_argument(sc, sc->FILL, small_int(2), cadr(args), T_NIL));
      return(hash_table_clear(sc, p));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(g_vector_fill(sc, args));

    case T_C_OBJECT:
      if (c_object_fill(p))
	return((*(c_object_fill(p)))(sc, p, cadr(args)));
      return(eval_error(sc, "attempt to fill ~S?", p));

    case T_PAIR:
      return(list_fill(sc, p, cadr(args)));

    case T_NIL:
      return(cadr(args));        /* this parallels the empty vector case */

    default:
      CHECK_METHOD(sc, p, sc->FILL, args);
    }

  return(wrong_type_argument_with_type(sc, sc->FILL, small_int(1), p, make_protected_string(sc, "a fillable object"))); /* (fill! 1 0) */
}



#define SAVE_X_Y_Z(X, Y, Z)	     \
  do {                               \
    X = ((is_null(sc->x)) ? -1 : s7_gc_protect(sc, sc->x));	\
    Y = ((is_null(sc->y)) ? -1 : s7_gc_protect(sc, sc->y));	\
    Z = ((is_null(sc->z)) ? -1 : s7_gc_protect(sc, sc->z));	\
  } while (0)

#define RESTORE_X_Y_Z(X, Y, Z)                \
  do {                                        \
    if (X == -1) sc->x = sc->NIL; else {sc->x = s7_gc_protected_at(sc, X); s7_gc_unprotect_at(sc, X);} \
    if (Y == -1) sc->y = sc->NIL; else {sc->y = s7_gc_protected_at(sc, Y); s7_gc_unprotect_at(sc, Y);} \
    if (Z == -1) sc->z = sc->NIL; else {sc->z = s7_gc_protected_at(sc, Z); s7_gc_unprotect_at(sc, Z);} \
    } while (0)


static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
{
  switch (type(obj))
    {
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(s7_vector_to_list(sc, obj));

    case T_STRING:
      return(s7_string_to_list(sc, string_value(obj), string_length(obj)));

    case T_HASH_TABLE:
      if (hash_table_entries(obj) > 0)
	{
	  s7_pointer x, iterator;
	  int gc_iter;
	  /* (format #f "~{~A ~}" (hash-table '(a . 1) '(b . 2))) */
	  
	  iterator = g_make_hash_table_iterator(sc, list_1(sc, obj));
	  gc_iter = s7_gc_protect(sc, iterator);
	  
	  sc->w = sc->NIL;
	  while (true)
	    {
	      x = hash_table_iterate(sc, iterator);
	      if (is_null(x)) break;
	      sc->w = cons(sc, x, sc->w);
	    }
	  
	  x = sc->w;
	  sc->w = sc->NIL;
	  s7_gc_unprotect_at(sc, gc_iter);
	  return(x);
	}
      return(sc->NIL);
      
    case T_ENVIRONMENT:
      return(s7_environment_to_list(sc, obj));

    case T_C_OBJECT:
      {
	long int i, len; /* the "long" matters on 64-bit machines */
	s7_pointer x, z, result;
	int save_x = -1, save_y = -1, save_z = -1, gc_res = -1, gc_z = -1;
	/* (format #f "~{~A ~}" (vct 1 2 3)) */

	x = object_length(sc, obj);
	if (s7_is_integer(x))
	  len = s7_integer(x);
	else return(sc->F);

	if (len < 0)
	  return(sc->F);
	if (len == 0)
	  return(sc->NIL);

	result = make_list(sc, len, sc->NIL);
	gc_res = s7_gc_protect(sc, result);
	z = list_1(sc, sc->F);
	gc_z = s7_gc_protect(sc, z);

	for (i = 0, x = result; i < len; i++, x = cdr(x))
	  {
	    car(z) = make_integer(sc, i);
	    SAVE_X_Y_Z(save_x, save_y, save_z);
	    car(x) = (*(c_object_ref(obj)))(sc, obj, z);
	    RESTORE_X_Y_Z(save_x, save_y, save_z);
	  }
	
	s7_gc_unprotect_at(sc, gc_z);
	s7_gc_unprotect_at(sc, gc_res);
	return(result);
      }
    }
  return(obj);
}



/* ---------------- stacktrace ---------------- */

static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e)
{
  if ((is_environment(e)) && (e != sc->global_env))
    {
      if (is_function_env(e))
	return(environment_function(e));
      return(stacktrace_find_caller(sc, next_environment(e)));
    }
  return(sc->F);
}

static bool stacktrace_find_environment(s7_scheme *sc, int loc, s7_pointer e)
{
  return((loc > 0) &&
	 ((stack_environment(sc->stack, loc) == e) ||
	  (stacktrace_find_environment(sc, loc - 4, e))));
}

static int stacktrace_find_error_hook_quit(s7_scheme *sc)
{
  int i;
  for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
    if (stack_op(sc->stack, i) == OP_ERROR_HOOK_QUIT)
      return(i);
  return(-1);
}

static bool stacktrace_in_error_handler(s7_scheme *sc, int loc)
{
  return((next_environment(sc->error_env) == sc->envir) ||
	 (stacktrace_find_environment(sc, loc * 4, next_environment(sc->error_env))) ||
	 (stacktrace_find_error_hook_quit(sc) > 0));
}


static bool direct_memq(s7_pointer symbol, s7_pointer symbols);

static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym)
{
  if (is_symbol(sym))
    {
      s7_pointer f;
      f = s7_symbol_value(sc, sym);
      return((is_procedure(f)) &&
	     (is_procedure(sc->error_hook)) &&
	     (is_pair(s7_hook_functions(sc, sc->error_hook))) &&
	     (direct_memq(f, s7_hook_functions(sc, sc->error_hook))));
    }
  return(false);
}

static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, 
			       char *notes, int gc_syms,
			       int code_cols, int total_cols, int notes_start_col, 
			       bool as_comment)
{
  s7_pointer syms;
  syms = gc_protected_at(sc, gc_syms);

  if (is_symbol(code))
    {
      if ((!direct_memq(code, syms)) &&
	  (global_slot(code) == sc->UNDEFINED))
	{
	  s7_pointer val;

	  syms = cons(sc, code, syms);
	  gc_protected_at(sc, gc_syms) = syms;

	  val = s7_symbol_local_value(sc, code, e);
	  if ((val != sc->UNDEFINED) &&
	      (!is_any_macro(val)))
	    {
	      int typ;

	      typ = type(val);
	      if ((typ != T_CLOSURE)      &&
		  (typ != T_CLOSURE_STAR) &&
		  (typ < T_C_FUNCTION)    &&
		  (typ != T_GOTO)         &&
		  (typ != T_CONTINUATION))
		{
		  char *objstr, *str;
		  const char *spaces;
		  int objlen, new_note_len, notes_max, cur_line_len = 0, spaces_len;
		  bool new_notes_line = false;

		  spaces = "                                                                                ";
		  spaces_len = strlen(spaces);

		  notes_max = total_cols - notes_start_col;
		  objstr = s7_object_to_c_string(sc, val);
		  objlen = strlen(objstr);
		  if (objlen > notes_max)
		    {
		      objstr[notes_max - 4] = '.';
		      objstr[notes_max - 3] = '.';
		      objstr[notes_max - 2] = '.';
		      objstr[notes_max - 1] = '\0';
		      objlen = notes_max;
		    }

		  new_note_len = symbol_name_length(code) + 3 + objlen;
		  /* we want to append this much info to the notes, but does it need a new line?
		   */
		  if (notes_start_col < code_cols)
		    new_notes_line = true;
		  else
		    {
		      if (notes)
			{
			  char *last_newline;
			  last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */
			  if (last_newline)
			    cur_line_len = strlen(notes) - strlen(last_newline);
			  else cur_line_len = strlen(notes);
			  new_notes_line = ((cur_line_len + new_note_len) > notes_max);
			}
		    }

		  if (new_notes_line)
		    {
		      new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0));
		      str = (char *)calloc(new_note_len, sizeof(char));
		      snprintf(str, new_note_len, "%s\n%s%s%s%s: %s", 
			       (notes) ? notes : "", 
			       (as_comment) ? "; " : "",
			       (char *)(spaces + spaces_len - notes_start_col),
			       (as_comment) ? "" : " ; ",
			       symbol_name(code), 
			       objstr);
		    }
		  else
		    {
		      new_note_len += ((notes) ? strlen(notes) : 0) + 4;
		      str = (char *)calloc(new_note_len, sizeof(char));
		      snprintf(str, new_note_len, "%s%s%s: %s", 
			       (notes) ? notes : "", 
			       (notes) ? ", " : " ; ",
			       symbol_name(code), 
			       objstr);
		    }
		  free(objstr);
		  if (notes) free(notes);
		  return(str);
		}
	    }
	}
      return(notes);
    }
  if (is_pair(code))
    {
      notes = stacktrace_walker(sc, car(code), e, notes, gc_syms, code_cols, total_cols, notes_start_col, as_comment);
      return(stacktrace_walker(sc, cdr(code), e, notes, gc_syms, code_cols, total_cols, notes_start_col, as_comment));
    }
  return(notes);
}

static char *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code, char *errstr, char *notes, int code_max, bool as_comment)
{
  int newlen, errlen, spaces_len;
  char *newstr, *str;
  const char *spaces;

  spaces = "                                                                                ";
  spaces_len = strlen(spaces);
  errlen = strlen(errstr);

  if ((is_symbol(f)) &&
      (f != car(code)))
    {
      newlen = symbol_name_length(f) + errlen + 10;
      newstr = (char *)calloc(newlen, sizeof(char));
      errlen = snprintf(newstr, newlen, "%s: %s", symbol_name(f), errstr);
    }
  else
    {
      newlen = errlen + 8;
      newstr = (char *)calloc(newlen, sizeof(char));
      if ((errlen > 2) && (errstr[2] == '('))
	errlen = snprintf(newstr, newlen, "  %s", errstr);
      else errlen = snprintf(newstr, newlen, "%s", errstr);
    }

  newlen = code_max + 8 + ((notes) ? strlen(notes) : 0);
  str = (char *)calloc(newlen, sizeof(char));

  if (errlen >= code_max)
    {
      newstr[code_max - 4] = '.';
      newstr[code_max - 3] = '.';
      newstr[code_max - 2] = '.';
      newstr[code_max - 1] = '\0';
      snprintf(str, newlen, "%s%s%s\n", (as_comment) ? "; " : "", newstr, (notes) ? notes : "");
    }
  else
    {
      snprintf(str, newlen, "%s%s%s%s\n", (as_comment) ? "; " : "", newstr, 
	       (char *)(spaces + spaces_len - code_max + errlen + 1), 
	       (notes) ? notes : "");
    }
  free(newstr);

  return(str);
}


static char *stacktrace_1(s7_scheme *sc, int frames_max, int code_cols, int total_cols, int notes_start_col, bool as_comment)
{
  char *str;
  int loc, top, frames = 0, gc_syms;

  gc_syms = s7_gc_protect(sc, sc->NIL);
  str = NULL;
  top = (sc->stack_end - sc->stack_start) / 4; /* g_stack_top, not s7_stack_top! */
  
  if (stacktrace_in_error_handler(sc, top))
    {
      s7_pointer err_code;
      err_code = slot_value(sc->error_code);
      if (is_pair(err_code))
	{
	  char *errstr, *notes = NULL;
	  s7_pointer cur_env, f;

	  errstr = s7_object_to_c_string(sc, err_code);
	  cur_env = next_environment(sc->error_env);
	  f = stacktrace_find_caller(sc, cur_env); /* this is a symbol */
	  if ((is_environment(cur_env)) &&
	      (cur_env != sc->global_env))
	    notes = stacktrace_walker(sc, err_code, cur_env, NULL, gc_syms, code_cols, total_cols, notes_start_col, as_comment);
	  str = stacktrace_add_func(sc, f, err_code, errstr, notes, code_cols, as_comment);
	  free(errstr);
	}

      /* now if OP_ERROR_HOOK_QUIT is in the stack, jump past it!
       */
      loc = stacktrace_find_error_hook_quit(sc);
      if (loc > 0) top = (loc + 1) / 4;
    }
     
  for (loc = top - 1; loc > 0; loc--)
    {
      s7_pointer code;
      int true_loc;

      true_loc = (int)(loc + 1) * 4 - 1;
      code = stack_code(sc->stack, true_loc);
      
      if (is_pair(code))
	{
	  char *codestr;
	  codestr = s7_object_to_c_string(sc, code);
	  if (codestr)
	    {
	      if ((strcmp(codestr, "(result)") != 0) &&
		  (strcmp(codestr, "(#f)") != 0) &&
		  (strstr(codestr, "(stacktrace)") == NULL) &&
		  (strstr(codestr, "(stacktrace ") == NULL))
		{
		  s7_pointer e, f;

		  e = stack_environment(sc->stack, true_loc);
		  f = stacktrace_find_caller(sc, e);
		  if (!stacktrace_error_hook_function(sc, f))
		    {
		      char *notes = NULL, *newstr;
		      int newlen;

		      frames++;
		      if (frames > frames_max)
			{
			  free(codestr);
			  s7_gc_unprotect_at(sc, gc_syms);
			  return(str);
			}

		      if ((is_environment(e)) && (e != sc->global_env))
			notes = stacktrace_walker(sc, code, e, NULL, gc_syms, code_cols, total_cols, notes_start_col, as_comment);
		      newstr = stacktrace_add_func(sc, f, code, codestr, notes, code_cols, as_comment);
		      free(codestr);
		      if (notes) free(notes);

		      newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0);
		      codestr = (char *)calloc(newlen, sizeof(char));
		      snprintf(codestr, newlen, "%s%s", (str) ? str : "", newstr);
		      if (str) free(str);
		      free(newstr);
		      str = codestr;
		      codestr = NULL;
		    }
		  else free(codestr);
		}
	      else free(codestr);
	    }
	}
    }

  s7_gc_unprotect_at(sc, gc_syms);      
  return(str);
}


s7_pointer s7_stacktrace(s7_scheme *sc)
{
  return(make_string_uncopied(sc, stacktrace_1(sc, 30, 45, 80, 45, false)));
}


static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args)
{
  #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \
a stacktrace as a string.  Each line has two portions, the code being evaluated and a note giving \
the value of local variables in that code.  The first argument sets how many lines are displayed. \
The next three arguments set the length and layout of those lines.  'as-comment' if #t causes each \
line to be preceded by a semicolon."

  s7_Int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50;
  bool as_comment = false;

  if (!is_null(args))
    {
      if (s7_is_integer(car(args)))
	{
	  max_frames = s7_integer(car(args));
	  if ((max_frames <= 0) || (max_frames > S7_LONG_MAX))
	    max_frames = 30;
	  args = cdr(args);
	  if (!is_null(args))
	    {
	      if (s7_is_integer(car(args)))
		{
		  code_cols = s7_integer(car(args));
		  if ((code_cols <= 8) || (code_cols > S7_LONG_MAX))
		    code_cols = 50;
		  args = cdr(args);
		  if (!is_null(args))
		    {
		      if (s7_is_integer(car(args)))
			{
			  total_cols = s7_integer(car(args));
			  if ((total_cols <= code_cols) || (total_cols > S7_LONG_MAX))
			    total_cols = 80;
			  args = cdr(args);
			  if (!is_null(args))
			    {
			      if (s7_is_integer(car(args)))
				{
				  notes_start_col = s7_integer(car(args));
				  if ((notes_start_col <= 0) || (notes_start_col > S7_LONG_MAX))
				    notes_start_col = 50;
				  args = cdr(args);
				  if (!is_null(args))
				    {
				      if (s7_is_boolean(car(args)))
					as_comment = s7_boolean(sc, car(args));
				      else return(wrong_type_argument(sc, sc->STACKTRACE, small_int(5), car(args), T_BOOLEAN));
				    }
				}
			      else return(wrong_type_argument(sc, sc->STACKTRACE, small_int(4), car(args), T_INTEGER));
			    }
			}
		      else return(wrong_type_argument(sc, sc->STACKTRACE, small_int(3), car(args), T_INTEGER));
		    }
		}
	      else return(wrong_type_argument(sc, sc->STACKTRACE, small_int(2), car(args), T_INTEGER));
	    }
	}
      else return(wrong_type_argument(sc, sc->STACKTRACE, small_int(1), car(args), T_INTEGER));
    }
  return(make_string_uncopied(sc, stacktrace_1(sc, (int)max_frames, (int)code_cols, (int)total_cols, (int)notes_start_col, as_comment)));
}



/* -------- error handlers -------- */

static const char *make_type_name(const char *name, int article)
{
  static char *typnam = NULL;
  static int typnam_len = 0;
  static const char *articles[3] =      {"", "the ", "a "};
  int len;

  len = safe_strlen(name) + 8;
  if (len > typnam_len)
    {
      if (typnam) free(typnam);
      typnam = (char *)calloc(len, sizeof(char));
      typnam_len = len;
    }
  if ((article == INDEFINITE_ARTICLE) &&
      ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u')))
    strcopy(typnam, "an ", typnam_len);
  else strcopy(typnam, articles[article], typnam_len);
  strcat(typnam, name);
  return(typnam);
}


static const char *environments[3] =    {"environment",         "the environment",        "an environment"};
static const char *closures[3] =        {"closure",             "the closure",            "a closure"};

static const char *type_name_from_type(s7_scheme *sc, int typ, int article)
{
  static const char *frees[3] =         {"free cell",          "the free cell",           "a free cell"};
  static const char *nils[3] =          {"nil",                "the null list",           "nil"};
  static const char *uniques[3] =       {"untyped",            "the untyped",             "untyped"};
  static const char *booleans[3] =      {"boolean",            "the boolean",             "boolean"};
  static const char *strings[3] =       {"string",             "the string",              "a string"};
  static const char *symbols[3] =       {"symbol",             "the symbol",              "a symbol"};
  static const char *syntaxes[3] =      {"syntax",             "the syntactic",           "syntactic"};
  static const char *pairs[3] =         {"pair",               "the pair",                "a pair"};
  static const char *gotos[3] =         {"goto",               "the call-with-exit goto", "a goto (from call-with-exit)"};
  static const char *continuations[3] = {"continuation",       "the continuation",        "a continuation"};
  static const char *functions[3] =     {"function",           "the function",            "a function"};
  static const char *macros[3] =        {"macro",              "the macro",               "a macro"};
  static const char *bacros[3] =        {"bacro",              "the bacro",               "a bacro"};
  static const char *vectors[3] =       {"vector",             "the vector",              "a vector"};
  static const char *int_vectors[3] =   {"int-vector",         "the int-vector",          "an int-vector"};
  static const char *float_vectors[3] = {"float-vector",       "the float-vector",        "a float-vector"};
  static const char *c_pointers[3] =    {"C pointer",          "the raw C pointer",       "a raw C pointer"};
  static const char *counters[3] =      {"internal counter",   "the internal counter",    "an internal counter"};
  static const char *baffles[3] =       {"baffle",             "the baffle",              "a baffle"};
  static const char *slots[3] =         {"slot",               "the slot (name binding)", "a slot (variable binding)"};
  static const char *characters[3] =    {"character",          "the character",           "a character"};
  static const char *catches[3] =       {"catch",              "the catch",               "a catch"};
  static const char *dynamic_winds[3] = {"dynamic-wind",       "the dynamic-wind",        "a dynamic-wind"};
  static const char *hash_tables[3] =   {"hash-table",         "the hash-table",          "a hash-table"};
  static const char *integers[3] =      {"integer",            "the integer",             "an integer"};
  static const char *big_integers[3] =  {"big integer",        "the big integer",         "a big integer"};
  static const char *ratios[3] =        {"ratio",              "the ratio",               "a ratio"};
  static const char *big_ratios[3] =    {"big ratio",          "the big ratio",           "a big ratio"};
  static const char *reals[3] =         {"real",               "the real",                "a real"};
  static const char *big_reals[3] =     {"big real",           "the big real",            "a big real"};
  static const char *complexes[3] =     {"complex number",     "the complex number",      "a complex number"};
  static const char *big_complexes[3] = {"big complex number", "the big complex number",  "a big complex number"};

  switch (typ)
    {
    case T_FREE:         return(frees[article]);
    case T_NIL:          return(nils[article]);
    case T_UNIQUE:       return(uniques[article]);
    case T_BOOLEAN:      return(booleans[article]);
    case T_STRING:       return(strings[article]);
    case T_SYMBOL:       return(symbols[article]);
    case T_SYNTAX:       return(syntaxes[article]);
    case T_PAIR:         return(pairs[article]);
    case T_GOTO:         return(gotos[article]);
    case T_CONTINUATION: return(continuations[article]);
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_LST_ARGS_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION:   return(functions[article]);
    case T_MACRO:
    case T_C_MACRO:      return(macros[article]);
    case T_C_POINTER:    return(c_pointers[article]);
    case T_CHARACTER:    return(characters[article]);
    case T_VECTOR:       return(vectors[article]);
    case T_INT_VECTOR:   return(int_vectors[article]);
    case T_FLOAT_VECTOR: return(float_vectors[article]);
    case T_BACRO:        return(bacros[article]);
    case T_CATCH:        return(catches[article]); /* are these 2 possible? */
    case T_DYNAMIC_WIND: return(dynamic_winds[article]);
    case T_HASH_TABLE:   return(hash_tables[article]);
    case T_COUNTER:      return(counters[article]);
    case T_BAFFLE:       return(baffles[article]);
    case T_SLOT:         return(slots[article]);
    case T_INTEGER:      return(integers[article]);
    case T_RATIO:        return(ratios[article]);
    case T_REAL:         return(reals[article]);
    case T_COMPLEX:      return(complexes[article]);
    case T_BIG_INTEGER:  return(big_integers[article]);
    case T_BIG_RATIO:    return(big_ratios[article]);
    case T_BIG_REAL:     return(big_reals[article]);
    case T_BIG_COMPLEX:  return(big_complexes[article]);
    }
  return(NULL);
}


static const char *type_name(s7_scheme *sc, s7_pointer arg, int article)
{
  const char *str;
  s7_pointer class_sym;

  str = type_name_from_type(sc, type(arg), article);
  if (str) return(str);

  switch (type(arg))
    {
    case T_C_OBJECT:     
      return(make_type_name(object_types[c_object_type(arg)]->name, article));

    case T_INPUT_PORT:   
      return(make_type_name((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((is_file_port(arg)) ? "output file port" : ((is_string_port(arg)) ? "output string port" : "output port"), article));

    case T_ENVIRONMENT:  
      if (has_methods(arg))
	{
	  class_sym = symbol_table_find_by_name(sc, "class-name", sc->class_name_location);
	  if (!is_null(class_sym))
	    {
	      s7_pointer class_name;
	      class_name = find_method(sc, arg, class_sym);
	      if ((class_name != sc->UNDEFINED) &&
		  (is_symbol(class_name)))
		return(make_type_name(symbol_name(class_name), article));
	    }
	}
      return(environments[article]);

    case T_CLOSURE:      
    case T_CLOSURE_STAR: 
      if (has_methods(arg))
	{
	  class_sym = symbol_table_find_by_name(sc, "class-name", sc->class_name_location);
	  if (!is_null(class_sym))
	    {
	      s7_pointer class_name;
	      class_name = find_method(sc, closure_environment(arg), class_sym);
	      if ((class_name != sc->UNDEFINED) &&
		  (is_symbol(class_name)))
		return(make_type_name(symbol_name(class_name), article));
	    }
	}
      return(closures[article]);
    }
  return("messed up object");
}



static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x)
{
  const char *name;
  s7_pointer p;

  p = prepackaged_type_names[type(x)];
  if (is_string(p))
    return(p);

  name = type_name(sc, x, INDEFINITE_ARTICLE); 
  if (name == closures[INDEFINITE_ARTICLE])
    return(A_CLOSURE);
  if (name == environments[INDEFINITE_ARTICLE])
    return(AN_ENVIRONMENT);
  return(make_protected_string(sc, name));
}


static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer typnam, s7_pointer descr)
{
  /* info list is '(format_string caller arg_n arg type_name descr) */
  car(sc->WTA1) = caller;
  car(sc->WTA2) = arg_n;
  car(sc->WTA3) = arg;
  if (typnam == sc->GC_NIL)
    car(sc->WTA4) = prepackaged_type_name(sc, arg);
  else car(sc->WTA4) = typnam;
  car(sc->WTA5) = descr;
  return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->WRONG_TYPE_ARG_INFO));
}


static s7_pointer simple_wrong_type_arg_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typnam, s7_pointer descr)
{
  list_set(sc, sc->SIMPLE_WRONG_TYPE_ARG_INFO, 1, caller);
  list_set(sc, sc->SIMPLE_WRONG_TYPE_ARG_INFO, 2, arg);
  if (typnam == sc->GC_NIL)
    list_set(sc, sc->SIMPLE_WRONG_TYPE_ARG_INFO, 3, prepackaged_type_name(sc, arg));
  else list_set(sc, sc->SIMPLE_WRONG_TYPE_ARG_INFO, 3, typnam);
  list_set(sc, sc->SIMPLE_WRONG_TYPE_ARG_INFO, 4, descr);
  return(s7_error(sc, sc->WRONG_TYPE_ARG, sc->SIMPLE_WRONG_TYPE_ARG_INFO));
}


s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, int arg_n, s7_pointer arg, const char *descr)
{
  /* info list is '(format_string caller arg_n arg type_name descr) */
  if (arg_n < 0) arg_n = 0;

  if (arg_n > 0)
    return(wrong_type_arg_error_prepackaged(sc, 
					    make_protected_string(sc, caller),
					    make_integer(sc, arg_n),
					    arg,
					    make_protected_string(sc, type_name(sc, arg, INDEFINITE_ARTICLE)),
					    make_protected_string(sc, descr)));
  return(simple_wrong_type_arg_error_prepackaged(sc,
						 make_protected_string(sc, caller),
						 arg,
						 make_protected_string(sc, type_name(sc, arg, INDEFINITE_ARTICLE)),
						 make_protected_string(sc, descr)));
}


static s7_pointer out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, const char *descr)
{
  /* info list is '(format_string caller arg_n arg descr) */
  list_set(sc, sc->OUT_OF_RANGE_INFO, 1, caller);
  list_set(sc, sc->OUT_OF_RANGE_INFO, 2, arg_n);
  list_set(sc, sc->OUT_OF_RANGE_INFO, 3, arg);
  list_set(sc, sc->OUT_OF_RANGE_INFO, 4, make_protected_string(sc, descr));
  return(s7_error(sc, sc->OUT_OF_RANGE, sc->OUT_OF_RANGE_INFO));
}


static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, const char *descr)
{
  list_set(sc, sc->SIMPLE_OUT_OF_RANGE_INFO, 1, caller);
  list_set(sc, sc->SIMPLE_OUT_OF_RANGE_INFO, 2, arg);
  list_set(sc, sc->SIMPLE_OUT_OF_RANGE_INFO, 3, make_protected_string(sc, descr));
  return(s7_error(sc, sc->OUT_OF_RANGE, sc->SIMPLE_OUT_OF_RANGE_INFO));
}


s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, int arg_n, s7_pointer arg, const char *descr)
{
  /* info list is '(format_string caller arg_n arg descr) */
  if (arg_n < 0) arg_n = 0;

  if (arg_n > 0)
    return(out_of_range_error_prepackaged(sc, 
					  make_protected_string(sc, caller),
					  make_integer(sc, arg_n),
					  arg,
					  descr));
  return(simple_out_of_range_error_prepackaged(sc,
					       make_protected_string(sc, caller),
					       arg,
					       descr));
}


s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args)
{
  return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, 
		  list_2(sc, 
			 make_protected_string(sc, caller), /* "caller" includes the format directives */
			 args)));
}


static s7_pointer division_by_zero_error(s7_scheme *sc, s7_pointer caller, s7_pointer arg)
{
  return(s7_error(sc, sc->DIVISION_BY_ZERO, list_3(sc, sc->DIVISION_BY_ZERO_ERROR, caller, arg)));
}


static s7_pointer file_error(s7_scheme *sc, const char *caller, const char *descr, const char *name)
{
  return(s7_error(sc, make_symbol(sc, "io-error"), 
		  list_4(sc, 
			 make_protected_string(sc, "~A: ~A ~S"),
			 make_protected_string(sc, caller),
			 make_protected_string(sc, descr),
			 make_protected_string(sc, name))));
}


static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer p)
{
  s7_pointer body;
  if (!is_closure(p)) return(p);
  body = closure_body(p);
  if (is_pair(cdr(body))) return(p);
  if (!is_pair(car(body))) return(sc->F);
  if (caar(body) == sc->QUOTE) return(sc->F);
  return(p);
}


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"
  s7_pointer p;

  /* apparently most schemes think the restriction here to a thunk is onerous, and
   *   instead limit it to functions that can be called with no args.
   *   hence is_thunkable here -- is this also the expectation in call-with-output-file and others?
   */

  if (!is_thunkable(sc, car(args)))
    return(wrong_type_argument_with_type(sc, sc->DYNAMIC_WIND, small_int(1), car(args), A_THUNK));
  if (!is_thunkable(sc, cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->DYNAMIC_WIND, small_int(2), cadr(args), A_THUNK));
  if (!is_thunkable(sc, caddr(args)))
    return(wrong_type_argument_with_type(sc, sc->DYNAMIC_WIND, small_int(3), caddr(args), A_THUNK));

  /* 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.
   */
  
  NEW_CELL(sc, p);
  dynamic_wind_in(p) = closure_or_f(sc, car(args));
  dynamic_wind_body(p) = cadr(args);
  dynamic_wind_out(p) = closure_or_f(sc, caddr(args));
  set_type(p, T_DYNAMIC_WIND);                          /* atom -> don't mark car/cdr, don't copy */
  
  /* since we don't care about the in and out results, and they are thunks, if the body is not a pair,
   *   or is a quoted thing, we just ignore that function.
   */

  push_stack(sc, OP_DYNAMIC_WIND, sc->NIL, p);          /* args will be the saved result, code = s7_dynwind_t obj */
  if (dynamic_wind_in(p) != sc->F)
    {
      dynamic_wind_state(p) = DWIND_INIT;
      push_stack(sc, OP_APPLY, sc->NIL, dynamic_wind_in(p));
    }
  else
    {
      dynamic_wind_state(p) = DWIND_BODY;
      push_stack(sc, OP_APPLY, sc->NIL, dynamic_wind_body(p));
    }
  return(sc->F);
}

/* C-side dynamic-wind would need at least void* context pointer passed to each function,
 *   and to fit with the scheme-side stuff above, the functions need to be s7 functions,
 *   so I wonder if it could be s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish)
 *   and the caller would use the C-closure idea (s7.html) to package up C-side data.
 *   Then, the caller would probably assume a return value, requiring s7_call?
 *   -> g_dynamic_wind(sc, list_3(sc, init, body, finish)) but with eval(sc, OP_APPLY) at end?
 */


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"
  s7_pointer p;

  /* should this check for a tag that can't possibly be eq? to anything that error might throw? (a string for example)
   */

  if (!is_thunk(sc, cadr(args)))
    return(wrong_type_argument_with_type(sc, sc->CATCH, small_int(2), cadr(args), A_THUNK));
  if (!is_procedure(caddr(args)))
    return(wrong_type_argument_with_type(sc, sc->CATCH, small_int(3), caddr(args), A_PROCEDURE));
  
  NEW_CELL(sc, p);
  catch_tag(p) = car(args);
  catch_goto_loc(p) = s7_stack_top(sc);
  catch_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
  catch_handler(p) = caddr(args);
  set_type(p, T_CATCH);

  push_stack(sc, OP_CATCH, args, p);          /* args ignored but maybe safer for GC? */

  if (is_closure(cadr(args)))
    {
      sc->code = closure_body(cadr(args));
      NEW_FRAME(sc, closure_environment(cadr(args)), sc->envir);
      push_stack(sc, OP_BEGIN, sc->args, sc->code);
    }
  else push_stack(sc, OP_APPLY, sc->NIL, cadr(args));
  return(sc->F);
}



s7_pointer s7_catch_all(s7_scheme *sc, s7_pointer thunk, s7_pointer error_handler)
{
  s7_pointer p;

  NEW_CELL(sc, p);
  catch_tag(p) = sc->T;                   /* if we catch everything, the error handling stuff in s7_call is not needed */
  catch_goto_loc(p) = s7_stack_top(sc);
  catch_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
  catch_handler(p) = error_handler;
  set_type(p, T_CATCH);

  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
  push_stack(sc, OP_CATCH, sc->NIL, p);
  sc->args = sc->NIL;
  sc->code = thunk;
  eval(sc, OP_APPLY);

  return(sc->value);
}


#if 0
static s7_pointer s7_apply_function_with_catch(s7_scheme *sc, s7_pointer func, s7_pointer args, s7_pointer error_handler)
{
  s7_pointer p;
  NEW_CELL(sc, p);
  catch_tag(p) = sc->T; 
  catch_goto_loc(p) = s7_stack_top(sc);
  catch_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
  catch_handler(p) = error_handler;
  set_type(p, T_CATCH);

  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
  push_stack(sc, OP_CATCH, sc->NIL, p);
  sc->args = args;
  sc->code = func;
  eval(sc, OP_APPLY);

  return(sc->value);
}

/* here's an example:
 *
    static s7_pointer error_handler(s7_scheme *sc, s7_pointer args)
    {
      fprintf(stderr, "got an error! %s\n", s7_object_to_c_string(sc, args));
      return(s7_car(args));
    }
    
    static s7_pointer adder(s7_scheme *sc, s7_pointer args)
    {
      return(s7_f(sc));
    }
    
    int main(int argc, char **argv)
    {
      s7_scheme *s7;
      s7 = s7_init();  
      fprintf(stderr, "catch: %s\n",
        s7_object_to_c_string(s7, 
    	  s7_catch_all(s7, 
    	    s7_make_function(s7, "adder", adder, 0, 0, false, "+"),
    	    s7_make_function(s7, "error-handler", error_handler, 0, 0, true, "error handler"))));
    }
 *
 * the function names are local (for error handling etc).  In general, it would be safer to
 *    call s7_gc_protect on the functions (s7_make_function does not protect them).  The
 *    body function ("adder") is a thunk -- args will always be nil.
 */
#endif


/* error reporting info -- save filename and line number */

#define INITIAL_FILE_NAMES_SIZE 8
static s7_pointer *file_names = NULL;
static int file_names_size = 0;
static int file_names_top = -1;

#define remembered_line_number(Line) (Line & 0xfffff)
#define remembered_file_name(Line)   (((Line >> 20) <= file_names_top) ? file_names[Line >> 20] : sc->F)
/* this gives room for 4000 files each of 1000000 lines */


static int remember_file_name(s7_scheme *sc, const char *file)
{
  int i, old_size = 0;

  for (i = 0; i <= file_names_top; i++)
    if (safe_strcmp(file, string_value(file_names[i])) == 0)
      return(i);

  file_names_top++;
  if (file_names_top >= file_names_size)
    {
      if (file_names_size == 0)
	{
	  file_names_size = INITIAL_FILE_NAMES_SIZE;
	  file_names = (s7_pointer *)calloc(file_names_size, sizeof(s7_pointer));
	}
      else
	{
	  old_size = file_names_size;
	  file_names_size *= 2;
	  file_names = (s7_pointer *)realloc(file_names, file_names_size * sizeof(s7_pointer));
	}
      for (i = old_size; i < file_names_size; i++)
	file_names[i] = sc->F;
    }
  file_names[file_names_top] = s7_make_permanent_string(file);

  return(file_names_top);
}


static s7_pointer init_error_env(s7_scheme *sc)
{
  s7_pointer e;
  int gc_loc;

  e = new_frame_in_env(sc, sc->global_env);
  gc_loc = s7_gc_protect(sc, e);

  sc->error_type = s7_make_slot(sc, e, make_symbol(sc, "error-type"), sc->F);  /* the error type or tag ('division-by-zero) */
  sc->error_data = s7_make_slot(sc, e, make_symbol(sc, "error-data"), sc->F);  /* the message or information passed by the error function */
  sc->error_code = s7_make_slot(sc, e, make_symbol(sc, "error-code"), sc->F);  /* the code that s7 thinks triggered the error */
  sc->error_line = s7_make_slot(sc, e, make_symbol(sc, "error-line"), sc->F);  /* the line number of that code */
  sc->error_file = s7_make_slot(sc, e, make_symbol(sc, "error-file"), sc->F);  /* the file name of that code */

  s7_gc_unprotect_at(sc, gc_loc);
  return(e);
}


static s7_pointer g_error_environment(s7_scheme *sc, s7_pointer args)
{
  #define H_error_environment "(error-environment) 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."
  return(sc->error_env);
}

/*  > (let ((a 32) (b "hiho")) (catch #t (lambda () (+ a b)) (lambda args (format #t "~{;~A~%~}" (error-environment)))))
    ";(error-type . wrong-type-arg)
    ;(error-data \"~A argument ~D, ~S, is ~A but should be ~A\" \"+\" 2 \"hiho\" \"a string\" \"a number\")
    ;(error-code + a b)
    ;(error-line . #f)
    ;(error-file . #f)
*/


static bool found_catch(s7_scheme *sc, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  int i;
  /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */

  for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
    {
      opcode_t op;
      s7_pointer x;

      op = stack_op(sc->stack, i);
      if (t_catchable_p[op])
	switch (op)
	  {
	  case OP_CATCH_ALL:
	    {
	      s7_pointer catcher;
	      catcher = stack_environment(sc->stack, i);
	      sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_all_op_loc(catcher));
	      sc->stack_end = (s7_pointer *)(sc->stack_start + catch_all_goto_loc(catcher));
	      pop_stack(sc);
	      sc->value = catch_all_result(catcher);
	      if (sc->longjmp_ok) {longjmp(sc->goto_start, 1);}
	      return(true);
	    }
	    break;
	    
	    
	  case OP_CATCH_1:
	  case OP_CATCH:
	    x = stack_code(sc->stack, i);
	    if ((catch_tag(x) == sc->T) ||
		(catch_tag(x) == type) ||
		(type == sc->T))
	      {
		int loc;
		s7_pointer catcher, error_func;
		catcher = x;
		loc = catch_goto_loc(catcher);
		sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher));
		sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
		error_func = catch_handler(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 the args symbol, set it to (list type info)
		 */
		
		/* if OP_CATCH_1, we deferred making the error handler until it is actually needed
		 */
		{
		  s7_pointer body, y = NULL;
		  if (op == OP_CATCH_1)
		    body = cdr(error_func);
		  else body = closure_body(error_func);
		  
		  if (is_null(cdr(body)))
		    {
		      body = car(body);
		      if (is_pair(body))
			{
			  if (car(body) == sc->QUOTE)
			    y = cadr(body);
			  else
			    {
			      if ((car(body) == sc->CAR) &&
				  (cadr(body) == car(error_func)))
				y = type;
			    }
			}
		      else
			{
			  if (is_symbol(body))
			    {
			      if (body == car(error_func))
				y = list_2(sc, type, info);
			    }
			  else y = body;
			}
		      if (y)
			{
			  pop_stack(sc);
			  sc->value = y;
			  if (sc->longjmp_ok) {longjmp(sc->goto_start, 1);}
			  return(true);
			}
		    }
		}
		if (op == OP_CATCH_1)
		  {
		    s7_pointer y;
		    MAKE_CLOSURE_NO_CAPTURE(sc, y, car(error_func), cdr(error_func), stack_environment(sc->stack, i));
		    sc->code = y;
		  }
		else sc->code = error_func;
		
		/* 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!
		 */
		
		if ((is_pair(closure_args(sc->code))) &&
		    (!s7_is_aritable(sc, sc->code, 2)))
		  {
		    s7_wrong_number_of_args_error(sc, "catch error handler has wrong number of args: ~S", sc->args);
		    return(false);
		  }
		
		/* since MAKE_CLOSURE sets needs_copied_args and we're going to OP_APPLY,
		 *   we don't need a new list here.
		 */
		car(sc->T2_1) = type;
		car(sc->T2_2) = info;
		sc->args = sc->T2_1;
		sc->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 
		 */
		if (sc->longjmp_ok)
		  {
		    longjmp(sc->goto_start, 1); /* this is trying to clear the C stack back to some clean state */
		  }
		
		return(true);
	      }
	    break;
	    
	  case OP_DYNAMIC_WIND:
	    x = stack_code(sc->stack, i);
	    if (dynamic_wind_state(x) == DWIND_BODY)
	      {
		dynamic_wind_state(x) = DWIND_FINISH;    /* make sure an uncaught error in the exit thunk doesn't cause us to loop */
		if (dynamic_wind_out(x) != sc->F)
		  {
		    push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); 
		    sc->args = sc->NIL;
		    sc->code = dynamic_wind_out(x);
		    eval(sc, OP_APPLY);                  /* I guess this means no call/cc out of the exit thunk in an error-catching context */
		  }
	      }
	    break;
	    
	  case OP_UNWIND_OUTPUT:
	    x = stack_code(sc->stack, i);                /* "code" = port that we opened */
	    s7_close_output_port(sc, x);
	    x = stack_args(sc->stack, i);                /* "args" = port that we shadowed, if not #f */
	    if (x != sc->F)
	      sc->output_port = x;
	    break;
	    
	  case OP_UNWIND_INPUT:
	    s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */
	    sc->input_port = stack_args(sc->stack, i);         /* "args" = port that we shadowed */
	    break;
	    
	  case OP_READ_DONE:        /* perhaps an error during (read) */
	    pop_input_port(sc);
	    break;
	    
	  case OP_EVAL_STRING_1:    /* perhaps an error happened before we could push the OP_EVAL_STRING_2 */
	  case OP_EVAL_STRING_2:
	    s7_close_input_port(sc, sc->input_port);
	    pop_input_port(sc);
	    break;
	    
	  case OP_BARRIER:
	    if (is_input_port(stack_args(sc->stack, i)))      /* (eval-string "'(1 .)") */
	      {
		if (sc->input_port == stack_args(sc->stack, i))
		  pop_input_port(sc);
		s7_close_input_port(sc, stack_args(sc->stack, i));
	      }
	    break;
	    
	  case OP_DEACTIVATE_GOTO:
	    call_exit_active(stack_args(sc->stack, i)) = false;
	    break;
	    
	  case OP_ERROR_HOOK_QUIT:
	    sc->error_hook = stack_code(sc->stack, i);
	    /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */
	    (*reset_hook) = true;
	    /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */
	    break;
	    
	  default:
	    break;
	  }
    }
  return(false);
}


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 the error-environment. \
It looks for an existing catch with a matching tag, and jumps to it if found.  Otherwise it raises an error."

  bool ignored_flag = false;
  if (found_catch(sc, car(args), cdr(args), &ignored_flag))
    return(car(args));
  return(s7_error(sc, make_symbol(sc, "uncaught-throw"), args));
}


s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
{
  static int last_line = -1;
  bool reset_error_hook = false;
  const char *call_name;
  s7_pointer cur_code;

  /* fprintf(stderr, "error: %s %s\n", DISPLAY(type), DISPLAY(info)); */
  /* null info can mean symbol table is locked so make-symbol uses s7_error to get out */

  /* set up (error-environment), look for a catch that matches 'type', if found
   *   call its error-handler, else if *error-hook* is bound, call it,
   *   else send out the error info ourselves.
   */
  call_name = sc->s7_call_name;
  /* sc->s7_call_name = NULL; */
  sc->no_values = 0; 
  sc->format_depth = -1;
  s7_gc_on(sc, true);  /* this is in case we were triggered from the sort function -- clumsy! */

  slot_set_value(sc->error_type, type);
  slot_set_value(sc->error_data, info);
  next_environment(sc->error_env) = sc->envir;

  cur_code = sc->cur_code;
  slot_set_value(sc->error_code, cur_code);
  /* sc->cur_code = sc->F; */

  /* (let ((x 32)) (define (h1 a) (* a "hi")) (define (h2 b) (+ b (h1 b))) (h2 1)) */

  if (has_line_number(cur_code)) /* could it ever be a function-env-with-line-info?  is it worth checking is_pair? */
    {
      int line;
      line = pair_line_number(cur_code);
      if (line != last_line)
	{
	  last_line = line;
	  if ((line > 0) &&
	      (is_pair(cur_code))) /* see above */
	    {
	      slot_set_value(sc->error_line, make_integer(sc, remembered_line_number(line))); 
	      slot_set_value(sc->error_file, remembered_file_name(line));	  
	    }
	  else
	    {
	      slot_set_value(sc->error_line, sc->F);
	      slot_set_value(sc->error_file, sc->F);
	    }
	}
    }
  else
    {
      slot_set_value(sc->error_line, sc->F);
      slot_set_value(sc->error_file, sc->F);
    }

  if (found_catch(sc, type, info, &reset_error_hook))
    return(type);

  /* error not caught */
  /* (set! *error-hook* (list (lambda (hook) (apply format #t (hook 'args))))) */
  
  if ((!reset_error_hook) && 
      (is_procedure(sc->error_hook)) &&
      (is_pair(s7_hook_functions(sc, sc->error_hook))))
    {
      s7_pointer error_list;
      /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */
      
      error_list = sc->error_hook;
      sc->error_hook = sc->F;
      /* if the *error-hook* functions trigger an error, we had better not have *error-hook* still set! */
      
      push_stack(sc, OP_ERROR_HOOK_QUIT, sc->NIL, error_list); /* restore *error-hook* upon successful (or any!) evaluation */
      sc->args = list_2(sc, type, info);
      sc->code = error_list;
      
      /* 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.
       */
      eval(sc, OP_APPLY);
    }
  else
    {
      /* 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!
       */
      s7_pointer error_port;
      error_port = s7_current_error_port(sc);
      
      if ((!s7_is_list(sc, info)) ||
	  (!is_string(car(info))))
	format_to_port(sc, error_port, "\n;~S ~S", list_2(sc, type, info), NULL, false, 7);
      else
	{
	  const char *carstr;
	  int i, len;
	  bool use_format = false;
	  
	  /* it's possible that the error string is just a string -- not intended for format */
	  carstr = string_value(car(info));
	  len = string_length(car(info));
	  for (i = 0; i < len; i++)
	    if (carstr[i] == '~')
	      {
		use_format = true;
		break;
	      }
	  
	  if (use_format)
	    {
	      char *errstr;
	      int str_len;
	      len += 8;
	      errstr = (char *)malloc(len * sizeof(char));
	      str_len = snprintf(errstr, len, "\n;%s", string_value(car(info)));
	      format_to_port(sc, error_port, errstr, cdr(info), NULL, false, str_len);
	      free(errstr);
	    }
	  else format_to_port(sc, error_port, "\n;~S ~S", list_2(sc, type, info), NULL, false, 7);
	}
      
      /* now display location at end */
      
      if ((is_input_port(sc->input_port)) &&
	  (port_file(sc->input_port) != stdin) &&
	  (!port_is_closed(sc->input_port)))
	{
	  const char *filename = NULL;
	  int line;
	  
	  filename = port_filename(sc->input_port);
	  line = port_line_number(sc->input_port);
	  
	  if (filename)
	    format_to_port(sc, error_port, "\n;  ~A[~D]", list_2(sc, make_protected_string(sc, filename), make_integer(sc, line)), NULL, false, 10);
	  else 
	    {
	      if ((line > 0) &&
		  (slot_value(sc->error_line) != sc->F))
		format_to_port(sc, error_port, "\n;  line ~D", list_1(sc, make_integer(sc, line)), NULL, false, 11);
	    }
	}
      else
	{
	  if (call_name)
	    {
	      sc->s7_call_name = NULL;
	      if ((sc->s7_call_file != NULL) &&
		  (sc->s7_call_line >= 0))
		{
		  format_to_port(sc, error_port, "\n;  ~A ~A[~D]",
				 list_3(sc, 
					make_protected_string(sc, call_name), 
					make_protected_string(sc, sc->s7_call_file), 
					make_integer(sc, sc->s7_call_line)), 
				 NULL, false, 13);
		}
	    }
	}
      s7_newline(sc, error_port);
      
      if (is_string(slot_value(sc->error_file)))
	{
	  format_to_port(sc, error_port, ";    ~S, line ~D",
			 list_2(sc, 
				slot_value(sc->error_file),
				slot_value(sc->error_line)),
			 NULL, false, 16);
	  s7_newline(sc, error_port);
	}
      
      /* look for __func__ in the error environment etc
       */
      if (error_port != sc->F)
	{
	  char *errstr;
	  errstr = stacktrace_1(sc, 
				s7_integer(s7_environment_ref(sc, sc->stacktrace_env, s7_make_symbol(sc, "max-frames"))),
				s7_integer(s7_environment_ref(sc, sc->stacktrace_env, s7_make_symbol(sc, "code-cols"))),
				s7_integer(s7_environment_ref(sc, sc->stacktrace_env, s7_make_symbol(sc, "total-cols"))),
				s7_integer(s7_environment_ref(sc, sc->stacktrace_env, s7_make_symbol(sc, "notes-start-col"))),
				s7_boolean(sc, s7_environment_ref(sc, sc->stacktrace_env, s7_make_symbol(sc, "as-comment"))));
	  if (errstr)
	    {
	      port_write_string(error_port)(sc, ";\n", 2, error_port);
	      port_write_string(error_port)(sc, errstr, strlen(errstr), error_port);
	      free(errstr);
	      port_write_character(error_port)(sc, '\n', error_port);
	    }
	}
      else
	{
	  if (is_pair(slot_value(sc->error_code)))
	    {
	      format_to_port(sc, error_port, ";    ~S", list_1(sc, slot_value(sc->error_code)), NULL, false, 7);
	      s7_newline(sc, error_port);
	    }
	}
      
      /* if (s7_is_continuation(type))
       *   go into repl here with access to continuation?  Or expect *error-handler* to deal with it?
       */
      sc->value = type;
      stack_reset(sc);
      sc->op = OP_ERROR_QUIT;
    }

  if (sc->longjmp_ok)
    {
      longjmp(sc->goto_start, 1); /* this is trying to clear the C stack back to some clean state */
    }
  
  return(type);
}


static s7_pointer apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  /* the operator type is needed here else the error message is confusing:
   *    (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)?
   */
  static s7_pointer errstr = NULL;
  if (is_null(obj))
    return(s7_error(sc, sc->SYNTAX_ERROR, list_2(sc, make_protected_string(sc, "attempt to apply nil to ~S?"), args)));
  if (!errstr)
    errstr = s7_make_permanent_string("attempt to apply ~A ~S to ~S?");
  return(s7_error(sc, sc->SYNTAX_ERROR, 
		  list_4(sc, errstr, make_protected_string(sc, type_name(sc, obj, DEFINITE_ARTICLE)), obj, args)));
}


static s7_pointer eval_error(s7_scheme *sc, const char *errmsg, s7_pointer obj)
{
  return(s7_error(sc, sc->SYNTAX_ERROR, list_2(sc, make_protected_string(sc, errmsg), obj)));
}


static s7_pointer eval_error_with_string(s7_scheme *sc, s7_pointer errmsg, s7_pointer obj)
{
  return(s7_error(sc, sc->SYNTAX_ERROR, list_2(sc, errmsg, obj)));
}


static s7_pointer eval_error_with_name_and_string(s7_scheme *sc, s7_pointer errmsg, s7_pointer obj)
{
  static s7_pointer *op_names_saved = NULL;
  int ind;
  ind = (int)(sc->op);
  if (!op_names_saved)
    op_names_saved = (s7_pointer *)calloc(OP_MAX_DEFINED + 1, sizeof(s7_pointer));
  if (!op_names_saved[ind])
    op_names_saved[ind] = s7_make_permanent_string(op_names[ind]);
  return(s7_error(sc, sc->SYNTAX_ERROR, list_3(sc, errmsg, op_names_saved[ind], obj)));
}


static s7_pointer eval_error_with_name(s7_scheme *sc, const char *errmsg, s7_pointer obj)
{
  return(eval_error_with_name_and_string(sc, make_protected_string(sc, errmsg), obj));
}


static s7_pointer eval_error_no_arg(s7_scheme *sc, const char *errmsg)
{
  return(s7_error(sc, sc->SYNTAX_ERROR, list_1(sc, make_protected_string(sc, errmsg))));
}


static s7_pointer read_error(s7_scheme *sc, const char *errmsg)
{
  /* reader 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.
   */
  char *msg;
  int len;
  s7_pointer pt;
  pt = sc->input_port;

  /* make an heroic effort to find where we slid off the tracks */

  if (is_string_port(sc->input_port))
    {
      #define QUOTE_SIZE 40
      unsigned int i, j, start = 0, end, slen;
      char *recent_input = NULL;

      /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */
      if (port_string_point(pt) >= port_string_length(pt))        
	port_string_point(pt) = port_string_length(pt) - 1;

      /* start at current position and look back a few chars */
      for (i = port_string_point(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++)
	if ((port_string(pt)[i] == '\0') ||
	    (port_string(pt)[i] == '\n') ||
	    (port_string(pt)[i] == '\r'))
	  break;
      start = i;

      /* start at current position and look ahead a few chars */
      for (i = port_string_point(pt), j = 0; (i < port_string_length(pt)) && (j < QUOTE_SIZE); i++, j++)
	if ((port_string(pt)[i] == '\0') ||
	    (port_string(pt)[i] == '\n') ||
	    (port_string(pt)[i] == '\r'))
	  break;

      end = i;
      slen = end - start;
      /* hopefully this is more or less the current line where the read error happened */

      if (slen > 0)
	{
	  recent_input = (char *)calloc((slen + 9), sizeof(char));
	  for (i = 0; i < (slen + 8); i++) recent_input[i] = '.';
	  recent_input[3] = ' ';
	  recent_input[slen + 4] = ' ';
	  for (i = 0; i < slen; i++) recent_input[i + 4] = port_string(pt)[start + i];
	}

      if ((port_line_number(pt) > 0) &&
	  (port_filename(pt)))
	{
	  len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64;
	  msg = (char *)malloc(len * sizeof(char));
	  len = snprintf(msg, len, "%s: %s %s[%d], last top-level form at: %s[%d]", 
			 errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt),
			 sc->current_file, sc->current_line);
	}
      else
	{
	  len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64;
	  msg = (char *)malloc(len * sizeof(char));

	  if ((sc->current_file) &&
	      (sc->current_line >= 0))
	    len = snprintf(msg, len, "%s: %s, last top-level form at %s[%d]", 
			   errmsg, (recent_input) ? recent_input : "",
			   sc->current_file, sc->current_line);
	  else len = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : "");
	}
      
      if (recent_input) free(recent_input);
      return(s7_error(sc, sc->READ_ERROR, 
		      list_1(sc, make_string_uncopied_with_length(sc, msg, len))));
    }

  if ((port_line_number(pt) > 0) &&
      (port_filename(pt)))
    {
      len = safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64;
      msg = (char *)malloc(len * sizeof(char));
      len = snprintf(msg, len, "%s %s[%d], last top-level form at %s[%d]", 
		     errmsg, port_filename(pt), port_line_number(pt), 
		     sc->current_file, sc->current_line);
      return(s7_error(sc, sc->READ_ERROR, 
		      list_1(sc, make_string_uncopied_with_length(sc, msg, len))));
    }

  return(s7_error(sc, sc->READ_ERROR, 
		  list_1(sc, make_protected_string(sc, (char *)errmsg))));
}


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."

  if (is_not_null(args))
    {
      if (is_string(car(args)))                    /* CL-style error? -- use tag = 'no-catch */
	{
	  s7_error(sc, make_symbol(sc, "no-catch"), args);
	  return(sc->UNSPECIFIED);
	}
      return(s7_error(sc, car(args), cdr(args)));
    }
  return(s7_error(sc, sc->NIL, sc->NIL));
}


static char *truncate_string(char *form, int len, use_write_t use_write, int *form_len)
{
  if (use_write != USE_DISPLAY)
    {
      /* I guess we need to protect the outer double quotes in this case */
      int i;
      for (i = len - 4; i >= (len / 2); i--)
	if (is_white_space((int)form[i]))
	  {
	    form[i] = '.';
	    form[i + 1] = '.';
	    form[i + 2] = '.';
	    form[i + 3] = '"';
	    form[i + 4] = '\0';
	    (*form_len) = i + 4;
	    return(form);
	  }
      i = len - 4;
      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
    {
      int i;
      for (i = len - 3; i >= (len / 2); i--)
	if (is_white_space((int)form[i]))
	  {
	    form[i] = '.';
	    form[i + 1] = '.';
	    form[i + 2] = '.';
	    form[i + 3] = '\0';
	    (*form_len) = i + 3;
	    return(form);
	  }
      i = len - 3;
      if (i >= 0)
	{
	  form[i] = '.';
	  form[i + 1] = '.';
	  form[i + 2] = '.';
	  form[i + 3] = '\0';
	}
      else form[len] = '\0';
    }
  return(form);
}


static char *object_to_truncated_string(s7_scheme *sc, s7_pointer p, int len)
{
  char *s;
  int s_len;
  s = s7_object_to_c_string(sc, p);
  s_len = safe_strlen(s);
  if (s_len > len)
    return(truncate_string(s, len, USE_DISPLAY, &s_len));
  return(s);
}


static char *missing_close_paren_syntax_check(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer p, old_hook;
  int old_hook_loc;
  char *msg = NULL;
  
  /* this can get into an infinite loop if unbound variable hook gets involved so...
   */
  old_hook = s7_hook_functions(sc, sc->unbound_variable_hook);
  old_hook_loc = s7_gc_protect(sc, old_hook);
  s7_hook_set_functions(sc, sc->unbound_variable_hook, sc->NIL);

  for (p = lst; is_pair(p); p = cdr(p))
    {
      if (is_pair(car(p)))
	{
	  if (is_symbol(caar(p)))
	    {
	      int len;
	      
	      len = s7_list_length(sc, car(p));
	      if (((s7_is_eq(caar(p), s7_make_symbol(sc, "if"))) &&
		   (len > 4)) ||
		  /* extreme care is needed -- we can't risk autoloading the very same file we're complaining about! 
		   *   so don't use unprotected SYMBOL_TO_VALUE or finder
		   */
		  ((s7_is_defined(sc, symbol_name(caar(p)))) &&
		   (s7_is_procedure(SYMBOL_TO_VALUE(sc, caar(p)))) &&
		   (!s7_is_aritable(sc, SYMBOL_TO_VALUE(sc, caar(p)), len))) ||
		  ((s7_is_eq(caar(p), s7_make_symbol(sc, "define"))) &&
		   (is_pair(cdr(p))) &&
		   (is_symbol(cadr(p))) &&
		   (len > 3)))
		{
		  int msg_len, form_len;
		  char *form;
		  /* it's very tricky to try to see other errors here, especially because 'case'
		   *   can have syntax names in its key lists.  Even this may get fooled, but
		   *   I'm hoping that more often than not, it will help track down the missing
		   *   close paren.
		   */

		  form = object_to_truncated_string(sc, car(p), 80);
		  form_len = safe_strlen(form);
		  msg_len = form_len + 128;
		  msg = (char *)calloc(msg_len, sizeof(char));
		  snprintf(msg, msg_len, ";  this looks bogus: %s", form);
		  free(form);

		  s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
		  s7_gc_unprotect_at(sc, old_hook_loc);

		  return(msg);
		}
	    }
	  msg = missing_close_paren_syntax_check(sc, car(p));
	  if (msg) 
	    {
	      s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
	      s7_gc_unprotect_at(sc, old_hook_loc);
	      return(msg);
	    }
	}
    }
  s7_hook_set_functions(sc, sc->unbound_variable_hook, old_hook);
  s7_gc_unprotect_at(sc, old_hook_loc);

  return(NULL);
}

static s7_pointer missing_close_paren_error(s7_scheme *sc)
{
  int len;
  char *msg, *syntax_msg = NULL;
  s7_pointer pt;
  pt = sc->input_port;

  /* it's hard to give a good idea here of where the missing paren is because we've already
   *   popped off all the stacked info, following ')' until eof.
   * but the current incoming program code is in sc->args, reversed at its top level,
   *   so it's worth looking for some problem involving too many clauses (if) or arguments, etc.
   * this can be a hard bug to track down in a large program, so s7 really has to make an effort to help.
   */

  if (is_pair(sc->args))
    {
      sc->x = s7_reverse(sc, sc->args);
      syntax_msg = missing_close_paren_syntax_check(sc, sc->x);
      /* if syntax_msg is null, we didn't find the problem, so perhaps show it indented?
       */
    }

  if ((port_line_number(pt) > 0) &&
      (port_filename(pt)))
    {
      len = port_filename_length(pt) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128;
      msg = (char *)malloc(len * sizeof(char));
      if (syntax_msg)
	{
	  len = snprintf(msg, len, "missing close paren, %s[%d], last top-level form at %s[%d]\n%s", 
			 port_filename(pt), port_line_number(pt), 
			 sc->current_file, sc->current_line, syntax_msg);
	  free(syntax_msg);
	}
      else len = snprintf(msg, len, "missing close paren, %s[%d], last top-level form at %s[%d]", 
			  port_filename(pt), port_line_number(pt), 
			  sc->current_file, sc->current_line);
      return(s7_error(sc, sc->READ_ERROR, make_string_uncopied_with_length(sc, msg, len)));
    }

  if (syntax_msg)
    {
      len = safe_strlen(syntax_msg) + 128;
      msg = (char *)malloc(len * sizeof(char));
      len = snprintf(msg, len, "missing close paren\n%s\n", syntax_msg);
      free(syntax_msg);
      return(s7_error(sc, sc->READ_ERROR, make_string_uncopied_with_length(sc, msg, len)));
    }
  return(s7_error(sc, sc->READ_ERROR, 
		  list_1(sc, make_protected_string(sc, "missing close paren"))));
}


static void improper_arglist_error(s7_scheme *sc)
{
  /* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code
   *   the original was `(,@(reverse args) . ,code) essentially
   */
  if (sc->args == sc->NIL)               /* (abs . 1) */
    s7_error(sc, sc->SYNTAX_ERROR, 
	     list_1(sc, make_protected_string(sc, "function call is a dotted list?")));
  else s7_error(sc, sc->SYNTAX_ERROR, 
		list_2(sc,
		       make_protected_string(sc, "improper list of arguments: ~S"),
		       append_in_place(sc, safe_reverse_in_place(sc, sc->args), sc->code)));
}




/* -------------------------------- leftovers -------------------------------- */


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


static bool call_begin_hook(s7_scheme *sc)
{
  bool result = false;
  /* originally the 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.
   */
  opcode_t op;
  op = sc->op;
  push_stack(sc, OP_BARRIER, sc->args, sc->code);
  sc->begin_hook(sc, &result);
  if (result)
    {
      /* set (error-environment) 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, sc->cur_code);
      slot_set_value(sc->error_line, sc->F);
      slot_set_value(sc->error_file, sc->F);
      next_environment(sc->error_env) = sc->envir;

      sc->value = s7_make_symbol(sc, "begin-hook-interrupt"); 
      /* otherwise the evaluator returns whatever random thing is in sc->value (normally #<closure>)
       *   which makes debugging unnecessarily difficult.
       */
      
      s7_quit(sc);     /* don't call gc here -- perhaps at restart somehow? */
      return(true);
    }
  pop_stack_no_op(sc);
  sc->op = op;         /* for better error handling.  otherwise we get "barrier" as the offending function name in eval_error_with_name */
  return(false);
}


void s7_quit(s7_scheme *sc)
{
  sc->longjmp_ok = false;
  pop_input_port(sc);

  stack_reset(sc);
  push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->NIL);
}


static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) 
{
  s7_pointer p, q;
  /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */
  p = cons(sc, car(d), cdr(d));
  q = p;
  while (is_not_null(cdr(cdr(p))))
    {
      d = cons(sc, car(p), cdr(p));
      p = cdr(p);
    }
  cdr(p) = car(cdr(p));
  return(q);
}


static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
{
  #define H_apply "(apply func ...) applies func to the rest of the arguments"

  sc->code = car(args);
  if (is_null(cdr(args)))
    sc->args = sc->NIL;
  else 
    {
      if (is_safe_procedure(sc->code))
	{
	  s7_pointer p, q;

	  for (q = args, p = cdr(args); is_not_null(cdr(p)); q = p, p = cdr(p));
	  /* the last arg is supposed to be a list, it will be spliced onto the end of the previous arg list (if any) below */

	  if (!is_proper_list(sc, car(p)))        /* (apply + #f) etc */
	    return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			    list_2(sc, 
				   make_protected_string(sc, "apply's last argument should be a proper list: ~S"),
				   args)));
	  cdr(q) = car(p);                       
	  push_stack(sc, OP_APPLY, cdr(args), sc->code);
	  return(sc->NIL);
	}
      else
	{
	  /* here we have to copy the arg list */
	  if (is_null(cddr(args)))
	    sc->args = cadr(args);
	  else sc->args = apply_list_star(sc, cdr(args));

	  if (!is_proper_list(sc, sc->args))        /* (apply + #f) etc */
	    return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			    list_2(sc, 
				   make_protected_string(sc, "apply's last argument should be a proper list: ~S"),
				   args)));
	}
    }

  if (is_any_macro(sc->code))                   /* (apply mac '(3)) -> (apply mac '((mac 3))) */
    {
      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
      sc->args = list_1(sc, cons(sc, sc->code, sc->args));
    }
  push_stack(sc, OP_APPLY, sc->args, sc->code);
  return(sc->NIL);
}


s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e)
{
  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
  sc->code = code;
  if ((e != sc->global_env) &&
      (is_environment(e)))
    sc->envir = e; 
  else sc->envir = sc->NIL; /* can't check is_environment(e) because sc->global_env sets its type to t_env! */
  eval(sc, OP_BEGIN);
  return(sc->value);
}


s7_pointer s7_eval_form(s7_scheme *sc, s7_pointer form, s7_pointer e)
{
  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
  sc->code = form;
  if ((e != sc->global_env) &&
      (is_environment(e)))
    sc->envir = e; 
  else sc->envir = sc->NIL;
  eval(sc, OP_EVAL);
  return(sc->value);
}


static s7_pointer g_eval(s7_scheme *sc, s7_pointer args)
{
  #define H_eval "(eval code (env (current-environment))) evaluates code in the environment env. 'env' \
defaults to the current environment; to evaluate something in the top-level environment instead, \
pass (global-environment):\n\
\n\
  (define x 32) \n\
  (let ((x 3))\n\
    (eval 'x (global-environment)))\n\
\n\
  returns 32"
  
  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_environment(e))
	return(wrong_type_argument_with_type(sc, sc->EVAL, small_int(2), e, AN_ENVIRONMENT));
      if (e == sc->global_env)
	sc->envir = sc->NIL;
      else sc->envir = e;
    }
  sc->code = car(args);

  if (s7_stack_top(sc) < 12)
    push_stack(sc, OP_BARRIER, sc->NIL, sc->NIL);
  push_stack(sc, OP_EVAL, sc->args, sc->code);

  return(sc->NIL);
}


s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
{
  bool old_longjmp;
  jmp_buf old_goto_start;

  /* this can be called while we are in the eval loop (within eval_c_string for instance),
   *   and if we reset the stack, the previously running evaluation steps off the end
   *   of the stack == segfault. 
   */
  if (is_c_function(func))
    return(c_function_call(func)(sc, args));  /* no check for wrong-number-of-args -- is that reasonable? */

  sc->temp1 = func; /* this is just GC protection */
  sc->temp2 = args;

  old_longjmp = sc->longjmp_ok;
  memcpy((void *)old_goto_start, (void *)(sc->goto_start), sizeof(jmp_buf));

  /* if an error occurs during s7_call, and it is caught, catch (above) wants to longjmp
   *   to its caller to complete the error handler evaluation so that the C stack is
   *   cleaned up -- this means we have to have the longjmp location set here, but
   *   we could get here from anywhere, so we need to save and restore the incoming
   *   longjmp location.
   */

  sc->longjmp_ok = true;
  if (setjmp(sc->goto_start) != 0) /* returning from s7_error catch handler */
    {
      sc->longjmp_ok = old_longjmp;
      memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));
      
      if ((sc->op == OP_ERROR_QUIT) &&
	  (sc->longjmp_ok))
	{
	  longjmp(sc->goto_start, 1); /* this is trying to clear the C stack back to some clean state */
	}

      eval(sc, sc->op); 
      /* sc->op can be OP_APPLY if s7_call raised an error that was caught (via catch) -- we're about to go to the error handler */
      return(sc->value);
    }

  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
  sc->args = args; 
  sc->code = func; 

  /* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example
   */

  eval(sc, OP_APPLY);

  sc->longjmp_ok = old_longjmp;
  memcpy((void *)(sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));

  return(sc->value);
} 


s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, int line)
{ 
  s7_pointer result;

  if (caller)
    {
      sc->s7_call_name = caller;
      sc->s7_call_file = file;
      sc->s7_call_line = line;
    }

  result = s7_call(sc, func, args);
  
  if (caller)
    {
      sc->s7_call_name = NULL;
      sc->s7_call_file = NULL;
      sc->s7_call_line = -1;
    }

  return(result);
}


static s7_pointer g_s7_version(s7_scheme *sc, s7_pointer args)
{
  #define H_s7_version "(s7-version) returns some string describing the current s7"
#if WITH_COUNTS
  report_counts(sc);
#endif
  return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE));
}


static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args)
{
  #define H_emergency_exit "(emergency-exit obj) exits s7 immediately"
  s7_pointer obj;
#ifndef EXIT_SUCCESS 
  #define EXIT_SUCCESS 0
  #define EXIT_FAILURE 1
#endif
  if (is_null(args))
    _exit(EXIT_SUCCESS);          /* r7rs spec says use _exit here */
  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(obj));
  return(sc->F);
}


static s7_pointer g_exit(s7_scheme *sc, s7_pointer args)
{
  #define H_exit "(exit obj) exits s7"
  s7_quit(sc);
  return(g_emergency_exit(sc, args));
}


#if DEBUGGING
static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort();}
#endif



/* ---------------------------------------- map and for-each ---------------------------------------- */

static s7_Int applicable_length(s7_scheme *sc, s7_pointer obj)
{
  switch (type(obj))
    {
    case T_PAIR:
      {
	s7_Int len;
	len = s7_list_length(sc, obj);
	if (len < 0)             /* dotted (does not include the final cdr -- perhaps this is a bug) */
	  return(-len);          /*         it means that (map abs '(1 . "hi")) returns '(1) */
	if (len == 0)            /* circular */
	  return(S7_LONG_MAX);
	return(len);
      }

    case T_C_OBJECT:
      return(object_length_to_int(sc, obj));

    case T_STRING:
      return(string_length(obj));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(vector_length(obj));

    case T_HASH_TABLE:
      return(hash_table_entries(obj));

    case T_ENVIRONMENT:
      return(environment_length(sc, obj));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(obj))
	return(closure_length(sc, obj));
      return(-1);

    case T_NIL:
      return(0);
    }
  
  return(-1);
}


static bool next_for_each(s7_scheme *sc)
{
  s7_pointer x, y, z, vargs, fargs;
  int loc, zloc = -1;

  z = sc->NIL;

  vargs = counter_list(sc->args);
  fargs = counter_result(sc->args);
  loc = counter_count(sc->args);

  /* for-each func ... -- each trailing sequence arg contributes one arg to the current call on func, 
   *   so in the next loop, gather one arg from each sequence.
   *   environments are turned into lists at the start.
   */

  for (x = fargs, y = vargs; is_not_null(x); x = cdr(x), y = cdr(y))
    {
      s7_pointer car_y;
      car_y = car(y);
      switch (type(car_y))
	{
	case T_PAIR:
	  car(x) = car(car_y);
	  car(y) = cdr(car_y);
	  break;
	  
	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:
	  car(x) = vector_getter(car_y)(sc, car_y, loc); 
	  break;
	  
	case T_STRING:
	  if (is_bytevector(car_y))
	    car(x) = small_int((unsigned int)string_value(car_y)[loc]);
	  else car(x) = s7_make_character(sc, ((unsigned char)(string_value(car_y)[loc])));
	  break;
	  
	case T_C_OBJECT:
	case T_CLOSURE:
	case T_CLOSURE_STAR:
	  {
	    int save_x = -1, save_y = -1, save_z = -1;
	    if (is_null(z))
	      {
		z = list_1(sc, make_integer(sc, loc));
		/* we can't use car(sc->args) directly here -- it is a counter.
		 *   the object application (the getter function) might return the index.
		 *   Then, if we pre-increment, the for-each application sees the incremented value.
		 */
		zloc = s7_gc_protect(sc, z);
	      }
	    
	    SAVE_X_Y_Z(save_x, save_y, save_z);
	    if (type(car_y) == T_C_OBJECT)
	      car(x) = (*(c_object_ref(car_y)))(sc, car_y, z);
	    else car(x) = s7_apply_function(sc, car_y, z);
	    /* (define fv (float-vector 1 2 3)) (for-each (lambda (x) (format #t "~A~%" x)) fv) */
	    RESTORE_X_Y_Z(save_x, save_y, save_z);
	  }
	  break;
	  
	default:           /* see comment in next_map: (let ((L (list 1 2 3 4 5))) (for-each (lambda (x) (set-cdr! (cddr L) 5) (display x)) L)) */
	  if (is_not_null(z))
	    s7_gc_unprotect_at(sc, zloc);
	  return(false);
	  break;
	}
    }

  if (zloc != -1)
    s7_gc_unprotect_at(sc, zloc);

  counter_count(sc->args) = loc + 1;
  push_stack(sc, OP_FOR_EACH, sc->args, sc->code);
  sc->args = fargs;

  if (is_macro(sc->code))
    {
      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
      /* we can use a temp here because the arg list will be copied in OP_FOR_EACH */
      car(sc->temp_cell_1) = sc->code;
      cdr(sc->temp_cell_1) = sc->args;
      sc->args = sc->temp_cell;
    }
  return(true);
}


static s7_pointer make_counter(s7_scheme *sc, s7_pointer result, s7_pointer lst, long long int count, long long int length)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  counter_result(x) = result;
  counter_list(x) = lst;
  counter_count(x) = count;
  counter_length(x) = length;
  counter_environment(x) = sc->NIL;
  set_type(x, T_COUNTER);
  return(x);
}


static s7_pointer make_simple_counter(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer x;
  NEW_CELL(sc, x);
  counter_result(x) = sc->NIL;
  counter_list(x) = lst;
  counter_count(x) = 0;
  counter_length(x) = 0;
  counter_environment(x) = sc->NIL;
  set_type(x, T_COUNTER);
  return(x);
}


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 (the normal case), string, vector, hash-table, or any applicable object."

  /* (for-each (lambda (n) (format #t "~A " n)) (vct 1.0 2.0 3.0)) */
  s7_Int len = 0; 
  /* "int" here is unhappy on 64-bit machines, and "long int" is unhappy on 32-bit machines, so try long long int.
   *    string_length is an int.
   */
  s7_pointer obj, x;
  static s7_pointer errstr1 = NULL, errstr2 = NULL;

  sc->code = car(args); /* the function */
  if (!is_applicable(sc->code))
    return(wrong_type_argument_with_type(sc, sc->FOR_EACH, small_int(1), sc->code, SOMETHING_APPLICABLE));

  /* macro application requires the entire call as the argument to apply, but apply itself fixes this up.
   *  that is, g_apply checks, then goes to OP_EVAL_MACRO after OP_APPLY with the fixed up list,
   *  but here we are simply sending it to OP_APPLY, so
   *
   *    (define-macro (hi a) `(+ ,a 1))
   *    (apply hi '(1))                 ; internally rewritten as (apply hi '((hi 1)))
   *    2                               ; apply adds the evaluation if its first arg is a macro
   *    (map hi '((hi 1) (hi 2)))       ; here we've rewritten the arg lists by hand
   *    ((+ 1 1) (+ 2 1))               ; but no evaluation
   *
   * ideally I think it should be
   *
   *    (map hi '(1 2))
   *    (2 3)
   *
   * OP_APPLY knows this is happening (in the second case) and raises an error -- what would break
   *   if we handle it locally instead?  This actually affects only T_C_MACRO (quasiquote) --
   *   normal macros/bacros would still be broken.
   * or could we rewrite the args to fit just as in apply? (also need the evaluation)
   */

  /* before checking len=0, we need to check that the arguments are all sequences (this is like our handling of args to + for example)
   *   otherwise (for-each = "" 123) -> #<unspecified> 
   * the function may not actually be applicable to its sequence elements, but that isn't an error:
   *   (map abs "") -> '()
   * and the function's max arity might be less than the number of sequences, but that also isn't an error!
   *   (let ((x 0)) (for-each (lambda* (a) (set! x (+ x a))) (list :a :a :a) (list 1 2 3)) x)
   *   where :a is the keyword argname (hi :a 1) etc
   */
  obj = cadr(args); 

  if ((is_pair(obj)) &&                                               /* arg is a list */
      (is_null(cddr(args))))                                          /* only one list arg */
    {
      len = s7_list_length(sc, obj);
      if (len > 0)                                                    /* a proper list arg */
	{
	  if ((type(sc->code) == T_CLOSURE) &&                        /* not lambda* that might get confused about arg names */
	      (closure_arity_to_int(sc, sc->code) == 1) &&            /* not a rest arg: not is_pair: (lambda (x . args) arg) */
	      (!is_immutable(car(closure_args(sc->code)))) &&         /* not a bad arg name! */
	      (!symbol_has_accessor(car(closure_args(sc->code)))))    /* not wrapped in an accessor */
	    {
	      /* one list arg -- special, but very common case
	       */
	      obj = make_simple_counter(sc, obj); /* counter_list(sc->args) => original list (cadr(args)) */
	      push_stack(sc, OP_FOR_EACH_SIMPLE, obj, sc->code);
	      return(sc->UNSPECIFIED);

	      /* this, and map, across a string (say) or other sequence involving
	       *   only 1 arg could be optimized in the same way. OP_FOR_EACH|MAP_STRING|VECTOR|C_OBJECT
	       */

	      /* if len is 1 can't we just call apply?
	       */
	    }

	  if ((is_safe_procedure(sc->code)) &&
	      (is_c_function(sc->code)) &&
	      (s7_is_aritable(sc, sc->code, 1)))
	    {
	      s7_function func;
	      s7_pointer p;
	      func = c_function_call(sc->code);
	      for (p = obj; is_pair(p); p = cdr(p))
		{
		  car(sc->T1_1) = car(p);
		  (*func)(sc, sc->T1_1);
		}
	      return(sc->UNSPECIFIED);
	    }
	}

      if (len < 0)
	len = -len; 
      else
	if (len == 0) 
	  len = S7_LONG_MAX;
    }
  else 
    {
      for (x = cdr(args); is_not_null(x); x = cdr(x))
	{
	  s7_Int nlen;
	  if (!is_sequence(car(x)))
	    {
	      if (!errstr1)
		errstr1 = s7_make_permanent_string("a sequence");
	      return(wrong_type_argument_n_with_type(sc, sc->FOR_EACH, position_of(x, args), car(x), errstr1));
	    }
	  nlen = applicable_length(sc, car(x));
	  if (nlen < 0)
	    {
	      if (!errstr2)
		errstr2 = s7_make_permanent_string("a vector, list, string, hash-table, or applicable object");
	      return(wrong_type_argument_n_with_type(sc, sc->FOR_EACH, position_of(x, args), car(x), errstr2));
	    }
	  if ((x == cdr(args)) || (nlen < len))
	    len = nlen;
	  if (len == 0) 
	    {
	      for (x = cdr(x); is_not_null(x); x = cdr(x))
		if (!is_sequence(car(x)))
		  {
		    if (!errstr1)
		      errstr1 = s7_make_permanent_string("a sequence");
		    return(wrong_type_argument_n_with_type(sc, sc->FOR_EACH, position_of(x, args), car(x), errstr1));
		  }
	      break;   /* need error check below */
	    }
	}
    }

  if (len != 0)
    {
      sc->x = list_1(sc, sc->NIL);
      if (is_hash_table(obj))
	sc->z = list_1(sc, g_make_hash_table_iterator(sc, cdr(args)));
      else 
	{ 
	  /* (let ((a 1) (b 2)) (for-each (lambda (slot) (format #t "~A~%" slot)) (current-environment))) */
	  if (is_environment(obj))
	    sc->z = list_1(sc, s7_environment_to_list(sc, obj));
	  else sc->z = list_1(sc, obj);
	}

      /* we have to copy the args if any of them is a list:
       *     (let* ((x (list (list 1 2 3))) (y (apply for-each abs x))) (list x y))
       *  (is this trying to say that the for-each loop might otherwise change the original list as it cdrs down it?)
       */

      if (is_not_null(cddr(args)))
	{
	  for (x = cddr(args); is_not_null(x); x = cdr(x))
	    {
	      sc->x = cons(sc, sc->NIL, sc->x);          /* we're making a list to be filled in later with the individual args */

	      if (is_hash_table(car(x)))
		sc->z = cons_unchecked(sc, g_make_hash_table_iterator(sc, x), sc->z);
	      else
		{
		  if (is_environment(car(x)))
		    sc->z = cons(sc, s7_environment_to_list(sc, car(x)), sc->z);
		  else sc->z = cons_unchecked(sc, car(x), sc->z);
		}
	    }
	}
    }
  else /* len == 0 and  we checked for non-applicable first arg above */
    return(sc->UNSPECIFIED);    /* circular -> S7_LONG_MAX in this case, so 0 -> nil */

  if (len == S7_LONG_MAX)
    {
      /* if at this point len == S7_LONG_MAX, then all args are circular lists, assuming that
       *    we're not looking at some enormous vector or string -- perhaps -1 would be a
       *    better marker.  This actually might not be an error (the for-each function could
       *    have call-with-exit), but it seems better to complain about it.
       * 
       * this means that a make-type generator's length is tricky:
       *    (let ((ctr ((cadr (make-type :getter (lambda (a b) b) :length (lambda (a) (- (expt 2 31) 1)))))) (sum 0))
       *      (call-with-exit (lambda (go) (for-each (lambda (a) (set! sum (+ sum a)) (if (> sum 100) (go sum))) ctr))))
       * returns an error about circular lists, but should return 105.
       *
       * I think I'll at least check that the args were in fact lists.
       */
      for (x = cdr(args); (is_pair(x)) && (is_pair(car(x))); x = cdr(x)) {}
      if (!is_pair(x))
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "for-each's arguments are circular lists! ~S"), cdr(args))));
    }

  /* (for-each (lambda () 1) (list 1 2 3)) */
  if ((is_closure(sc->code)) &&
      (closure_arity_to_int(sc, sc->code) == 0))
    return(s7_error(sc, sc->WRONG_TYPE_ARG, list_1(sc, make_protected_string(sc, "for-each function is a thunk")))); 

  sc->y = args;
  sc->args = make_counter(sc, sc->x, safe_reverse_in_place(sc, sc->z), 0, len);
  /* counter_result: func-arglist, counter_list: objects, counter_count: current count, counter_length: applicable length */

  sc->x = sc->NIL;
  sc->y = sc->NIL;
  sc->z = sc->NIL;
  push_stack(sc, OP_FOR_EACH, sc->args, sc->code);
  return(sc->UNSPECIFIED);
}



static bool is_lambda(s7_scheme *sc, s7_pointer sym)
{
  return((sym == sc->LAMBDA) && (symbol_id(sym) == 0));
  /* symbol_id==0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */
}


/* also call-with-exit/catch/map etc */

static s7_pointer for_each_1;
static s7_pointer g_for_each_1(s7_scheme *sc, s7_pointer args)
{
  /* first arg is (lambda (sym) ...) when sym has no complications, only 2 args passed
   */
  s7_pointer obj;
  s7_Int len;

  obj = cadr(args);
  if (!is_pair(obj))
    return(g_for_each(sc, args));
  
  len = s7_list_length(sc, obj);
  if (len == 0)                   /* circular list */
    return(g_for_each(sc, args)); /* this is faster than calling s7_error here -- weird! */
  obj = make_simple_counter(sc, obj);

  push_stack(sc, OP_FOR_EACH_SIMPLE, obj, car(args));
  return(sc->UNSPECIFIED);
}

static s7_pointer for_each_2;
static s7_pointer g_for_each_2(s7_scheme *sc, s7_pointer args)
{
  /* first arg is (lambda (sym) (...)) -- one pair in lambda, when sym has no complications, only 2 args passed
   */
  s7_pointer obj;
  s7_Int len;

  obj = cadr(args);
  if (!is_pair(obj))
    return(g_for_each(sc, args));
  
  len = s7_list_length(sc, obj);
  if (len == 0)                   /* circular list */
    return(g_for_each(sc, args)); /* this is faster than calling s7_error here -- weird! */
  obj = make_simple_counter(sc, obj);

  push_stack(sc, OP_FOR_EACH_SIMPLER, obj, car(args));
  return(sc->UNSPECIFIED);
}

/* for_each_2: (let () (define (f b) b) (define (hi) (let ((lst '(1 2 3))) (for-each (lambda (a) (f a)) lst))) (hi))
 * for_each_1: (let () (define (f b) b) (define (hi) (let ((lst '(1 2 3))) (for-each (lambda (a) 123 (f a)) lst))) (hi))
 */

static s7_pointer for_each_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      s7_pointer lexpr;
      lexpr = cadr(expr);

      if (is_lambda(sc, car(lexpr)))
	{
	  s7_pointer largs, lbody;

	  largs = cadr(lexpr);
	  lbody = cddr(lexpr);

      	  if ((is_pair(largs)) &&
	      (is_null(cdr(largs))) &&
	      (!is_immutable(car(largs))) &&
	      (!symbol_has_accessor(car(largs))))
	    {
	      if ((is_pair(car(lbody))) &&
		  (is_null(cdr(lbody))))
		return(for_each_2);
	      return(for_each_1); 
	    }
	}
      /* (define (hi) (for-each (lambda (a) a) (values '(1 2 3) '(3 2 1))))
       *   which currently won't be optimized
       */
    }
  return(f);
}

/* extending this to map made little difference 
 */


static bool next_map(s7_scheme *sc)
{
  s7_pointer y, z, vargs;
  int loc, zloc = -1;

  z = sc->NIL;
  vargs = counter_list(sc->args);
  loc = counter_count(sc->args);
  sc->x = sc->NIL;                     /* can't use preset args list here (as in for-each): (map list '(a b c)) */

  for (y = vargs; is_not_null(y); y = cdr(y))
    {
      s7_pointer x, car_y;
      car_y = car(y);
      switch (type(car_y))
	{
	case T_PAIR:
	  x = car(car_y);
	  car(y) = cdr(car_y);
	  break;
	  
	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:
	  x = vector_getter(car_y)(sc, car_y, loc); 
	  break;

	case T_STRING:
	  if (is_bytevector(car_y))
	    x = small_int((unsigned int)string_value(car_y)[loc]);
	  else x = s7_make_character(sc, ((unsigned char)(string_value(car_y)[loc])));
	  break;

	case T_C_OBJECT: 
	case T_CLOSURE:
	case T_CLOSURE_STAR:
	  {
	    int save_x = -1, save_y = -1, save_z = -1;
	    if (is_null(z))
	      {
		z = list_1(sc, make_integer(sc, loc));
		zloc = s7_gc_protect(sc, z);
	      }
	    SAVE_X_Y_Z(save_x, save_y, save_z);
	    if (type(car_y) == T_C_OBJECT)
	      x = (*(c_object_ref(car_y)))(sc, car_y, z);
	    else x = s7_apply_function(sc, car_y, z);
	    /* (define fv (float-vector 1 2 3)) (map (lambda (x) x) fv) */
	    RESTORE_X_Y_Z(save_x, save_y, save_z);
	  }
	  break;

	default: 
	  /* this can happen if one of the args is clobbered by the map function, so our initial
	   *   length is messed up:
	   *   (let ((L (list 1 2 3 4 5))) (map (lambda (x) (set-cdr! (cddr L) 5) x) L))
	   */

	  if (is_not_null(z))
	    s7_gc_unprotect_at(sc, zloc);
	  return(false);                  /* this stops the map process, so the code mentioned above returns '(1 2 3) */
	  break;
	}
      
      sc->x = cons(sc, x, sc->x);
    }

  if (is_not_null(z))
    s7_gc_unprotect_at(sc, zloc);
  sc->x = safe_reverse_in_place(sc, sc->x);

  counter_count(sc->args) = loc + 1;
  push_stack(sc, OP_MAP, sc->args, sc->code);
  sc->args = sc->x;
  sc->x = sc->NIL;

  if (is_macro(sc->code))
    {
      /* (let ((lst '(1 2 3))) 
       *   (define-macro (hiho a) `(+ 1 ,a)) 
       *   (map hiho lst)) 
       * -> '(2 3 4)
       *
       * but this can be very confusing!  quasiquote is considered to be a macro, so
       *    (map quasiquote '((1 2) (3 4))) -> (2 4)
       * because map (or apply?) thinks the 1 and 3 are macro names!
       */
      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
      car(sc->temp_cell_1) = sc->code;
      cdr(sc->temp_cell_1) = sc->args;
      sc->args = sc->temp_cell;
    }

  return(true);
}


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."

  s7_Int len;
  s7_pointer obj, x;
  static s7_pointer errstr1 = NULL, errstr2 = NULL;

  sc->code = car(args);
  if (!is_applicable(sc->code))
    return(wrong_type_argument_with_type(sc, sc->MAP, small_int(1), sc->code, SOMETHING_APPLICABLE));

  sc->y = args;                     /* gc protect */
  obj = cadr(args); 

  /* there are two simple cases here: a safe function can be handled immediately, and a closure
   *   with one arg called with one list can be handled without all the elaborate run-time checks.
   */

  if ((is_pair(obj)) &&                                               /* arg is a list */
      (is_null(cddr(args))))                                          /* only one list arg */
    {
      len = s7_list_length(sc, obj);
      if (len > 0)                                                    /* a proper list arg */
	{
	  if ((type(sc->code) == T_CLOSURE) &&                        /* not lambda* that might get confused about arg names */
	      (closure_arity_to_int(sc, sc->code) == 1) &&            /* not a rest arg, not is_pair here: (lambda (x . args) args) */
	      (!is_immutable(car(closure_args(sc->code)))) &&         /* not a bad arg name! */
	      (!symbol_has_accessor(car(closure_args(sc->code)))))    /* not wrapped in an accessor */
	    {
	      push_stack(sc, OP_MAP_SIMPLE, make_counter(sc, sc->NIL, obj, len, 0), sc->code);
	      return(sc->NO_VALUE);
	    }

	  if ((is_safe_procedure(sc->code)) &&
	      (is_c_function(sc->code)) &&
	      (s7_is_aritable(sc, sc->code, 1)))
	    {
	      s7_pointer p;
	      s7_function func;

	      func = c_function_call(sc->code);
	      sc->x = sc->NIL;
	      for (p = obj; is_pair(p); p = cdr(p))
		{
		  car(sc->T1_1) = car(p);
		  sc->x = cons(sc, (*func)(sc, sc->T1_1), sc->x); /* can we assume a safe function won't return multiple values? */
		}
	      p = safe_reverse_in_place(sc, sc->x);
	      sc->x = sc->NIL;

	      return(p);
	    }
	}

      if (len < 0)
	len = -len; 
      else
	if (len == 0) 
	  len = S7_LONG_MAX;
    }
  else len = applicable_length(sc, obj);

  if (len < 0)
    {
      if (!errstr1)
	errstr1 = s7_make_permanent_string("a vector, list, string, hash-table, or applicable object");
      return(wrong_type_argument_with_type(sc, sc->MAP, small_int(2), obj, errstr1));
    }

  for (x = cddr(args); is_not_null(x); x = cdr(x))
    if (!is_sequence(car(x)))
      {
	if (!errstr2)
	  errstr2 = s7_make_permanent_string("a sequence");
	return(wrong_type_argument_n_with_type(sc, sc->MAP, position_of(x, args), car(x), errstr2));
      }

  if (len != 0)
    {
      if (is_hash_table(obj))
	sc->z = list_1(sc, g_make_hash_table_iterator(sc, cdr(args)));
      else 
	{
	  if (is_environment(obj))
	    sc->z = list_1(sc, s7_environment_to_list(sc, obj));
	  else sc->z = list_1(sc, obj);
	}

      /* we have to copy the args if any of them is a list:
       * (let* ((x (list (list 1 2 3))) (y (apply map abs x))) (list x y))
       */
      
      if (is_not_null(cddr(args)))
	{
	  for (x = cddr(args); is_not_null(x); x = cdr(x))
	    {
	      s7_Int nlen;
	      
	      nlen = applicable_length(sc, car(x));
	      if (nlen < 0)
		return(wrong_type_argument_n_with_type(sc, sc->MAP, position_of(x, args), car(x), 
						       make_protected_string(sc, "a vector, list, string, hash-table, or applicable object")));
	      if (nlen < len) len = nlen;
	      if (len == 0) break; /* need error check below */
	      
	      if (is_hash_table(car(x)))
		sc->z = cons(sc, g_make_hash_table_iterator(sc, x), sc->z);
	      else
		{
		  if (is_environment(car(x)))
		    sc->z = cons_unchecked(sc, s7_environment_to_list(sc, car(x)), sc->z);
		  else sc->z = cons_unchecked(sc, car(x), sc->z);
		}
	    }
	}
    }

  if (len == 0)   /* (map 1 "hi" '()) */
    return(sc->NIL);    /* obj has no elements (the circular list case will return S7_LONG_MAX here) */

  if (len == S7_LONG_MAX)
    {
      /* all args are circular lists, or perhaps an odd scheme type (see comment under for-each) */
      for (x = cdr(args); (is_pair(x)) && (is_pair(car(x))); x = cdr(x)) {}
      if (!is_pair(x))
	return(s7_error(sc, sc->WRONG_TYPE_ARG, 
			list_2(sc, make_protected_string(sc, "map's arguments are circular lists! ~S"), cdr(args))));
    }

  /* (for-each (lambda () 1) (list 1 2 3)) */
  if ((is_closure(sc->code)) &&
      (closure_arity_to_int(sc, sc->code) == 0))
    return(s7_error(sc, sc->WRONG_TYPE_ARG, list_1(sc, make_protected_string(sc, "map function is a thunk")))); 

  sc->args = make_counter(sc, sc->NIL, safe_reverse_in_place(sc, sc->z), 0, len);
  sc->y = sc->NIL;
  sc->z = sc->NIL;
  if (next_map(sc))
    push_stack(sc, OP_APPLY, sc->args, sc->code);

  return(sc->NIL);
}



/* -------------------------------- multiple-values -------------------------------- */

static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
{
  if (sc->stack_end > sc->stack_start)
    {
      int top;
      s7_pointer x;
      top = s7_stack_top(sc) - 1;

      switch (stack_op(sc->stack, top))
	{
	  /* 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's 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.
	   */
	  for (x = args; is_not_null(cdr(x)); x = cdr(x))
	    stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top));
	  return(car(x));

	  /* in the next set, the main evaluator branches blithly assume no multiple-values,
	   *   and if it happens anyway, we vector to a different branch here 
	   */
	case OP_SAFE_C_opSq_P_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_opSq_P_MV;
	  return(args);

	case OP_EVAL_ARGS_P_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_P_1_MV;
	  return(args);

	case OP_EVAL_ARGS_SSP_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_SSP_MV;
	  return(args);

	case OP_EVAL_ARGS_P_2:
	  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_P_2_MV;
	  return(args);

	case OP_EVAL_ARGS_P_3:
	  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_P_3_MV;
	  return(args);

	case OP_EVAL_ARGS_P_4:
	  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_P_4_MV;
	  return(args);

	case OP_C_P_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_C_P_2;
	  return(args);

	case OP_C_SP_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_C_SP_2;
	  return(args);

	case OP_SAFE_C_PP_1:
	  vector_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_3;
	  return(args);

	case OP_SAFE_C_PP_2:
	  vector_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_4;
	  return(args);

	case OP_SAFE_C_PP_5:
	  vector_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_6;
	  return(args);

	case OP_EVAL_ARGS5:
	  /* code = previous arg saved, args = ante-previous args reversed
	   *   we'll take value->code->args and reverse in args5
	   *   if one value, return it, else
	   *      put code onto args, splice as above until there are 2 left
	   *      set code to first and value to last
	   */
	  if (is_null(args))
	    return(sc->UNSPECIFIED);

	  if (is_null(cdr(args)))
	    return(car(args));

	  stack_args(sc->stack, top) = cons(sc, stack_code(sc->stack, top), stack_args(sc->stack, top));
	  for (x = args; is_not_null(cddr(x)); x = cdr(x))
	    stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top));
	  stack_code(sc->stack, top) = car(x);
	  return(cadr(x));

	  /* look for errors here rather than glomming up the set! and let code */
	case OP_SET_SAFE:
	case OP_SET1:                                             /* (set! var (values 1 2 3)) */
	  set_multiple_value(args);
	  return(eval_error(sc, "can't set! some variable to ~S", args));

	case OP_SET_PAIR_P_1:
	case OP_SET_PAIR_C_P_1:
	  set_multiple_value(args);
	  return(eval_error(sc, "too many values to set! ~S", args));

	case OP_LET1:                                             /* (let ((var (values 1 2 3))) ...) */
	case OP_LET_STAR1:
	case OP_LETREC1:
	case OP_LET_O1:
	case OP_LET_O2:
	case OP_LET_O3:
	  set_multiple_value(args);
	  return(eval_error_with_name_and_string(sc, BAD_BINDING, args)); /* "~A: can't bind some variable to ~S" */

	  /* handle 'and' and 'or' specially */
	case OP_AND1:
	  for (x = args; is_not_null(cdr(x)); x = cdr(x))
	    if (car(x) == sc->F)
	      return(sc->F);
	  return(car(x));

	case OP_OR1:
	  for (x = args; is_not_null(cdr(x)); x = cdr(x))
	    if (car(x) != sc->F)
	      return(car(x));
	  return(car(x));

	case OP_BARRIER: 
	  pop_stack(sc);
	  return(splice_in_values(sc, args));

	case OP_BEGIN1:
	case OP_CATCH_1:
	  /* 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))
	   * the catch case is much more obscure. I think the begin check handles others like for-each(?).
	   */
	  return(args);

	default:
	  break;
	}
    }

  /* let it meander back up the call chain until someone knows where to splice it */
  set_multiple_value(args);
  return(args);
}


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')"

  if (is_null(args))
    {
      opcode_t op;
      op = stack_op(sc->stack, s7_stack_top(sc) - 1);
      if ((op == OP_SET1) || /* (set! var (values)) */
	  (op == OP_SET_SAFE))
	return(eval_error(sc, "set!: can't assign (values) to something: ~A", args));

      return(sc->NO_VALUE); 
    }

  /* this was sc->NIL until 16-Jun-10, 
   *   nil is consistent with the implied values call in call/cc (if no args, the continuation function returns '())
   *   hmmm... 
   *   Guile complains ("too few values returned to continuation") in the call/cc case, and
   *   (equal? (if #f #f) (* (values))) complains "Zero values returned to single-valued continuation"
   *   so perhaps call/cc should also return #<unspecified> -- I don't know what is best.
   *
   * a note in the scheme bboard:
   *
   *  This would work in s7:
   *
   *  (define (print-concat . args) 
   *    (if (or (null? args)               ; (print-concat)
   *            (eq? (car args) (values))) ; (print-concat arg1 ...)
   *        (newline) 
   *      (begin 
   *        (display (car args)) 
   *        (print-concat (apply values (cdr args))))))
   *  
   *  but it's a bit ugly.  I think (values) should be the same as
   *  (apply values '()). It's currently #<unspecified>, mainly for
   *  historical reasons (a lot of the code s7 is used with
   *  assumes that behavior).  If (values) simply vanished,
   *  then code like (abs -1 (values)) is not an error.
   *  If it returned nil, you get inconsistencies elsewhere:
   *  (values) now is the same as (values '()) which is
   *  (apply values '(())).  This also affects quasiquote 
   *  (s7 uses (apply values ...) for unquote-splicing).
   *
   * But that makes me think that (eval) should return #<unspecified>. What about (eval-string)?
   */
  
  if (is_null(cdr(args)))
    return(car(args));

  return(splice_in_values(sc, args));
}


s7_pointer s7_values(s7_scheme *sc, int num_values, ...)
{
  int i;
  va_list ap;
  s7_pointer p;
  
  if (num_values == 0)
    return(sc->NIL);

  sc->w = sc->NIL;
  va_start(ap, num_values);
  for (i = 0; i < num_values; i++)
    sc->w = cons(sc, va_arg(ap, s7_pointer), sc->w);
  va_end(ap);

  p = sc->w;
  sc->w = sc->NIL;

  return(g_values(sc, safe_reverse_in_place(sc, p)));
}



/* -------------------------------- quasiquote -------------------------------- */

static s7_pointer g_qq_list(s7_scheme *sc, s7_pointer args)
{
  #define H_qq_list "({list} ...) returns its arguments in a list (internal to quasiquote)"

  s7_pointer x, y, px;

  for (x = args; is_pair(x); x = cdr(x))
    if (car(x) == sc->NO_VALUE) 
      break;
  
  if (is_null(x))
    return(args);

  /* this is not maximally efficient, but it's not important:
   *   we've hit the rare special case where ({apply_values} '())) needs to be ignored
   *   in the splicing process (i.e. the arglist acts as if the thing never happened)
   */
  px = sc->NIL;
  for (x = args, y = args; is_pair(y); y = cdr(y))
    if (car(y) != sc->NO_VALUE)
      {
	car(x) = car(y);
	px = x;
	x = cdr(x);
      }

  if ((is_not_null(y)) &&
      (y != sc->NO_VALUE))
    cdr(x) = cdr(y);
  else 
    {
      sc->no_values--;
      if (is_null(px))
	return(sc->NIL);
      cdr(px) = sc->NIL;
    }

  return(args);
}


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."
  s7_pointer x;

  if (is_null(args))
    {
      sc->no_values++;
      return(sc->NO_VALUE);
    }
  if (is_null(cdr(args)))
    x = car(args);
  else x = apply_list_star(sc, args);

  if (!is_proper_list(sc, x))
    return(s7_error(sc, sc->WRONG_TYPE_ARG, 
		    list_2(sc, 
			   make_protected_string(sc, "apply's last argument should be a proper list: ~S"),
			   args)));
  if (is_null(x))
    {
      sc->no_values++;
      return(sc->NO_VALUE);
    }
  return(g_values(sc, x));
}

/* (apply values ...) replaces (unquote_splicing ...)
 *
 * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a)
 * (define-macro (hi a) ``(+ 1 ,,a) == (list list '+ 1 (list quote a)))
 *
 * (define-macro (hi a) `(+ 1 ,@a) == (list '+ 1 (apply values a))
 * (define-macro (hi a) ``(+ 1 ,,@a) == (list 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)
 *   in s7 this is an error.  
 *
 * also in CL the target of ,@ can apparently be a circular list
 */

static bool is_simple_code(s7_scheme *sc, s7_pointer form)
{
  s7_pointer tmp;
  for (tmp = form; is_pair(tmp); tmp = cdr(tmp))
    if (is_pair(car(tmp)))
      {
	if (!is_simple_code(sc, car(tmp)))
	  return(false);
      }
    else
      {
	if ((car(tmp) == sc->UNQUOTE) ||
	    ((is_null(car(tmp))) && (is_null(cdr(tmp)))))
	  return(false);
      }
  return(is_null(tmp));
}


static s7_pointer g_quasiquote_1(s7_scheme *sc, s7_pointer form)
{
  #define H_quasiquote "(quasiquote arg) is the same as `arg.  If arg is a list, it can contain \
comma (\"unquote\") and comma-atsign (\"unquote-splicing\") to pre-evaluate portions of the list. \
unquoted expressions are evaluated and plugged into the list, unquote-splicing 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_symbol(form))
	{
	  /* things that evaluate to themselves don't need to be quoted. 
	   *    but this means `() -> () whereas below `(1) -> '(1) -- should nil here return '()?
	   *    (this also affects vector constants since they call g_quasiquote at run time in OP_READ_QUASIQUOTE_VECTOR)
	   */
	  return(form);
	}
      return(list_2(sc, sc->QUOTE, form));
    }

  if (car(form) == sc->UNQUOTE)
    {
      if (is_not_null(cddr(form)))
	return(eval_error(sc, "unquote: too many arguments, ~S", 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 (is_simple_code(sc, form))
    return(list_2(sc, sc->QUOTE, form));

  {
    int len, i, loc;
    s7_pointer orig, bq, old_scw;
    bool dotted = false;

    len = s7_list_length(sc, form);
    if (len < 0)
      {
	len = -len;
	dotted = true;
      }

    old_scw = sc->w;
    loc = s7_gc_protect(sc, old_scw);

    sc->w = sc->NIL;
    for (i = 0; i <= len; i++)
      sc->w = cons(sc, sc->NIL, sc->w);

    car(sc->w) = sc->QQ_List;
    
    if (!dotted)
      {
	for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq))
	  {
	    if ((is_pair(cdr(orig))) &&   /* this was is_pair(orig) which seems to be always the case */
		(cadr(orig) == sc->UNQUOTE))
	      {
		/* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) 
		 * `(1 . ,@'((2 3))) -> (1 unquote ({apply_values} '((2 3)))) -> ({append} ({list} 1) ({apply_values} '((2 3)))) -> '(1 2 3)
		 * this used to be `(1 . ,@('(2 3))).  
		 *     This now becomes (1 unquote ({apply_values} ('(2 3)))) -> ({append} ({list} 1) ({apply_values} ('(2 3)))) -> error
		 * `(1 . (,@'(2 3))) works in both cases, and `(1 . (,(+ 1 1)))
		 * so do we actually need this block? `(1 ,@'(2 3)) if undotted
		 */
		car(bq) = g_quasiquote_1(sc, car(orig));
		cdr(bq) = sc->NIL;
		sc->w = list_3(sc, sc->QQ_Append, sc->w, caddr(orig));
		break;
	      }
	    else car(bq) = g_quasiquote_1(sc, car(orig));
	  }
      }
    else
      {
	/* `(1 2 . 3) */
	len--;
	for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq))
	  car(bq) = g_quasiquote_1(sc, car(orig));
	car(bq) = g_quasiquote_1(sc, car(orig));

	sc->w = list_3(sc, sc->QQ_Append, sc->w, g_quasiquote_1(sc, cdr(orig)));
	/* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */
      }

    bq = sc->w;
    sc->w = old_scw;
    s7_gc_unprotect_at(sc, loc);

    if ((car(bq) == sc->QQ_List) &&
	(s7_list_length(sc, bq) == 3) &&
	(is_pair(cadr(bq))) &&
	(caadr(bq) == sc->QUOTE) &&
	(is_pair(caddr(bq))) &&
	(caaddr(bq) == sc->QQ_Apply_Values) &&
	(is_symbol(cadr(caddr(bq)))))
      {
	/* fprintf(stderr, "rtn: %s\n", DISPLAY(bq)); */
	set_unsafely_optimized(bq);
	set_optimize_data(bq, HOP_C_QQ_1);
      }

    return(bq);
  }
}


static s7_pointer g_quasiquote(s7_scheme *sc, s7_pointer args)
{
  /* this is for explicit quasiquote support, not the backquote stuff in macros */
  return(g_quasiquote_1(sc, car(args)));
}



/* ---------------- reader funcs for eval ---------------- */

static void back_up_stack(s7_scheme *sc)
{
  opcode_t top_op;
  top_op = stack_op(sc->stack, s7_stack_top(sc) - 1);
  if (top_op == OP_READ_DOT)
    {
      pop_stack(sc);
      top_op = stack_op(sc->stack, s7_stack_top(sc) - 1);
    }
  if ((top_op == OP_READ_VECTOR) ||
      (top_op == OP_READ_BYTEVECTOR))
    {
      pop_stack(sc);
      top_op = stack_op(sc->stack, s7_stack_top(sc) - 1);
    }
  if (top_op == OP_READ_QUOTE)
    pop_stack(sc);
}


static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
{
  int c;
  /* inchar can return EOF, so it can't be used directly as an index into the digits array */
  c = inchar(pt);
  switch (c)
    {
    case EOF:
      s7_error(sc, sc->READ_ERROR,
	       list_1(sc, make_protected_string(sc, "unexpected '#' at end of input")));
      break;
      
    case '(':
      sc->w = small_int(1);
      return(TOKEN_VECTOR);
      
    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() 
	 *   and we can't shrug it off:
	 *   :#2147483649123D()
	 *   ;#nD(...) dimensions argument 1, -2147483647, is out of range (must be 1 or more)
	 * but
	 *   :#2147483649123D()
	 *   creates a vector with 512 dimensions!
	 * ndims in the vector struct is an unsigned int, so we'll complain if it goes over short max for now
	 */
	s7_Int dims;
	int dig, d, loc = 0;
	sc->strbuf[loc++] = c;
	dims = digits[c];
	
	while (true)
	  {
	    d = inchar(pt);
	    if (d == EOF)
	      s7_error(sc, sc->READ_ERROR,
		       list_1(sc, make_protected_string(sc, "unexpected end of input while reading #n...")));
	    
	    dig = digits[d];
	    if (dig >= 10) break;
	    dims = dig + (dims * 10);
	    if ((dims <= 0) ||
		(dims > S7_SHORT_MAX))
	      s7_error(sc, sc->READ_ERROR,
		       list_2(sc, make_protected_string(sc, "overflow while reading #nD: ~A"), make_integer(sc, dims)));
	    sc->strbuf[loc++] = d;
	  }
	sc->strbuf[loc++] = d;
	if ((d == 'D') || (d == 'd'))
	  {
	    d = inchar(pt);
	    if (d == EOF)
	      s7_error(sc, sc->READ_ERROR,
		       list_1(sc, make_protected_string(sc, "unexpected end of input while reading #nD...")));
	    sc->strbuf[loc++] = d;
	    if (d == '(')
	      {
		sc->w = make_integer(sc, dims);
		return(TOKEN_VECTOR);
	      }
	  }
	
	/* try to back out */
	for (d = loc - 1; d > 0; d--)
	  backchar(sc->strbuf[d], pt);
      }
      break;

    case 'u':
      {
	int d;
	d = inchar(pt);
	if (d == EOF)
	  s7_error(sc, sc->READ_ERROR,
		   list_1(sc, make_protected_string(sc, "unexpected end of input while reading #u...")));
	if (d == '8')
	  {
	    d = inchar(pt);
	    if (d == EOF)
	      s7_error(sc, sc->READ_ERROR,
		       list_1(sc, make_protected_string(sc, "unexpected end of input while reading #u8...")));
	    if (d == '(')
	      return(TOKEN_BYTEVECTOR);
	    backchar(d, pt);
	    backchar('8', pt);
	    backchar('u', pt);
	  }
      }
      break;
      
    case ':':  /* turn #: into : -- this is for compatibility with Guile, #:optional in particular.
		*   I just noticed that Rick is using this -- I'll just leave it alone.
		*/
      sc->strbuf[0] = ':';
      return(TOKEN_ATOM);

      /* block comments in #! ... !# */
      /* this is needed when an input file is treated as a script:
	 #!/home/bil/cl/snd
	 !#
	 (format #t "a test~%")
	 (exit)
      */
    case '!':
      {
	char last_char;
	last_char = ' ';
	while ((c = inchar(pt)) != EOF)
	  {
	    if ((c == '#') &&
		(last_char == '!'))
	      break;
	    last_char = c;
	  }
	if (c == EOF)
	  s7_error(sc, sc->READ_ERROR,
		   list_1(sc, make_protected_string(sc, "unexpected end of input while reading #!")));
	return(token(sc));
      }
      
      /* block comments in #| ... |# 
       *   since we ignore everything until the |#, internal semicolon comments are ignored,
       *   meaning that ;|# is as effective as |#
       */
    case '|':
      {
	char last_char;
	last_char = ' ';
	
	if (is_file_port(pt))
	  {
	    while (true)
	      {
		c = fgetc(port_file(pt));
		if (c == EOF)
		  s7_error(sc, sc->READ_ERROR,
			   list_1(sc, make_protected_string(sc, "unexpected end of input while reading #|")));
		if ((c == '#') &&
		    (last_char == '|'))
		  break;
		last_char = c;
		if (c == '\n')
		  port_line_number(pt)++;
	      }
	    return(token(sc));
	  }
	else 
	  {
	    const char *str, *orig_str, *p, *pend;

	    orig_str = (const char *)(port_string(pt) + port_string_point(pt));
	    pend = (const char *)(port_string(pt) + port_string_length(pt));
	    str = orig_str;

	    while (true)
	      {
		p = strchr(str, (int)'|');
		if ((!p) || (p >= pend))
		  {
		    port_string_point(pt) = port_string_length(pt);
		    s7_error(sc, sc->READ_ERROR,
			     list_1(sc, make_protected_string(sc, "unexpected end of input while reading #|")));
		  }
		if (p[1] == '#')
		  break;
		str = (const char *)(p + 1);
	      }
	    port_string_point(pt) += (p - orig_str + 2);

	    /* now count newline inside the comment */
	    str = (const char *)orig_str;
	    pend = p;
	    while (true)
	      {
		p = strchr(str, (int)'\n');
		if ((p) && (p < pend))
		  {
		    port_line_number(pt)++;
		    str = (char *)(p + 1);
		  }
		else break;
	      }
	    return(token(sc));
	  }
      }
    }
  
  sc->strbuf[0] = c; 
  return(TOKEN_SHARP_CONST); /* next stage notices any errors */
}    


static token_t read_comma(s7_scheme *sc, s7_pointer pt)
{
  int c;
  /* here we probably should check for symbol names that start with "@":
     
     :(defmacro hi (@foo) `(+ ,@foo 1))
     hi
     :(hi 2)
     ;foo: unbound variable
	 
     but

     :(defmacro hi (.foo) `(+ ,.foo 1))
     hi
     :(hi 2)
     3

     and ambiguous:
     :(define-macro (hi @foo . foo) `(list ,@foo))

     what about , @foo -- is the space significant?  We accept ,@ foo.
  */

  if ((c = inchar(pt)) == '@') 
    return(TOKEN_AT_MARK);

  if (c == EOF)
    {
      sc->strbuf[0] = ',';  /* was '@' which doesn't make any sense */
      return(TOKEN_COMMA);  /* was TOKEN_ATOM, which also doesn't seem sensible */
    }
  backchar(c, pt);
  return(TOKEN_COMMA);
}


static token_t read_dot(s7_scheme *sc, s7_pointer pt)
{
  int c;
  c = inchar(pt);
  if (c != EOF)
    {
      backchar(c, pt);

      if ((!char_ok_in_a_name[c]) && (c != 0))
	return(TOKEN_DOT);
    }
  else
    {
      sc->strbuf[0] = '.'; 
      return(TOKEN_DOT);
    }
  sc->strbuf[0] = '.'; 
  return(TOKEN_ATOM);  /* i.e. something that can start with a dot like a number */
}


static token_t token(s7_scheme *sc)
{
  int c;
  s7_pointer pt;

  pt = sc->input_port;
  c = port_read_white_space(pt)(sc, pt);

  switch (c) 
    {
    case '(':
      return(TOKEN_LEFT_PAREN);
      
    case ')':
      return(TOKEN_RIGHT_PAREN);
      
    case '.':
      return(read_dot(sc, pt));

    case '\'':
      return(TOKEN_QUOTE);
      
    case ';':
      return(port_read_semicolon(pt)(sc, pt));

    case '"':
      return(TOKEN_DOUBLE_QUOTE);
      
    case '`':
      return(TOKEN_BACK_QUOTE);
      
    case ',':
      return(read_comma(sc, pt));
      
    case '#':
      return(read_sharp(sc, pt));

    case EOF:
      return(TOKEN_EOF);

    default: 
      sc->strbuf[0] = 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);
    }
}



#define NOT_AN_X_CHAR -1

static int read_x_char(s7_pointer pt)
{
  /* possible "\xnn" char (write creates these things, so we have to read them) 
   *   but we could have crazy input like "\x -- with no trailing double quote
   */
  int d1, d2, c;

  c = inchar(pt);
  if (c == EOF)
    return(NOT_AN_X_CHAR);

  d1 = digits[c];
  if (d1 < 16)
    {
      c = inchar(pt);
      if (c == EOF)
	return(NOT_AN_X_CHAR);
      d2 = digits[c];
      if (d2 < 16)
	return(16 * d1 + d2);           /* following char can be anything, including a number -- we ignore it */
      /* apparently one digit is also ok */
      backchar(c, pt);
      return(d1);
    }
  return(NOT_AN_X_CHAR);
}


static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt)
{
  /* sc->F => error 
   *   no check needed here for bad input port and so on
   */
  unsigned int i = 0;
  int c;

  if (is_string_port(pt))
    {
      /* try the most common case first */
      char *s, *start, *end;
      start = (char *)(port_string(pt) + port_string_point(pt));
      if (*start == '"')
	{
	  port_string_point(pt)++;
	  return(make_empty_string(sc, 0, 0));
	}

      end = (char *)(port_string(pt) + port_string_length(pt));
      s = strpbrk(start, "\"\n\\");
      if ((!s) || (s >= end))
	return(sc->F);
      if (*s == '"')
	{
	  int len;
	  len = s - start;
	  port_string_point(pt) += (len + 1);
	  return(s7_make_terminated_string_with_length(sc, start, len));
	}
      
      for (; s < end; s++)
	{
	  if (*s == '"')                         /* switch here no faster */
	    {
	      int len;
	      len = s - start;
	      port_string_point(pt) += (len + 1);
	      return(s7_make_terminated_string_with_length(sc, start, len));
	    }
	  else
	    {
	      if (*s == '\\')
		{
		  if ((unsigned int)(s - start) >= sc->strbuf_size)
		    resize_strbuf(sc);
		  for (i = 0; i < (unsigned int)(s - start); i++)
		    sc->strbuf[i] = port_string(pt)[port_string_point(pt)++];
		  break;
		}
	      else
		{
		  if (*s == '\n')
		    port_line_number(pt)++; 
		}
	    }
	}
    }

  while (true)
    {
      /* splitting this check out and duplicating the loop was slower?!? */
      c = port_read_character(pt)(sc, pt);

      switch (c)
	{
	case '\n': 
	  port_line_number(pt)++; 
	  sc->strbuf[i++] = c;
	  break;

	case EOF:
	  return(sc->F);

	case '"':
	  return(s7_make_terminated_string_with_length(sc, sc->strbuf, i));

	case '\\':
	  c = inchar(pt);

	  if (c == EOF) 
	    return(sc->F);

	  if (c == '\\')
	    sc->strbuf[i++] = '\\';
	  else
	    {
	      if (c == '"')
		sc->strbuf[i++] = '"';
	      else
		{
		  if (c == 'n')
		    sc->strbuf[i++] = '\n';
		  else 
		    {
		      if (c == 't')                         /* this is for compatibility with other Schemes */
			sc->strbuf[i++] = '\t';
		      else 
			{
			  if (c == 'x')
			    {
			      c = read_x_char(pt);
			      if (c == NOT_AN_X_CHAR)
				return(sc->T);
			      sc->strbuf[i++] = (unsigned char)c;
			    }
			  else
			    {
			      /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */
			      if ((c != '\n') && (c != '\r'))
				return(sc->T); 

			      /* #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++] = c;
	  break;
	}

      if (i >= sc->strbuf_size)
	resize_strbuf(sc);
    }
}


static s7_pointer read_expression(s7_scheme *sc)
{ 
  while (true) 
    {
      int c;
      switch (sc->tok) 
	{
	case TOKEN_EOF:
	  return(sc->EOF_OBJECT);
	  
	case TOKEN_BYTEVECTOR:
	  push_stack_no_code(sc, OP_READ_BYTEVECTOR, sc->NIL);
	  sc->tok = TOKEN_LEFT_PAREN;
	  break;

	case TOKEN_VECTOR:         /* already read #( -- TOKEN_VECTOR is triggered by #( */
	    push_stack_no_code(sc, OP_READ_VECTOR, sc->w);   /* sc->w is the dimensions */
	    /* fall through */
	  
	case TOKEN_LEFT_PAREN:
	  sc->tok = token(sc);

	  if (sc->tok == TOKEN_RIGHT_PAREN)
	    return(sc->NIL);

	  if (sc->tok == TOKEN_DOT) 
	    {
	      back_up_stack(sc);
	      do {c = inchar(sc->input_port);} while ((c != ')') && (c != EOF));
	      return(read_error(sc, "stray dot after '('?"));         /* (car '( . )) */
	    }

	  if (sc->tok == TOKEN_EOF)
	    return(missing_close_paren_error(sc));

	  push_stack_no_code(sc, OP_READ_LIST, sc->NIL);
	  /* here we need to clear args, but code is ignored */

	  CHECK_STACK_SIZE(sc);
	  break;
	  
	case TOKEN_QUOTE:
	  push_stack_no_code(sc, OP_READ_QUOTE, sc->NIL);
	  sc->tok = token(sc);
	  break;
	  
	case TOKEN_BACK_QUOTE:
	  sc->tok = token(sc);
#if WITH_QUASIQUOTE_VECTOR
	  if (sc->tok == TOKEN_VECTOR)
	    {
	      push_stack_no_code(sc, OP_READ_QUASIQUOTE_VECTOR, sc->w);
	      sc->tok = TOKEN_LEFT_PAREN; 
	    } 
	  else 
#endif
	    push_stack_no_code(sc, OP_READ_QUASIQUOTE, sc->NIL);
	  break;
	  
	case TOKEN_COMMA:
	  push_stack_no_code(sc, OP_READ_UNQUOTE, sc->NIL);
	  sc->tok = token(sc);
	  break;
	  
	case TOKEN_AT_MARK:
	  push_stack_no_code(sc, OP_READ_APPLY_VALUES, sc->NIL);
	  sc->tok = token(sc);
	  break;
	  
	case TOKEN_ATOM:
	  return(port_read_name(sc->input_port)(sc, sc->input_port, NO_SHARP));
	  /* If reading list (from lparen), this will finally get us to op_read_list */
	  
	case TOKEN_DOUBLE_QUOTE:
	  sc->value = read_string_constant(sc, sc->input_port);

	  if (sc->value == sc->F)                                   /* can happen if input code ends in the middle of a string */
	    return(read_error(sc, "end of input encountered while in a string"));
	  if (sc->value == sc->T)
	    return(read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"));

	  return(sc->value);
	  
	case TOKEN_SHARP_CONST:
	  sc->value = port_read_name(sc->input_port)(sc, sc->input_port, WITH_SHARP);

	  /* here we need the following character and form 
	   *   strbuf[0] == '#', false above = # case, not an atom
	   */
	  if (is_null(sc->value))
	    {
	      return(read_error(sc, "undefined # expression"));
	      /* a read error here seems draconian -- this unknown constant doesn't otherwise get in our way
	       *   but how to alert the caller to the problem without stopping the read?
	       */
	    }
	  return(sc->value);

	case TOKEN_DOT:                                             /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */
	  back_up_stack(sc);
	  do {c = inchar(sc->input_port);} while ((c != ')') && (c != EOF));
	  return(read_error(sc, "stray dot in list?"));             /* (+ 1 . . ) */

	case TOKEN_RIGHT_PAREN:                                     /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */
	  back_up_stack(sc);
	  return(read_error(sc, "unexpected close paren"));         /* (+ 1 2)) or (+ 1 . ) */
	}
    }

  /* we never get here */
  return(sc->NIL);
}



/* ---------------- *unbound-variable-hook* ---------------- */

static s7_pointer loaded_library(s7_scheme *sc, const char *file)
{
  s7_pointer p;
  for (p = slot_value(sc->libraries); is_pair(p); p = cdr(p))
    if (strcmp(file, string_value(caar(p))) == 0)
      return(cdar(p));
  return(sc->NIL);
}


static s7_pointer unbound_variable(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 (sym == sc->UNQUOTE)
    return(eval_error_no_arg(sc, "unquote (',') occurred outside quasiquote"));

  if (sym == sc->__FUNC__) /* __func__ is a sort of symbol macro */
    {
      s7_pointer env;
      env = find_closure_environment(sc, sc->envir);
      if ((is_environment(env)) &&
	  (is_symbol(environment_function(env))))
	{
	  if (has_line_number(env))
	    return(list_3(sc, environment_function(env), file_names[environment_file(env)], make_integer(sc, environment_line(env))));
	  return(environment_function(env));
	}
      return(sc->UNDEFINED);
    }
  
  if (safe_strcmp(symbol_name(sym), "|#") == 0)
    return(read_error(sc, "unmatched |#"));

  /* check *autoload*, autoload_names, then *unbound-variable-hook* 
   */
  if ((sc->autoload_names) ||
      (is_hash_table(sc->autoload_table)) ||
      (is_not_null(s7_hook_functions(sc, sc->unbound_variable_hook))))
    {
      int cur_code_loc, value_loc, args_loc, code_loc;
      s7_pointer result, cur_code, value, code, args, cur_env;
      int save_x = -1, save_y = -1, save_z = -1;
      
      /* 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 sc->cur_code are
       *   not protected (yet).  We need sc->cur_code 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->envir in case s7_load is called.
       */

      args = sc->args;
      args_loc = s7_gc_protect(sc, args);
      code = sc->code;
      code_loc = s7_gc_protect(sc, code);
      value = sc->value;
      value_loc = s7_gc_protect(sc, value);
      cur_code = sc->cur_code;
      cur_env = sc->envir;
      result = sc->UNDEFINED;

      if (!is_pair(cur_code))
	{
	  /* isolated typo perhaps -- no pair to hold the position info, so make one.
	   *   sc->cur_code is GC-protected, so this should be safe.
	   */
	  cur_code = cons(sc, sym, sc->NIL);     /* the error will say "(sym)" which is not too misleading */
	  pair_line_number(cur_code) = port_line_number(sc->input_port) | (port_file_number(sc->input_port) << 20);
	  set_has_line_number(cur_code);
	}
      cur_code_loc = s7_gc_protect(sc, cur_code);   /* we need to save this because it has the file/line number of the unbound symbol */

      SAVE_X_Y_Z(save_x, save_y, save_z); /* this is needed to protect entire expression context */
      /* -------- */

      /* check sc->autoload_names */
      if (sc->autoload_names)
	{
	  const char *file;
	  file = find_autoload_name(sc, sym);
	  if (file)
	    {
	      s7_pointer e;
	      /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...]
	       */
	      e = loaded_library(sc, file);
	      if (!is_environment(e))
		e = s7_load(sc, file);
	      result = s7_symbol_value(sc, sym); /* calls find_symbol, does not trigger unbound_variable search */
	      if ((result == sc->UNDEFINED) &&
		  (is_environment(e)))
		{
		  result = s7_environment_ref(sc, e, sym);
		  /* I think to be consistent we should add '(sym . result) to the global env
		   */
		  if (result != sc->UNDEFINED)
		    {
		      s7_define(sc, sc->NIL, sym, result);
		    }
		}
	    }
	}

      if (result == sc->UNDEFINED)
	{
	  /* check the *autoload* hash table */
	  if (is_hash_table(sc->autoload_table))
	    {
	      s7_pointer val;
	      /* 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...
	       */
	      val = s7_hash_table_ref(sc, sc->autoload_table, sym);
	      if (is_string(val))
		{
		  /* val should be a filename. *load-path* is searched if necessary. */
		  s7_load(sc, string_value(val));
		}
	      else
		{
		  if (is_closure(val))
		    {
		      /* val should be a function of one argument, the current (calling) environment. */
		      s7_call(sc, val, s7_cons(sc, sc->envir, sc->NIL));
		    }
		}
	      result = s7_symbol_value(sc, sym); /* calls find_symbol, does not trigger unbound_variable search */
	    }
	  
	  /* check *unbound-variable-hook* */
	  if (result == sc->UNDEFINED)
	    result = s7_call(sc, sc->unbound_variable_hook, list_1(sc, sym)); /* not s7_apply_function */
	}

      /* -------- */
      RESTORE_X_Y_Z(save_x, save_y, save_z);

      sc->value = value;
      s7_gc_unprotect_at(sc, value_loc);
      sc->cur_code = cur_code;
      s7_gc_unprotect_at(sc, cur_code_loc);
      sc->args = args;
      s7_gc_unprotect_at(sc, args_loc);
      sc->code = code;
      sc->envir = cur_env;
      s7_gc_unprotect_at(sc, code_loc);

      if ((result != sc->UNDEFINED) &&
	  (result != sc->UNSPECIFIED))
	return(result);
    }
  
  return(eval_error(sc, "~A: unbound variable", sym));
}


static s7_pointer assign_syntax(s7_scheme *sc, const char *name, opcode_t op) 
{
  s7_pointer x, syn;
  unsigned int loc;

  loc = symbol_table_hash(name);
  x = new_symbol(sc, name, loc);
  symbol_hash(x) = loc;

  syn = alloc_pointer();
  set_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS); 
  syntax_opcode(syn) = op;
  cdr(syn) = syn; /* this saves us an error check in the main eval section */
  car(syn) = x;
  global_slot(x) = permanent_slot(x, syn);
  initial_slot(x) = permanent_slot(x, syn);

  typeflag(x) = SYNTACTIC_TYPE;
  symbol_set_local(x, 0LL, sc->NIL);
  syntax_opcode(x) = op;
  return(x);
}


static s7_pointer assign_internal_syntax(s7_scheme *sc, const char *name, opcode_t op) 
{
  s7_pointer x, str, syn; 
  unsigned int loc;

  str = s7_make_permanent_string(name);

  x = alloc_pointer();
  heap_location(x) = NOT_IN_HEAP;
  symbol_name_cell(x) = str;
  set_type(x, T_SYMBOL);

  global_slot(x) = sc->NIL;
  initial_slot(x) = sc->UNDEFINED;
  loc = symbol_table_hash(name); 
  symbol_hash(x) = loc;
  symbol_set_local(x, 0LL, sc->NIL);
  symbol_accessor(x) = -1;

  syn = alloc_pointer();
  set_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS); 
  syntax_opcode(syn) = op;
  cdr(syn) = syn; 
  car(syn) = s7_make_symbol(sc, name);
  global_slot(x) = permanent_slot(x, syn);
  initial_slot(x) = permanent_slot(x, syn);

  typeflag(x) = SYNTACTIC_TYPE;
  symbol_set_local(x, 0LL, sc->NIL);
  syntax_opcode(x) = op;
  return(x);
}


static bool direct_memq(s7_pointer symbol, s7_pointer symbols)
{
  s7_pointer x;
  for (x = symbols; is_pair(x); x = cdr(x))
    {
      if (car(x) == symbol)
	return(true);
      x = cdr(x);
      if (car(x) == symbol)
	return(true);
    }
  return(false);
}


bool s7_tree_memq(s7_scheme *sc, s7_pointer symbol, s7_pointer tree)
{
  if (is_null(tree))
    return(false);
  if (symbol == tree)
    return(true);
  if (is_pair(tree))
    return((s7_tree_memq(sc, symbol, car(tree))) ||
	   (s7_tree_memq(sc, symbol, cdr(tree))));
  return(false);
}

#if 0
static s7_pointer remq(s7_scheme *sc, s7_pointer a, s7_pointer obj) 
{
  s7_pointer p;

  sc->w = sc->NIL;
  for ( ; is_pair(a); a = cdr(a))
    if (car(a) != obj)
      sc->w = cons(sc, car(a), sc->w);
  p = sc->w;
  sc->w = sc->NIL;

  return(s7_reverse(sc, p));
}
#endif



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'"
  s7_pointer p;
  p = car(args);

  if (!is_pair(p))
    {
      CHECK_METHOD(sc, p, sc->PAIR_LINE_NUMBER, args);
      return(simple_wrong_type_argument(sc, sc->PAIR_LINE_NUMBER, p, T_PAIR));	
    }
  if (has_line_number(p))
    return(make_integer(sc, (s7_Int)(remembered_line_number(pair_line_number(p)))));
  return(small_int(0));
}


static s7_pointer quotify(s7_scheme *sc, s7_pointer pars)
{
  /* the default parameter values of define-macro* and define-bacro* should not be evaluated until
   * the expansion is evaluated.  That is, 
   *
   *   (let ((x 0)) (define-macro* (hi (a (let () (set! x (+ x 1)) x))) `(let ((x -1)) (+ x ,a))) (list (hi) x))
   *
   * should return the same value as the equivalent explicit form:
   *
   *   (let ((x 0)) (define-macro (hi a) `(let ((x -1)) (+ x ,a))) (list (hi (let () (set! x (+ x 1)) x)) x))
   *
   * '(-1 0) in both cases.
   *
   * But at the point in eval where we handle lambda* arguments, we can't easily tell whether we're part of
   * a function or a macro, so at definition time of a macro* we scan the parameter list for an expression
   * as a default value, and replace it with (quote expr).
   *
   * and... (define-macro* ((a x)) ...) should behave the same as (define-macro* ((a (+ x 0))) ...)
   */
  s7_pointer tmp;
  for (tmp = pars; is_pair(tmp); tmp = cdr(tmp))
    if ((is_pair(car(tmp))) &&
	(is_pair(cdar(tmp))) &&
	((is_pair(cadar(tmp))) ||
	 (is_symbol(cadar(tmp))) ||
	 (is_syntax(cadar(tmp)))))
      cadar(tmp) = list_2(sc, sc->QUOTE, cadar(tmp));
  return(pars);
}


static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  s7_pointer x;

  for (x = environment_slots(sc->envir) /* presumably the arglist */; is_slot(x); x = next_slot(x))
    if (slot_symbol(x) == sym)
      {
	/* x is our binding (symbol . value) */
	if (is_not_checked(x))
	  set_checked(x); /* this is a special use of this bit, I think */
	else 
	  {
	    return(s7_error(sc, sc->WRONG_TYPE_ARG,
			    list_4(sc,
				   make_protected_string(sc, "~A: parameter set twice, ~S in ~S"),
				   closure_name(sc, sc->code), sc->y, sc->args)));
	  }
	slot_set_value(x, val);
	return(val);
      }
  return(sc->NO_VALUE);
}


static s7_pointer lambda_star_set_args(s7_scheme *sc)
{
  /* sc->code is a closure: ((args body) envir)
   * (define* (hi a (b 1)) (+ a b))
   * (procedure-source hi) -> (lambda* (a (b 1)) (+ a b))
   *
   * so rather than spinning through the args binding names to values in the
   *   procedure's new environment (as in the usual closure case above),
   *   we scan the current args, and match against the
   *   template in the car of the closure, binding as we go.
   *
   * for each actual arg, if it's not a keyword that matches a member of the 
   *   template, bind it to its current (place-wise) arg, else bind it to
   *   that arg.  If it's the symbol :key or :optional, just go on.
   *   If it's :rest bind the next arg to the trailing args at this point.
   *   All args can be accessed by their name as a keyword.
   *   In other words (define* (hi (a 1)) ...) is the same as (define* (hi :key (a 1)) ...) etc.
   *
   * all args are optional, any arg with no default value defaults to #f.
   *   but the rest arg should default to '().
   *
   * I later decided to add two warnings: if a parameter is set twice and if
   *   an unknown keyword is seen in a keyword position and there is no rest arg.
   *
   * :key and :optional are just noise words, so these have already been spliced out of the arg list
   */

  bool allow_other_keys = false;

  /* get the current args, re-setting args that have explicit values */
  sc->x = closure_args(sc->code);
  sc->y = sc->args; 
  sc->z = sc->NIL;
  while ((is_pair(sc->x)) &&
	 (is_pair(sc->y)))
    {
      if (car(sc->x) == sc->KEY_ALLOW_OTHER_KEYS)
	{
	  allow_other_keys = true;
	  sc->x = cdr(sc->x);
	}
      else
	{
	  if (car(sc->x) == sc->KEY_REST)           /* the rest arg */
	    {
	      /* next arg is bound to trailing args from this point as a list */
	      sc->z = sc->KEY_REST;
	      sc->x = cdr(sc->x);
	      
	      if (is_pair(car(sc->x)))
		lambda_star_argument_set_value(sc, caar(sc->x), sc->y);
	      else lambda_star_argument_set_value(sc, car(sc->x), sc->y);
	      
	      sc->y = cdr(sc->y);
	      sc->x = cdr(sc->x);
	      if (car(sc->x) == sc->KEY_ALLOW_OTHER_KEYS)
		break;
	    }
	  else
	    {
	      if ((is_pair(cdr(sc->y))) &&
		  (is_keyword(car(sc->y))))
		{
		  /* char *name; */                      /* found a keyword, check the lambda args via the corresponding symbol */
		  s7_pointer sym;
		  sym = keyword_symbol(car(sc->y));
		  
		  
		  if (lambda_star_argument_set_value(sc, sym, car(cdr(sc->y))) == 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) ||
			  (direct_memq(sc->KEY_ALLOW_OTHER_KEYS, sc->x)))
			{
			  allow_other_keys = true;
			  /* 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
			   */
			  sc->y = cddr(sc->y);
			  continue;
			}
		      else
			{
			  if ((is_pair(car(sc->x))) &&
			      (is_keyword(cadar(sc->x))))
			    {
			      /* sc->x is the closure args list, not the copy of it in the current environment */
			      s7_pointer x;
			      
			      x = find_symbol(sc, caar(sc->x));
			      if (is_slot(x))
				{
				  if (is_not_checked(x))
				    {
				      set_checked(x);
				      slot_set_value(x, car(sc->y));
				    }
				  else 
				    {
				      /* this case is not caught yet: ((lambda* (a :optional b :allow-other-keys ) a) :b 1 :c :a :a ) */
				      
				      return(s7_error(sc, sc->WRONG_TYPE_ARG,
						      list_4(sc,
							     make_protected_string(sc, "~A: parameter set twice, ~S in ~S"),
							     closure_name(sc, sc->code), sc->y, sc->args)));
				    }
				}
			      else
				{
				  return(s7_error(sc, sc->WRONG_TYPE_ARG,
						  list_4(sc,
							 make_protected_string(sc, "~A: unknown key: ~S in ~S"),
							 closure_name(sc, sc->code), sc->y, sc->args)));
				}
			      /* (define* (f a (b :c)) b) (f :b 1 :d) */
			    }
			  else
			    {
			      return(s7_error(sc, sc->WRONG_TYPE_ARG,
					      list_4(sc,
						     make_protected_string(sc, "~A: unknown key: ~S in ~S"),
						     closure_name(sc, sc->code), sc->y, sc->args)));
			    }
			}
		    }
		  sc->y = cdr(sc->y);
		  if (is_pair(sc->y)) sc->y = cdr(sc->y);
		}
	      else                                  /* not a key/value pair */
		{
		  /* this is always a positional (i.e. direct) change, but the closure_args are in the
		   *   definition order whereas currently the environment slots are in reverse order.
		   */
		  if (is_pair(car(sc->x)))
		    lambda_star_argument_set_value(sc, caar(sc->x), car(sc->y));
		  else lambda_star_argument_set_value(sc, car(sc->x), car(sc->y));

		  sc->y = cdr(sc->y);
		}
	      sc->x = cdr(sc->x);
	    }
	}
    }

  /* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) */
  /* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) */

  /* check for trailing args with no :rest arg */
  if (is_not_null(sc->y))
    {
      if ((is_not_null(sc->x)) ||
	  (sc->z == sc->KEY_REST))
	{
	  if (is_symbol(sc->x))
	    add_slot(sc, sc->x, sc->y); 
	}
      else
	{
	  if (!allow_other_keys)                       /* ((lambda* (a) a) :a 1 2) */
	    return(s7_error(sc, sc->WRONG_NUMBER_OF_ARGS, 
			    list_3(sc, sc->TOO_MANY_ARGUMENTS, closure_name(sc, sc->code), sc->args)));
	  else
	    {
	      /* check trailing args for repeated keys or keys with no values or values with no keys */
	      while (is_pair(sc->y))
		{
		  if ((!is_keyword(car(sc->y))) ||     /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */
		      (!is_pair(cdr(sc->y))))          /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */
		    return(s7_error(sc, sc->WRONG_TYPE_ARG,
				    list_3(sc, 
					   make_protected_string(sc, "~A: not a key/value pair: ~S"),
					   closure_name(sc, sc->code), sc->y)));
#if 0
		  s7_pointer x;
		  for (x = sc->args; (is_pair(x)) && (x != sc->y); x = cdr(x))
		    if (car(x) == car(sc->y))          /* ((lambda* (a :allow-other-keys) a) :a 1 :a 2) */
		      return(s7_error(sc, sc->WRONG_TYPE_ARG,
				      list_4(sc,
					     make_protected_string(sc, "~A: parameter set twice, ~S in ~S"),
					     closure_name(sc, sc->code), sc->y, sc->args)));

		  /* this is very tricky! ((lambda* (:allow-other-keys ) #f) :b :a :a :b ) or offset if 1 par etc
		   */

		  /* ((lambda* (:key b :allow-other-keys ) b) 1 :b 2) -> 1
		   *  that is, the argument is set twice, but the second setting is in the trailing args
		   */
#endif
		  sc->y = cddr(sc->y);
		}
	    }
	} 
    }
  return(sc->NIL);
}


static s7_pointer find_symbol_or_bust(s7_scheme *sc, s7_pointer hdl) 
{
  s7_pointer x;

  if (environment_id(sc->envir) == symbol_id(hdl))
    return(slot_value(local_slot(hdl)));

  for (x = sc->envir; symbol_id(hdl) < environment_id(x); x = next_environment(x));

  /* this looks redundant, but every attempt to improve it is much slower! */
  if (environment_id(x) == symbol_id(hdl))
    return(slot_value(local_slot(hdl)));

  for (; is_environment(x); x = next_environment(x))
    {
      s7_pointer y;
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == hdl)
	  return(slot_value(y));
    }

  x = global_slot(hdl);
  if (is_slot(x)) 
    return(slot_value(x));

  return(unbound_variable(sc, hdl));
}



#define is_h_safe_c_s(P) ((is_optimized(P)) && (optimize_data(P) == HOP_SAFE_C_S))
#define is_safe_c_s(P)   ((is_optimized(P)) && (op_no_hop(P) == OP_SAFE_C_S))

static bool is_h_optimized(s7_pointer p)
{
  return((is_optimized(p)) &&
	 ((optimize_data(p) & 1) != 0) &&
	 (!is_unknown_op(optimize_data(p))));
}


static s7_pointer find_safe_do_symbol_or_bust(s7_scheme *sc, s7_pointer sym) 
{
  /* this is never called but seems to speed up the compiled code by 10%!! */
  s7_pointer val;
  val = NULL;
  if (!val)
    {
      val = find_symbol(sc, sym);
      if (!is_slot(val)) 
	return(unbound_variable(sc, sym));
    }
  return(slot_value(val));
}


static s7_pointer is_pair_car, is_pair_cdr, is_pair_cadr;
static s7_pointer g_is_pair_car(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadar(args));
  if (!is_pair(val))                                               /* (define (tst) (let ((a 123)) (pair? (car a)))) */
    return(g_is_pair(sc, list_1(sc, g_car(sc, list_1(sc, val))))); /* handle possible methods the indirect way */
  return(make_boolean(sc, is_pair(car(val))));
}

static s7_pointer g_is_pair_cdr(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_pair(sc, list_1(sc, g_cdr(sc, list_1(sc, val))))); 
  return(make_boolean(sc, is_pair(cdr(val))));
}

static s7_pointer g_is_pair_cadr(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_pair(sc, list_1(sc, g_cadr(sc, list_1(sc, val))))); 
  return(make_boolean(sc, is_pair(cadr(val))));
}

static s7_pointer is_pair_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (is_optimized(cadr(expr)))
    {
      if (optimize_data(cadr(expr)) == HOP_SAFE_C_S)
	{
	  s7_function g;
	  g = c_call(cadr(expr));
	  if (g == g_car)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_pair_car);
	    }
	  if (g == g_cdr)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_pair_cdr);
	    }
	  if (g == g_cadr)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_pair_cadr);
	    }
	}
    }
  return(f);
}

static s7_pointer is_null_cdr;
static s7_pointer g_is_null_cdr(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_null(sc, list_1(sc, g_cdr(sc, list_1(sc, val))))); 
  return(make_boolean(sc, is_null(cdr(val))));
}

static s7_pointer is_null_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((is_optimized(cadr(expr))) &&
      (optimize_data(cadr(expr)) == HOP_SAFE_C_S))
    {
      s7_function g;
      g = c_call(cadr(expr));
      if (g == g_cdr)
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(is_null_cdr);
	}
    }
  return(f);
}

static s7_pointer cdr_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(f);
}

static s7_pointer car_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(f);
}


static s7_pointer format_allg, format_allg_no_column, format_just_newline;
static s7_pointer g_format_allg(s7_scheme *sc, s7_pointer args)
{
  return(g_format_1(sc, args, ((main_stack_op(sc) != OP_BEGIN1) || (!is_optimized(sc->cur_code)) || (op_no_hop(sc->cur_code) != OP_SAFE_C_SC))));
}

static s7_pointer g_format_just_newline(s7_scheme *sc, s7_pointer args)
{
  s7_pointer pt, str;
  bool need_output;
  int tpoint;
  char *new_str;

  pt = car(args);
 
  if (pt == sc->T)
    pt = sc->output_port;
  else
    {
      if ((pt != sc->F) &&              
	  ((!is_output_port(pt)) ||    
	   (port_is_closed(pt))))
	{
	  CHECK_METHOD(sc, pt, sc->FORMAT, args);
	  return(wrong_type_argument_with_type(sc, sc->FORMAT, small_int(1), pt, A_FORMAT_PORT));
	}
    }

  str = cadr(args);
  new_str = (char *)string_value(str);
  tpoint = string_length(str) - 2;

  need_output = ((main_stack_op(sc) != OP_BEGIN1) || (!is_optimized(sc->cur_code)) || (op_no_hop(sc->cur_code) != OP_SAFE_C_SC));

  if (pt == sc->F)
    {
      if (!need_output)
	return(sc->F);
    }
  else
    {
      if (tpoint > 0)
	{
	  new_str[tpoint] = '\0';
	  port_write_string(pt)(sc, new_str, tpoint, pt);
	  new_str[tpoint] = '~';
	}
      port_write_character(pt)(sc, '\n', pt);
    }

  if (need_output)
    {
      if (tpoint == 0)
	return(s7_make_string_with_length(sc, "\n", 1));

      new_str[tpoint] = '\n';
      new_str[tpoint + 1] = '\0';
      str = s7_make_string_with_length(sc, new_str, tpoint + 1);
      new_str[tpoint] = '~';
      new_str[tpoint + 1] = '%';
      return(str);
    }
  return(sc->F);
}


static s7_pointer g_format_allg_no_column(s7_scheme *sc, s7_pointer args)
{
  s7_pointer pt;
  pt = car(args);
 
  if (!((s7_is_boolean(pt)) ||               /* #f or #t */
	((is_output_port(pt)) &&             /* (current-output-port) or call-with-open-file arg, etc */
	 (!port_is_closed(pt)))))
    {
      CHECK_METHOD(sc, pt, sc->FORMAT, args);
      return(wrong_type_argument_with_type(sc, sc->FORMAT, small_int(1), pt, A_FORMAT_PORT));
    }

  return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt, 
			  string_value(cadr(args)), cddr(args), NULL,
			  ((main_stack_op(sc) != OP_BEGIN1) || (!is_optimized(sc->cur_code)) || (op_no_hop(sc->cur_code) != OP_SAFE_C_SC)),
			  false,
			  string_length(cadr(args))));
}


static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args > 1) &&
      (!is_string(cadr(expr))) &&
      (is_string(caddr(expr))))
    {
      s7_pointer str_arg;
      str_arg = caddr(expr);
      if (args == 2) 
	{
	  int len;
	  const char *p, *orig;

	  orig = (const char *)string_value(str_arg);
	  len = string_length(str_arg);
	  if ((len > 1) &&
	      (orig[len - 1] == '%'))
	    {
	      p = strchr(orig, (int)'~');
	      if ((p) && ((p - orig) == len - 2))
		return(format_just_newline);
	    }
	}
	  
      if ((args == 2) ||
	  ((is_optimized(expr)) &&
	   ((op_no_hop(expr) == OP_C_ALL_X) ||
	    (op_no_hop(expr) == OP_SAFE_C_ALL_X))))
	{
	  if (!is_columnizing(string_value(str_arg)))
	    return(format_allg_no_column);
	  return(format_allg);
	}
    }
  return(f);
}

static s7_pointer is_eq_car, is_eq_car_q, is_eq_caar_q;
static s7_pointer g_is_eq_car(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer lst, val;
  lst = finder(sc, cadar(args));
  val = finder(sc, cadr(args));
  if (!is_pair(lst))
    return(g_is_eq(sc, list_2(sc, g_car(sc, list_1(sc, lst)), val)));
  return(make_boolean(sc, car(lst) == val));
}

static s7_pointer g_is_eq_car_q(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer lst;
  lst = finder(sc, cadar(args));
  if (!is_pair(lst))
    return(g_is_eq(sc, list_2(sc, g_car(sc, list_1(sc, lst)), cadr(cadr(args)))));
  return(make_boolean(sc, car(lst) == cadr(cadr(args))));
}

static s7_pointer g_is_eq_caar_q(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer lst;
  lst = finder(sc, cadar(args));
  if (!is_pair(lst))
    return(g_is_eq(sc, list_2(sc, g_caar(sc, list_1(sc, lst)), cadr(cadr(args)))));
  return(make_boolean(sc, caar(lst) == cadr(cadr(args))));
}

static s7_pointer is_eq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((is_pair(cadr(expr))) &&
      (is_optimized(cadr(expr))) &&
      (optimize_data(cadr(expr)) == HOP_SAFE_C_S))
    {
      if ((is_symbol(caddr(expr))) &&
	  (c_call(cadr(expr)) == g_car))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(is_eq_car);
	}
      if ((is_pair(caddr(expr))) &&
	  (caaddr(expr) == sc->QUOTE))
	{
	  if (c_call(cadr(expr)) == g_car)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_eq_car_q);
	    }
	  if (c_call(cadr(expr)) == g_caar)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_eq_caar_q);
	    }
	}
    }
  return(f);
}


/* also not-chooser for all the ? procs, ss case for not equal? etc
 */
static s7_pointer not_is_pair, not_is_symbol, not_is_null, not_is_list, not_is_number, not_is_real, not_is_rational, not_is_integer;
static s7_pointer not_is_boolean, not_is_char, not_is_string, not_is_eof;
static s7_pointer not_is_eq_sq, not_is_eq_ss;

static s7_pointer g_not_is_pair(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !is_pair(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_null(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !is_null(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_symbol(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !is_symbol(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_number(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_number(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_real(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_real(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_integer(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_integer(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_rational(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_rational(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_list(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !is_proper_list(sc, finder(sc, cadar(args)))));}
static s7_pointer g_not_is_boolean(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_boolean(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_char(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !s7_is_character(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_string(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, !is_string(finder(sc, cadar(args)))));}
static s7_pointer g_not_is_eof(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, finder(sc, cadar(args)) != sc->EOF_OBJECT));}

static s7_pointer g_not_is_eq_sq(s7_scheme *sc, s7_pointer args) 
{
  return(make_boolean(sc, finder(sc, cadr(car(args))) != cadr(caddr(car(args)))));
}

static s7_pointer g_not_is_eq_ss(s7_scheme *sc, s7_pointer args) 
{
  return(make_boolean(sc, finder(sc, cadr(car(args))) != finder(sc, caddr(car(args)))));
}

static s7_pointer not_is_pair_car;
static s7_pointer g_not_is_pair_car(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadr(cadar(args)));
  if (!is_pair(val))
    return(g_not(sc, list_1(sc, g_is_pair(sc, list_1(sc, g_car(sc, list_1(sc, val)))))));
  return(make_boolean(sc, !is_pair(car(val))));
}

static s7_pointer not_is_null_cdr;
static s7_pointer g_not_is_null_cdr(s7_scheme *sc, s7_pointer args) 
{
  s7_pointer val;
  val = finder(sc, cadr(cadar(args)));
  if (!is_pair(val))
    return(g_not(sc, list_1(sc, g_is_pair(sc, list_1(sc, g_cdr(sc, list_1(sc, val)))))));
  return(make_boolean(sc, !is_null(cdr(val))));
}

static s7_pointer not_c_c;
static s7_pointer g_not_c_c(s7_scheme *sc, s7_pointer args) 
{
  /* args: ( (null? l) ) */
  return(make_boolean(sc, is_false(sc, c_call(car(args))(sc, cdar(args)))));
}

static s7_pointer not_chooser(s7_scheme *sc, s7_pointer g, int args, s7_pointer expr)
{
  if (is_optimized(cadr(expr))) /* cadr(expr) might be a symbol, for example; is_optimized includes is_pair */
    {
      if (optimize_data(cadr(expr)) == HOP_SAFE_C_S)
	{
	  s7_function f;
	  f = c_call(cadr(expr));
	  
	  if (f == g_is_pair)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_pair);
	    }
	  if (f == g_is_null)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_null);
	    }
	  if (f == g_is_symbol)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_symbol);
	    }
	  if (f == g_is_list)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_list);
	    }

	  /* g_is_number is c_function_call(slot_value(global_slot(sc->NUMBERP)))
	   *   so if this is changed (via open_environment??) the latter is perhaps better??
	   * but user might have (#_number? e), so we can't change later and catch this.
	   */

	  if ((f == g_is_number) || (f == g_is_complex))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_number);
	    }
	  if (f == g_is_rational)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_rational);
	    }
	  if (f == g_is_real)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_real);
	    }
	  if (f == g_is_integer)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_integer);
	    }
	  if (f == g_is_char)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_char);
	    }
	  if (f == g_is_boolean)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_boolean);
	    }
	  if (f == g_is_string)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_string);
	    }
	  if (f == g_is_eof_object)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_eof);
	    }
	}

      if ((optimize_data(cadr(expr)) == HOP_SAFE_C_SQ) &&
	  (c_call(cadr(expr)) == g_is_eq))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(not_is_eq_sq);
	}

      if (optimize_data(cadr(expr)) == HOP_SAFE_C_SS)
	{
	  if (c_call(cadr(expr)) == g_is_eq)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(not_is_eq_ss);
	    }
	}

      if (optimize_data(cadr(expr)) == HOP_SAFE_C_C)
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  if (c_call(cadr(expr)) == g_is_pair_car)
	    return(not_is_pair_car);
	  if (c_call(cadr(expr)) == g_is_null_cdr)
	    return(not_is_null_cdr);
	  return(not_c_c);
	}
    }
  return(g);
}


static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (is_symbol(cadr(expr)))
	{
	  if ((s7_is_integer(caddr(expr))) &&
	      (s7_integer(caddr(expr)) >= 0))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(vector_ref_ic);
	    }

	  if (is_global(cadr(expr)))
	    {
	      if (is_symbol(caddr(expr)))
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(vector_ref_gs);

		  /* (define global_vector (vector 1 2 3))
		   * (define (hi i) (vector-ref global_vector i))
		   */
		}
	      if ((is_pair(caddr(expr))) &&
		  (is_safely_optimized(caddr(expr))) &&
		  (c_call(caddr(expr)) == g_vector_ref_gs))
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(vector_ref_ggs);
		}
	    }

	  if ((is_pair(caddr(expr))) &&
	      (is_safely_optimized(caddr(expr))) &&
	      (c_call(caddr(expr)) == g_add_cs1))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(vector_ref_add1);
	      /* vector_ref_sub1 was not worth the code, and few other easily optimized expressions happen here */
	    }
	}
      return(vector_ref_2);
    }
  return(f);
}


static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 3)
    {
      s7_pointer arg1, arg2, arg3;

      arg1 = cadr(expr);
      arg2 = caddr(expr);
      arg3 = cadddr(expr);
      
      if (is_symbol(arg1))
	{
	  if ((s7_is_integer(arg2)) &&
	      (s7_integer(arg2) >= 0) &&
	      (is_symbol(arg3)))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(vector_set_ic);
	    }
	  if (is_symbol(arg2))
	    {
	      if ((!is_pair(arg3)) &&
		  (!is_symbol(arg3)))
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(vector_set_ssc);
		}
	      if ((is_pair(arg3)) &&
		  (is_safely_optimized(arg3)) &&
		  (c_call(arg3) == g_vector_ref_2) &&
		  (arg1 == cadr(arg3)) &&
		  (is_symbol(caddr(arg3))))
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(vector_set_vref);
		}
	    }
	}
      return(vector_set_3);
    }
  return(f);
}



static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 3) &&
      (s7_is_integer(caddr(expr))) &&
      (s7_integer(caddr(expr)) >= 0) &&
      (s7_integer(caddr(expr)) < MAX_LIST_LENGTH))
    return(list_set_ic);
  return(f);
}


static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (s7_is_integer(caddr(expr))) &&
      (s7_integer(caddr(expr)) >= 0) &&
      (s7_integer(caddr(expr)) < MAX_LIST_LENGTH))
    return(list_ref_ic);
  return(f);
}


static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if ((is_symbol(cadr(expr))) &&
	  (is_symbol(caddr(expr))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(hash_table_ref_ss);
	}
      if ((is_symbol(cadr(expr))) &&
	  (is_pair(caddr(expr))) &&
	  (is_optimized(caddr(expr))) &&
	  (optimize_data(caddr(expr)) == HOP_SAFE_C_S) &&
	  (c_call(caddr(expr)) == g_car))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(hash_table_ref_car);
	}
      return(hash_table_ref_2);
    }
  return(f);
}


#if (!WITH_GMP)
static s7_pointer modulo_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (is_symbol(cadr(expr))) &&
      (is_integer(caddr(expr))) &&
      (integer(caddr(expr)) > 1))
    {
      set_optimize_data(expr, HOP_SAFE_C_C);
      return(mod_si);
    }
  return(f);
}

static s7_pointer abs_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  s7_pointer arg;
  /* (abs (- v1 v2))
   * (abs (- (car vals) 0.5))
   * (abs (- nval (vector-ref vals i)))
   */

  arg = cadr(expr);
  if ((is_pair(arg)) &&
      (is_optimized(arg)))
    {
      if ((optimize_data(arg) == HOP_SAFE_C_C) &&
	  (s7_function_returns_temp(sc, arg)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(abs_direct);
	}
    }
  return(f);
}

#if 0
static s7_pointer magnitude_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  s7_pointer arg;
  /* (magnitude (- new 0.0))              h_safe_c_sc
   * (magnitude (- val 3.0))
   * (magnitude (- rval sval))            h_safe_c_ss
   * (magnitude (- (mus-scaler gen) 0.1)) h_safe_c_opsq_c
   * (magnitude (- (v0 1) 0.1)            h_safe_c_pc  
   * (magnitude (- (maxamp) 0.107))       h_safe_c_opcq_c
   */
  return(f);
}
#endif
#endif


static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s))
   */
  if (args == 1)
    return(add_1);

#if (!WITH_GMP)
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      if (arg1 == small_int(1))
	return(add_1s);

      arg2 = caddr(expr);
      if (arg2 == small_int(1))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_cs1);
	    }
	  return(add_s1);
	}

      if (s7_is_integer(arg2))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_si);
	    }
	  if ((is_pair(arg1)) &&
	      (is_safely_optimized(arg1)) &&
	      (c_call(arg1) == g_multiply_si))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_si_i);
	    }
	}

      if ((s7_is_integer(arg1)) &&
	  (is_symbol(arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(add_is);
	}

      if ((type(arg2) == T_REAL) &&
	  (is_symbol(arg1)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(add_sf);
	}

      if (type(arg1) == T_REAL)
	{
	  if (is_symbol(arg2))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_fs);
	    }
	  if ((is_pair(arg2)) &&
	      (is_optimized(arg2)) &&
	      (fcdr(arg2) == (s7_pointer)g_multiply_sf))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_f_sf);
	    }
	  if ((is_pair(arg2)) &&
	      (is_optimized(arg2)) &&
	      (fcdr(arg2) == (s7_pointer)g_sqr_ss))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(add_f_sqr);
	    }
	}

      if ((is_symbol(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (optimize_data(arg2) == HOP_SAFE_C_C) &&
	  (s7_function_returns_temp(sc, arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(add_s_direct);
	}

      if ((is_pair(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg1)) &&
	  (is_optimized(arg2)))
	{
	  if ((optimize_data(arg1) == HOP_SAFE_C_SS) &&
	      (optimize_data(arg2) == HOP_SAFE_C_C) &&
	      (fcdr(arg1) == (s7_pointer)g_multiply_2) &&
	      (fcdr(arg2) == (s7_pointer)g_mul_1ss) &&
	      (cadr(arg1) == caddr(cadr(arg2))))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      set_ecdr(cdr(expr), caddr(arg1));
	      set_fcdr(cdr(expr), caddr(arg2));
	      return(add_ss_1ss);
	    }

	  if ((s7_function_returns_temp(sc, arg1)) &&
	      (s7_function_returns_temp(sc, arg2)))
	    return(add_2_temp);
	}

      if ((is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (s7_function_returns_temp(sc, arg2)))
	return(add_s_temp);

      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (s7_function_returns_temp(sc, arg1)))
	return(add_temp_s);

      return(add_2);
    }

  if (args == 3)
    {
      s7_pointer arg1, arg2, arg3;
      arg1 = cadr(expr);
      arg2 = caddr(expr);
      arg3 = cadddr(expr);

      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (is_pair(arg3)) &&
	  (is_optimized(arg3)) &&
	  (s7_function_returns_temp(sc, arg1)) &&
	  (s7_function_returns_temp(sc, arg2)) &&
	  (s7_function_returns_temp(sc, arg3)))
	return(add_3_temp);
    }

  /* fprintf(stderr, "%d: %s\n", args, DISPLAY_80(expr)); */
#endif
  return(f);
}


static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  /* it's possible to precompute constant multiplies, use OP_CONSTANT as the optimize_data, 
   *    put the value in fcdr, remove it from the heap, return NULL (checking for ecdr null in 
   *    set_c_function and c_function_is_ok), then simply return fcdr in OP_CONSTANT, but
   *    that sort of thing almost never happens in real code.
   */
#if (!WITH_GMP)
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);

      if ((is_symbol(arg1)) &&
	  (s7_is_integer(arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_si);
	}

      if ((is_symbol(arg2)) &&
	  (s7_is_integer(arg1)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_is);
	}

      if ((type(arg1) == T_REAL) &&
	  (is_symbol(arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_fs);
	}
      if ((type(arg2) == T_REAL) &&
	  (is_symbol(arg1)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_sf);
	}
      if ((is_symbol(arg1)) &&
	  (arg1 == arg2))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(sqr_ss);
	}

      /* (* direct ...) here saved a little, but I think not worth the extra code */
      
      if ((is_pair(arg1)) &&
	  (is_symbol(arg2)) &&
	  (car(arg1) == sc->MINUS) &&
	  (type(cadr(arg1)) == T_REAL) &&
	  (real(cadr(arg1)) == 1.0) &&
	  (is_symbol(caddr(arg1))) &&
	  (is_null(cdddr(arg1))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(mul_1ss);
	}

      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (s7_function_returns_temp(sc, arg1)) &&
	  (s7_function_returns_temp(sc, arg2)))
	return(multiply_2_temp);

      if ((is_symbol(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (optimize_data(arg2) == HOP_SAFE_C_C) &&
	  (s7_function_returns_temp(sc, arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_s_direct);
	}

      if ((is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (s7_function_returns_temp(sc, arg2)))
	return(multiply_s_temp);

      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (s7_function_returns_temp(sc, arg1)))
	return(multiply_temp_s);

      /* (* c c) -- types are manifest (as is the result...)
       * (* s (sin|cos s))
       * (* 1.0 x) -> float(x)
       * (* pi x) special too
       * (* 2 (frames)) -- we know both are ints
       */
      /* fprintf(stderr, "m%d: %s\n", args, DISPLAY_80(expr)); */
      return(multiply_2);
    }

  if (args == 3)
    {
      s7_pointer arg1, arg2, arg3;
      arg1 = cadr(expr);
      arg2 = caddr(expr);
      arg3 = cadddr(expr);

      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (is_pair(arg2)) &&
	  (is_optimized(arg2)) &&
	  (is_pair(arg3)) &&
	  (is_optimized(arg3)) &&
	  (s7_function_returns_temp(sc, arg1)) &&
	  (s7_function_returns_temp(sc, arg2)) &&
	  (s7_function_returns_temp(sc, arg3)))
	return(multiply_3_temp);

      if ((type(arg1) == T_REAL) &&
	  (is_symbol(arg2)) &&
	  (is_pair(arg3)) &&
	  (car(arg3) == sc->COS) &&
	  (is_symbol(cadr(arg3))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(multiply_cs_cos);
	}
    }

  if (args > 2)
    {
      s7_pointer arg1;
      arg1 = cadr(expr);
      if ((is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
      	  (s7_function_returns_temp(sc, arg1)))
	return(multiply_1_any);
    }

  /* fprintf(stderr, "m%d: %s\n", args, DISPLAY_80(expr)); */
#endif
  return(f);
}

/* (define (hi a) (- a 1.0)) (hi (string->number "#e1."))
 */

static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
#if (!WITH_GMP)
  if (args == 1)
    return(subtract_1);

  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);

      if (arg2 == small_int(1))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(subtract_cs1);
	    }
	  return(subtract_s1);
	}

      if (type(arg2) == T_REAL)
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(subtract_sf);
	    }
	  if ((is_pair(arg1)) &&
	      (is_safely_optimized(arg1)) &&
	      (c_call(arg1) == g_multiply_sf))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(subtract_sf_f);
	    }
	}

      if ((type(arg1) == T_REAL) &&
	  (is_symbol(arg2)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(subtract_fs);
	}

      if ((s7_is_integer(arg2)) &&
	  (is_symbol(arg1)))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(subtract_csn);
	}
      if ((type(arg2) == T_REAL) &&
	  (is_pair(arg1)) &&
	  (is_optimized(arg1)) &&
	  (optimize_data(arg1) == HOP_SAFE_C_C) &&
	  (car(arg1) == sc->RANDOM) &&
	  (type(cadr(arg1)) == T_REAL))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(subtract_ran);
	}

      /* fprintf(stderr, "%d: %s\n", args, DISPLAY_80(expr)); */
      return(subtract_2);
    }
#endif
  /* fprintf(stderr, "%d: %s\n", args, DISPLAY_80(expr)); */
  return(f);
}


#if (!WITH_GMP)
static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      s7_pointer arg1;
      arg1 = cadr(expr);

      if (arg1 == small_int(1))
	return(divide_1);

      if ((type(arg1) == T_REAL) &&
	  (real(arg1) == 1.0))
	return(divide_1r);
    }

  /* fprintf(stderr, "%d: %s\n", args, DISPLAY_80(expr)); */
  /* si sf ii ff fs -- c as div case? */
  /*
   */
  return(f);
}
#endif


static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (type(cadr(expr)) == T_REAL) &&
      (!is_NaN(real(cadr(expr)))))
    return(max_f2);
  return(f);
}


static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (type(cadr(expr)) == T_REAL) &&
      (!is_NaN(real(cadr(expr)))))
    return(min_f2);
  return(f);
}


static s7_pointer is_zero_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
#if (!WITH_GMP)
  if ((args == 1) &&
      (is_safely_optimized(cadr(expr))) &&
      (c_call(cadr(expr)) == g_mod_si))
    {
      set_optimize_data(expr, HOP_SAFE_C_C);
      return(mod_si_is_zero);
    }
#endif
  return(f);
}


static s7_pointer equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
#if (!WITH_GMP)
  if (args == 2)
    {
      if (s7_is_integer(caddr(expr)))
	{
	  if (is_safely_optimized(cadr(expr)))
	    {
	      s7_function f;
	      f = c_call(cadr(expr));
	      if (f == g_length)
		{
		  if (optimize_data(cadr(expr)) == HOP_SAFE_C_S)
		    {
		      set_optimize_data(expr, HOP_SAFE_C_C);
		      return(equal_length_ic);
		    }
		}
	      if ((f == g_mod_si) &&
		  (integer(caddr(expr)) == 0))
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(mod_si_is_zero);
		}
	    }
	  if (is_symbol(cadr(expr)))
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(equal_s_ic);
	    }
	}
      /* fprintf(stderr, "=2: %s\n", DISPLAY_80(expr)); */
      return(equal_2);
    }
#endif
  return(f);
}


#if (!WITH_GMP)
static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_integer(caddr(expr)))
	{
	  if ((is_optimized(cadr(expr))) &&
	      (optimize_data(cadr(expr)) == HOP_SAFE_C_S))
	    {
	      s7_function f;
	      f = c_call(cadr(expr));
	      if (f == g_length)
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(less_length_ic);
		}
	    }
	  if (integer(caddr(expr)) == 0)
	    return(less_s0);
	  return(less_s_ic);
	}
      return(less_2);
    }
  return(f);
}


static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_integer(caddr(expr)))
	return(leq_s_ic);
      return(leq_2);
    }
  return(f);
}


static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_integer(caddr(expr)))
	return(greater_s_ic);
      if (type(caddr(expr)) == T_REAL)
	return(greater_s_fc);
      return(greater_2);
    }
  return(f);
}


static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_integer(caddr(expr)))
	{
	  if ((is_optimized(cadr(expr))) &&
	      (optimize_data(cadr(expr)) == HOP_SAFE_C_S))
	    {
	      s7_function f;
	      f = c_call(cadr(expr));
	      if (f == g_length)
		{
		  set_optimize_data(expr, HOP_SAFE_C_C);
		  return(geq_length_ic);
		}
	    }
	  return(geq_s_ic);
	}
      /* fprintf(stderr, ">=2: %s\n", DISPLAY_80(expr)); */
      return(geq_2);
    }
  return(f);
}


static s7_pointer is_negative_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 1)
    {
      if ((is_optimized(cadr(expr))) &&
	  (optimize_data(cadr(expr)) == HOP_SAFE_C_S))
	{
	  s7_function f;
	  f = c_call(cadr(expr));
	  if (f == g_length)
	    {
	      set_optimize_data(expr, HOP_SAFE_C_C);
	      return(is_negative_length);
	    }
	}
    }
  return(f);
}
#endif
/* end (!WITH_GMP) */



static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if ((is_symbol(cadr(expr))) &&
	  (s7_is_character(caddr(expr))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  return(char_equal_s_ic);
	}
      return(char_equal_2);
    }
  return(f);
}

static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_less_s_ic);
      return(char_less_2);
    }
  return(f);
}

static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_greater_s_ic);
      return(char_greater_2);
    }
  return(f);
}

static s7_pointer char_geq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_geq_s_ic);
      return(char_geq_2);
    }
  return(f);
}

static s7_pointer char_leq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_leq_s_ic);
      return(char_leq_2);
    }
  return(f);
}


static s7_pointer char_ci_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_ci_equal_s_ic);
      return(char_ci_equal_2);
    }
  return(f);
}

static s7_pointer char_ci_less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_ci_less_s_ic);
      return(char_ci_less_2);
    }
  return(f);
}

static s7_pointer char_ci_greater_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_ci_greater_s_ic);
      return(char_ci_greater_2);
    }
  return(f);
}

static s7_pointer char_ci_geq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_ci_geq_s_ic);
      return(char_ci_geq_2);
    }
  return(f);
}

static s7_pointer char_ci_leq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      if (s7_is_character(caddr(expr)))
	return(char_ci_leq_s_ic);
      return(char_ci_leq_2);
    }
  return(f);
}


static void check_for_substring_temp(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 1) &&
      (is_pair(cadr(expr))) &&
      (is_symbol(caadr(expr))) &&
      (is_safely_optimized(cadr(expr))) &&
      (c_call(cadr(expr)) == g_substring))
    set_c_function(cadr(expr), substring_to_temp);
  else
    {
      if (args == 2)
	{
	  if ((!is_pair(cadr(expr))) &&
	      (is_pair(caddr(expr))) &&
	      (is_symbol(caaddr(expr))) &&
	      (is_safely_optimized(caddr(expr))) &&
	      (c_call(caddr(expr)) == g_substring))
	    set_c_function(caddr(expr), substring_to_temp);
	  if ((!is_pair(caddr(expr))) &&
	      (is_pair(cadr(expr))) &&
	      (is_symbol(caadr(expr))) &&
	      (is_safely_optimized(cadr(expr))) &&
	      (c_call(cadr(expr)) == g_substring))
	    set_c_function(cadr(expr), substring_to_temp);
	}
    }
}


static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_equal_s_ic); 
      return(string_equal_2);
    }
  return(f);
}

static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_less_s_ic);
      
      if ((is_pair(cadr(expr))) &&
	  (is_safely_optimized(cadr(expr))) &&
	  (c_call(cadr(expr)) == g_symbol_to_string))
	set_c_function(cadr(expr), symbol_to_string_uncopied);

      if ((is_pair(caddr(expr))) &&
	  (is_safely_optimized(caddr(expr))) &&
	  (c_call(caddr(expr)) == g_symbol_to_string))
	set_c_function(caddr(expr), symbol_to_string_uncopied);

      return(string_less_2);
    }
  return(f);
}

static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_greater_s_ic);
      return(string_greater_2);
    }
  return(f);
}

static s7_pointer string_geq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_geq_s_ic);
      return(string_geq_2);
    }
  return(f);
}

static s7_pointer string_leq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_leq_s_ic);
      return(string_leq_2);
    }
  return(f);
}


static s7_pointer string_ci_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_ci_equal_s_ic);
      return(string_ci_equal_2);
    }
  return(f);
}

static s7_pointer string_ci_less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_ci_less_s_ic);
      return(string_ci_less_2);
    }
  return(f);
}

static s7_pointer string_ci_greater_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_ci_greater_s_ic);
      return(string_ci_greater_2);
    }
  return(f);
}

static s7_pointer string_ci_geq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_ci_geq_s_ic);
      return(string_ci_geq_2);
    }
  return(f);
}

static s7_pointer string_ci_leq_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if (args == 2)
    {
      if (is_string(caddr(expr)))
	return(string_ci_leq_s_ic);
      return(string_ci_leq_2);
    }
  return(f);
}


static s7_pointer string_ref_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if ((is_pair(cadr(expr))) &&
      (is_safely_optimized(cadr(expr))) &&
      (c_call(cadr(expr)) == g_symbol_to_string))
    set_c_function(cadr(expr), symbol_to_string_uncopied);
  return(f);
}

static s7_pointer string_set_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 3)
    {
      if ((is_symbol(cadr(expr))) &&
	  (is_symbol(caddr(expr))) &&
	  (is_all_x_safe(sc, cadddr(expr))))
	{
	  set_optimize_data(expr, HOP_SAFE_C_C);
	  annotate_arg(sc, cdddr(expr));
	  return(string_set_ssa);
	}
    }
  return(f);
}

static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, f, args, expr);
  if ((is_pair(cadr(expr))) &&
      (is_safely_optimized(cadr(expr))) &&
      (c_call(cadr(expr)) == g_symbol_to_string))
    set_c_function(cadr(expr), symbol_to_string_uncopied);
  return(f);
}


static s7_pointer or_direct;
static s7_pointer g_or_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x;
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = car(p);
      if (is_symbol(x))
	x = finder(sc, x);
      if (is_true(sc, x))
	return(x);
    }
  return(sc->F);
}


static s7_pointer and_direct;
static s7_pointer g_and_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x;
  x = sc->T;
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = car(p);
      if (is_symbol(x))
	x = finder(sc, x);
      if (is_false(sc, x))
	return(x);
    }
  return(x);
}


static s7_pointer if_direct;
static s7_pointer g_if_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  p = car(args);
  if (is_symbol(p))
    p = finder(sc, p);
  if (is_true(sc, p))
    p = cadr(args);
  else 
    {
      if (!is_null(cddr(args)))
	p = caddr(args);
      else return(sc->UNSPECIFIED);
    }
  if (is_symbol(p))
    return(finder(sc, p));
  return(p);
}


static s7_pointer or_all_x;
static s7_pointer g_or_all_x(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x;
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = ((s7_function)fcdr(p))(sc, car(p));
      if (is_true(sc, x))
	return(x);
    }
  return(sc->F);
}


static s7_pointer and_all_x;
static s7_pointer g_and_all_x(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x = sc->T;
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = ((s7_function)fcdr(p))(sc, car(p));
      if (is_false(sc, x))
	return(x);
    }
  return(x);
}


static s7_pointer if_all_x;
static s7_pointer g_if_all_x(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  if (is_true(sc, ((s7_function)fcdr(args))(sc, car(args))))
    p = cdr(args);
  else 
    {
      p = cddr(args);
      if (is_null(p))
	return(sc->UNSPECIFIED);
    }
  return(((s7_function)fcdr(p))(sc, car(p)));
}


static s7_pointer if_all_x_qq;
static s7_pointer g_if_all_x_qq(s7_scheme *sc, s7_pointer args)
{
  if (is_true(sc, ((s7_function)fcdr(args))(sc, car(args))))
    return(cadr(cadr(args)));
  return(cadr(caddr(args)));
}


static s7_pointer if_all_x_qa;
static s7_pointer g_if_all_x_qa(s7_scheme *sc, s7_pointer args)
{
  if (is_true(sc, ((s7_function)fcdr(args))(sc, car(args))))
    return(cadr(cadr(args)));
  return(((s7_function)fcdr(cddr(args)))(sc, caddr(args)));
}


static s7_pointer or_s_direct;
static s7_pointer g_or_s_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x;
  car(sc->T1_1) = finder(sc, cadar(args));
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = c_call(car(p))(sc, sc->T1_1);
      if (is_true(sc, x))
	return(x);
    }
  return(sc->F);
}


static s7_pointer and_s_direct;
static s7_pointer g_and_s_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, x = sc->T;
  car(sc->T1_1) = finder(sc, cadar(args));
  for (p = args; is_pair(p); p = cdr(p))
    {
      x = c_call(car(p))(sc, sc->T1_1);
      if (is_false(sc, x))
	return(x);
    }
  return(x);
}


static s7_pointer if_s_direct;
static s7_pointer g_if_s_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  car(sc->T1_1) = finder(sc, cadar(args));
  if (is_true(sc, c_call(car(args))(sc, sc->T1_1)))
    p = cdr(args);
  else 
    {
      p = cddr(args);
      if (is_null(p))
	return(sc->UNSPECIFIED);
    }
  return(c_call(car(p))(sc, sc->T1_1));
}

/* cond_all_x_all_x happens very rarely, similarly let_all_x_all_x and case_all_x
 */



static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer uf;
  uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
  s7_function_set_class(uf, cls);
  return(uf);
}

static s7_pointer make_temp_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer uf;
  uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
  s7_function_set_class(uf, cls);
  s7_function_set_returns_temp(uf);
  return(uf);
}

static s7_pointer set_function_chooser(s7_scheme *sc, s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr))
{
  s7_pointer f;
  f = slot_value(global_slot(sym));
  c_function_chooser(f) = chooser;
  return(f);
}


static unsigned int add_class = 0, equal_class = 0;

static void init_choosers(s7_scheme *sc)
{
  s7_pointer f;

  /* + */
  f = set_function_chooser(sc, sc->ADD, add_chooser);
  add_class = c_function_class(f);

  add_1 = make_function_with_class(sc, f, "+", g_add_1, 1, 0, false, "+ optimization");
  add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false, "+ optimization");

  add_2_temp = make_temp_function_with_class(sc, f, "+", g_add_2_temp, 2, 0, false, "+ optimization");
  add_s_temp = make_temp_function_with_class(sc, f, "+", g_add_s_temp, 2, 0, false, "+ optimization");
  add_s_direct = make_temp_function_with_class(sc, f, "+", g_add_s_direct, 2, 0, false, "+ optimization");
  add_temp_s = make_temp_function_with_class(sc, f, "+", g_add_temp_s, 2, 0, false, "+ optimization");
  add_3_temp = make_temp_function_with_class(sc, f, "+", g_add_3_temp, 3, 0, false, "+ optimization");

  add_1s = make_function_with_class(sc, f, "+", g_add_1s, 2, 0, false, "+ optimization");
  add_s1 = make_function_with_class(sc, f, "+", g_add_s1, 2, 0, false, "+ optimization");
  add_cs1 = make_function_with_class(sc, f, "+", g_add_cs1, 2, 0, false, "+ optimization");
  add_si_i = make_function_with_class(sc, f, "+", g_add_si_i, 2, 0, false, "+ optimization");
  add_si = make_function_with_class(sc, f, "+", g_add_si, 2, 0, false, "+ optimization");
  add_is = make_function_with_class(sc, f, "+", g_add_is, 2, 0, false, "+ optimization");
  add_sf = make_function_with_class(sc, f, "+", g_add_sf, 2, 0, false, "+ optimization");
  add_fs = make_function_with_class(sc, f, "+", g_add_fs, 2, 0, false, "+ optimization");
  add_ss_1ss = make_temp_function_with_class(sc, f, "+", g_add_ss_1ss, 2, 0, false, "+ optimization");
  add_f_sf = make_function_with_class(sc, f, "+", g_add_f_sf, 2, 0, false, "+ optimization");
  add_f_sqr = make_function_with_class(sc, f, "+", g_add_f_sqr, 2, 0, false, "+ optimization");


  /* - */
  f = set_function_chooser(sc, sc->MINUS, subtract_chooser);

  subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false, "- optimization");
  subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false, "- optimization");
  subtract_s1 = make_function_with_class(sc, f, "-", g_subtract_s1, 2, 0, false, "- optimization");
  subtract_cs1 = make_function_with_class(sc, f, "-", g_subtract_cs1, 2, 0, false, "- optimization");
  subtract_csn = make_function_with_class(sc, f, "-", g_subtract_csn, 2, 0, false, "- optimization");
  subtract_ran = make_temp_function_with_class(sc, f, "-", g_subtract_ran, 2, 0, false, "- optimization");
  subtract_sf = make_function_with_class(sc, f, "-", g_subtract_sf, 2, 0, false, "- optimization");
  subtract_fs = make_function_with_class(sc, f, "-", g_subtract_fs, 2, 0, false, "- optimization");
  subtract_sf_f = make_function_with_class(sc, f, "-", g_subtract_sf_f, 2, 0, false, "- optimization");


  /* * */
  f = set_function_chooser(sc, sc->MULTIPLY, multiply_chooser);

  multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false, "* optimization");

  multiply_2_temp = make_temp_function_with_class(sc, f, "*", g_multiply_2_temp, 2, 0, false, "* optimization");
  multiply_3_temp = make_temp_function_with_class(sc, f, "*", g_multiply_3_temp, 3, 0, false, "* optimization");
  multiply_1_any = make_temp_function_with_class(sc, f, "*", g_multiply_1_any, 3, 0, true, "* optimization");
  multiply_s_temp = make_temp_function_with_class(sc, f, "*", g_multiply_s_temp, 2, 0, false, "* optimization");
  multiply_temp_s = make_temp_function_with_class(sc, f, "*", g_multiply_temp_s, 2, 0, false, "* optimization");
  multiply_s_direct = make_temp_function_with_class(sc, f, "*", g_multiply_s_direct, 2, 0, false, "* optimization");

  multiply_is = make_function_with_class(sc, f, "*", g_multiply_is, 2, 0, false, "* optimization");
  multiply_si = make_function_with_class(sc, f, "*", g_multiply_si, 2, 0, false, "* optimization");
  multiply_fs = make_function_with_class(sc, f, "*", g_multiply_fs, 2, 0, false, "* optimization");
  multiply_sf = make_function_with_class(sc, f, "*", g_multiply_sf, 2, 0, false, "* optimization");
#if (!WITH_GMP)
  sqr_ss = make_function_with_class(sc, f, "*", g_sqr_ss, 2, 0, false, "* optimization");
  mul_1ss = make_function_with_class(sc, f, "*", g_mul_1ss, 2, 0, false, "* optimization");
  multiply_cs_cos = make_function_with_class(sc, f, "*", g_multiply_cs_cos, 3, 0, false, "* optimization");
#endif


  /* / */
#if (!WITH_GMP)
  f = set_function_chooser(sc, sc->DIVIDE, divide_chooser);
  divide_1 = make_function_with_class(sc, f, "/", g_divide_1, 2, 0, false, "/ optimization");

  divide_1r = make_function_with_class(sc, f, "/", g_divide_1r, 2, 0, false, "/ optimization");
#endif


#if (!WITH_GMP)
  /* modulo */
  f = set_function_chooser(sc, sc->MODULO, modulo_chooser);
  mod_si = make_function_with_class(sc, f, "modulo", g_mod_si, 2, 0, false, "modulo optimization");

  /* abs */
  f = set_function_chooser(sc, sc->ABS, abs_chooser);
  abs_direct = make_temp_function_with_class(sc, f, "abs", g_abs_direct, 1, 0, false, "abs optimization");
#endif


  /* max */
  f = set_function_chooser(sc, sc->MAX, max_chooser);
  max_f2 = make_function_with_class(sc, f, "max", g_max_f2, 2, 0, false, "max optimization");


  /* min */
  f = set_function_chooser(sc, sc->MIN, min_chooser);
  min_f2 = make_function_with_class(sc, f, "min", g_min_f2, 2, 0, false, "min optimization");


  /* zero? */
  f = set_function_chooser(sc, sc->ZEROP, is_zero_chooser);


  /* = */
  f = set_function_chooser(sc, sc->EQ, equal_chooser);
  equal_class = c_function_class(f);

  equal_s_ic = make_function_with_class(sc, f, "=", g_equal_s_ic, 2, 0, false, "= optimization");
  equal_length_ic = make_function_with_class(sc, f, "=", g_equal_length_ic, 2, 0, false, "= optimization");
  equal_2 = make_function_with_class(sc, f, "=", g_equal_2, 2, 0, false, "= optimization");
#if (!WITH_GMP)
  mod_si_is_zero = make_function_with_class(sc, f, "=", g_mod_si_is_zero, 2, 0, false, "= optimization");
#endif

#if (!WITH_GMP)
  /* negative? */
  f = set_function_chooser(sc, sc->NEGATIVEP, is_negative_chooser);
  is_negative_length = make_function_with_class(sc, f, "negative?", g_is_negative_length, 1, 0, false, "negative? optimization");


  /* < */
  f = set_function_chooser(sc, sc->LT, less_chooser);

  less_s_ic = make_function_with_class(sc, f, "<", g_less_s_ic, 2, 0, false, "< optimization");
  less_s0 = make_function_with_class(sc, f, "<", g_less_s0, 2, 0, false, "< optimization");
  less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false, "< optimization");
  less_length_ic = make_function_with_class(sc, f, "<", g_less_length_ic, 2, 0, false, "< optimization");


  /* > */
  f = set_function_chooser(sc, sc->GT, greater_chooser);

  greater_s_ic = make_function_with_class(sc, f, ">", g_greater_s_ic, 2, 0, false, "> optimization");
  greater_s_fc = make_function_with_class(sc, f, ">", g_greater_s_fc, 2, 0, false, "> optimization");
  greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false, "> optimization");


  /* <= */
  f = set_function_chooser(sc, sc->LEQ, leq_chooser);

  leq_s_ic = make_function_with_class(sc, f, "<=", g_leq_s_ic, 2, 0, false, "<= optimization");
  leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false, "<= optimization");


  /* >= */
  f = set_function_chooser(sc, sc->GEQ, geq_chooser);

  geq_s_ic = make_function_with_class(sc, f, ">=", g_geq_s_ic, 2, 0, false, ">= optimization");
  geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false, ">= optimization");
  geq_length_ic = make_function_with_class(sc, f, ">=", g_geq_length_ic, 2, 0, false, ">= optimization");

  /* random */
  f = set_function_chooser(sc, sc->RANDOM, random_chooser);

  random_ic = make_function_with_class(sc, f, "random", g_random_ic, 1, 0, false, "random optimization");
  random_rc = make_function_with_class(sc, f, "random", g_random_rc, 1, 0, false, "random optimization");
  set_returns_temp(random_rc);
#endif

  /* aritable? */
  f = set_function_chooser(sc, sc->ARITABLEP, is_aritable_chooser);
  is_aritable_ic = make_function_with_class(sc, f, "aritable?", g_is_aritable_ic, 2, 0, false, "aritable? optimization");


  /* char=? */
  f = set_function_chooser(sc, sc->CHAR_EQ, char_equal_chooser);

  char_equal_s_ic = make_function_with_class(sc, f, "char=?", g_char_equal_s_ic, 2, 0, false, "char=? optimization");
  char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false, "char=? optimization");


  /* char>? */
  f = set_function_chooser(sc, sc->CHAR_GT, char_greater_chooser);

  char_greater_s_ic = make_function_with_class(sc, f, "char>?", g_char_greater_s_ic, 2, 0, false, "char>? optimization");
  char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false, "char>? optimization");


  /* char<? */
  f = set_function_chooser(sc, sc->CHAR_LT, char_less_chooser);

  char_less_s_ic = make_function_with_class(sc, f, "char<?", g_char_less_s_ic, 2, 0, false, "char<? optimization");
  char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false, "char<? optimization");


  /* char<=? */
  f = set_function_chooser(sc, sc->CHAR_LEQ, char_leq_chooser);

  char_leq_s_ic = make_function_with_class(sc, f, "char<=?", g_char_leq_s_ic, 2, 0, false, "char<=? optimization");
  char_leq_2 = make_function_with_class(sc, f, "char<=?", g_char_leq_2, 2, 0, false, "char<=? optimization");


  /* char>=? */
  f = set_function_chooser(sc, sc->CHAR_GEQ, char_geq_chooser);

  char_geq_s_ic = make_function_with_class(sc, f, "char>=?", g_char_geq_s_ic, 2, 0, false, "char>=? optimization");
  char_geq_2 = make_function_with_class(sc, f, "char>=?", g_char_geq_2, 2, 0, false, "char>=? optimization");


  /* char-ci=? */
  f = set_function_chooser(sc, sc->CHAR_CI_EQ, char_ci_equal_chooser);

  char_ci_equal_s_ic = make_function_with_class(sc, f, "char-ci=?", g_char_ci_equal_s_ic, 2, 0, false, "char-ci=? optimization");
  char_ci_equal_2 = make_function_with_class(sc, f, "char-ci=?", g_char_ci_equal_2, 2, 0, false, "char-ci=? optimization");


  /* char-ci>? */
  f = set_function_chooser(sc, sc->CHAR_CI_GT, char_ci_greater_chooser);

  char_ci_greater_s_ic = make_function_with_class(sc, f, "char-ci>?", g_char_ci_greater_s_ic, 2, 0, false, "char-ci>? optimization");
  char_ci_greater_2 = make_function_with_class(sc, f, "char-ci>?", g_char_ci_greater_2, 2, 0, false, "char-ci>? optimization");


  /* char-ci<? */
  f = set_function_chooser(sc, sc->CHAR_CI_LT, char_ci_less_chooser);

  char_ci_less_s_ic = make_function_with_class(sc, f, "char-ci<?", g_char_ci_less_s_ic, 2, 0, false, "char-ci<? optimization");
  char_ci_less_2 = make_function_with_class(sc, f, "char-ci<?", g_char_ci_less_2, 2, 0, false, "char-ci<? optimization");


  /* char-ci<=? */
  f = set_function_chooser(sc, sc->CHAR_CI_LEQ, char_ci_leq_chooser);

  char_ci_leq_s_ic = make_function_with_class(sc, f, "char-ci<=?", g_char_ci_leq_s_ic, 2, 0, false, "char-ci<=? optimization");
  char_ci_leq_2 = make_function_with_class(sc, f, "char-ci<=?", g_char_ci_leq_2, 2, 0, false, "char-ci<=? optimization");


  /* char-ci>=? */
  f = set_function_chooser(sc, sc->CHAR_CI_GEQ, char_ci_geq_chooser);

  char_ci_geq_s_ic = make_function_with_class(sc, f, "char-ci>=?", g_char_ci_geq_s_ic, 2, 0, false, "char-ci>=? optimization");
  char_ci_geq_2 = make_function_with_class(sc, f, "char-ci>=?", g_char_ci_geq_2, 2, 0, false, "char-ci>=? optimization");


  /* string=? */
  f = set_function_chooser(sc, sc->STRING_EQ, string_equal_chooser);

  string_equal_s_ic = make_function_with_class(sc, f, "string=?", g_string_equal_s_ic, 2, 0, false, "string=? optimization");
  string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false, "string=? optimization");


  /* substring */
  substring_to_temp = s7_make_function(sc, "substring", g_substring_to_temp, 2, 1, false, "substring optimization");
  s7_function_set_class(substring_to_temp, slot_value(global_slot(sc->SUBSTRING)));


  /* string>? */
  f = set_function_chooser(sc, sc->STRING_GT, string_greater_chooser);

  string_greater_s_ic = make_function_with_class(sc, f, "string>?", g_string_greater_s_ic, 2, 0, false, "string>? optimization");
  string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false, "string>? optimization");


  /* string<? */
  f = set_function_chooser(sc, sc->STRING_LT, string_less_chooser);

  string_less_s_ic = make_function_with_class(sc, f, "string<?", g_string_less_s_ic, 2, 0, false, "string<? optimization");
  string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false, "string<? optimization");


  /* string<=? */
  f = set_function_chooser(sc, sc->STRING_LEQ, string_leq_chooser);

  string_leq_s_ic = make_function_with_class(sc, f, "string<=?", g_string_leq_s_ic, 2, 0, false, "string<=? optimization");
  string_leq_2 = make_function_with_class(sc, f, "string<=?", g_string_leq_2, 2, 0, false, "string<=? optimization");


  /* string>=? */
  f = set_function_chooser(sc, sc->STRING_GEQ, string_geq_chooser);

  string_geq_s_ic = make_function_with_class(sc, f, "string>=?", g_string_geq_s_ic, 2, 0, false, "string>=? optimization");
  string_geq_2 = make_function_with_class(sc, f, "string>=?", g_string_geq_2, 2, 0, false, "string>=? optimization");


  /* string-ci=? */
  f = set_function_chooser(sc, sc->STRING_CI_EQ, string_ci_equal_chooser);

  string_ci_equal_s_ic = make_function_with_class(sc, f, "string-ci=?", g_string_ci_equal_s_ic, 2, 0, false, "string-ci=? optimization");
  string_ci_equal_2 = make_function_with_class(sc, f, "string-ci=?", g_string_ci_equal_2, 2, 0, false, "string-ci=? optimization");


  /* string-ci>? */
  f = set_function_chooser(sc, sc->STRING_CI_GT, string_ci_greater_chooser);

  string_ci_greater_s_ic = make_function_with_class(sc, f, "string-ci>?", g_string_ci_greater_s_ic, 2, 0, false, "string-ci>? optimization");
  string_ci_greater_2 = make_function_with_class(sc, f, "string-ci>?", g_string_ci_greater_2, 2, 0, false, "string-ci>? optimization");


  /* string-ci<? */
  f = set_function_chooser(sc, sc->STRING_CI_LT, string_ci_less_chooser);

  string_ci_less_s_ic = make_function_with_class(sc, f, "string-ci<?", g_string_ci_less_s_ic, 2, 0, false, "string-ci<? optimization");
  string_ci_less_2 = make_function_with_class(sc, f, "string-ci<?", g_string_ci_less_2, 2, 0, false, "string-ci<? optimization");


  /* string-ci<=? */
  f = set_function_chooser(sc, sc->STRING_CI_LEQ, string_ci_leq_chooser);

  string_ci_leq_s_ic = make_function_with_class(sc, f, "string-ci<=?", g_string_ci_leq_s_ic, 2, 0, false, "string-ci<=? optimization");
  string_ci_leq_2 = make_function_with_class(sc, f, "string-ci<=?", g_string_ci_leq_2, 2, 0, false, "string-ci<=? optimization");


  /* string-ci>=? */
  f = set_function_chooser(sc, sc->STRING_CI_GEQ, string_ci_geq_chooser);

  string_ci_geq_s_ic = make_function_with_class(sc, f, "string-ci>=?", g_string_ci_geq_s_ic, 2, 0, false, "string-ci>=? optimization");
  string_ci_geq_2 = make_function_with_class(sc, f, "string-ci>=?", g_string_ci_geq_2, 2, 0, false, "string-ci>=? optimization");


  /* string-ref */
  f = set_function_chooser(sc, sc->STRING_REF, string_ref_chooser);

  /* string-set! */
  f = set_function_chooser(sc, sc->STRING_SET, string_set_chooser);
  string_set_ssa = make_function_with_class(sc, f, "string-set!", g_string_set_ssa, 3, 0, false, "string-set! optimization");

  string_set_ssa_looped = s7_make_function(sc, "string-set!", g_string_set_ssa_looped, 3, 0, false, "string-set! optimization");
  s7_function_set_class(string_set_ssa_looped, f);
  s7_function_set_looped(string_set_ssa, string_set_ssa_looped);
  s7_function_set_ex_parser(f, string_set_ex_parser);


  /* string-append */
  f = set_function_chooser(sc, sc->STRING_APPEND, string_append_chooser);


  /* symbol->string experiment */
  f = slot_value(global_slot(sc->SYMBOL_TO_STRING));
  symbol_to_string_uncopied = s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, "symbol->string optimization");
  s7_function_set_class(symbol_to_string_uncopied, f);


  /* for-each */
  f = set_function_chooser(sc, sc->FOR_EACH, for_each_chooser);

  for_each_1 = make_function_with_class(sc, f, "for-each", g_for_each_1, 2, 0, false, "for-each optimization");
  for_each_2 = make_function_with_class(sc, f, "for-each", g_for_each_2, 2, 0, false, "for-each optimization");

  
  /* vector-ref */
  f = set_function_chooser(sc, sc->VECTOR_REF, vector_ref_chooser);

  vector_ref_ic = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic, 2, 0, false, "vector-ref optimization");
  vector_ref_add1 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_add1, 2, 0, false, "vector-ref optimization");
  vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false, "vector-ref optimization");
  vector_ref_gs = make_function_with_class(sc, f, "vector-ref", g_vector_ref_gs, 2, 0, false, "vector-ref optimization");
  vector_ref_ggs = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ggs, 2, 0, false, "vector-ref optimization");


  /* vector-set! */
  f = set_function_chooser(sc, sc->VECTOR_SET, vector_set_chooser);

  vector_set_ic = make_function_with_class(sc, f, "vector-set!", g_vector_set_ic, 3, 0, false, "vector-set! optimization");
  vector_set_vref = make_function_with_class(sc, f, "vector-set!", g_vector_set_vref, 3, 0, false, "vector-set! optimization");
  vector_set_ssc = make_function_with_class(sc, f, "vector-set!", g_vector_set_ssc, 3, 0, false, "vector-set! optimization");
  vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false, "vector-set! optimization");

  vector_set_ssc_looped = make_function_with_class(sc, f, "vector-set!", g_vector_set_ssc_looped, 3, 0, false, "vector-set! optimization");
  s7_function_set_looped(vector_set_ssc, vector_set_ssc_looped);



  /* list-ref */
  f = set_function_chooser(sc, sc->LIST_REF, list_ref_chooser);
  list_ref_ic = make_function_with_class(sc, f, "list-ref", g_list_ref_ic, 2, 0, false, "list-ref optimization");


  /* list-set! */
  f = set_function_chooser(sc, sc->LIST_SET, list_set_chooser);
  list_set_ic = make_function_with_class(sc, f, "list-set!", g_list_set_ic, 3, 0, false, "list-set! optimization");


  /* hash-table-ref */
  f = set_function_chooser(sc, sc->HASH_TABLE_REF, hash_table_ref_chooser);

  hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false, "hash-table-ref optimization");
  hash_table_ref_ss = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_ss, 2, 0, false, "hash-table-ref optimization");
  hash_table_ref_car = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_car, 2, 0, false, "hash-table-ref optimization");


  /* car */
  f = set_function_chooser(sc, sc->CAR, car_chooser);

  /* cdr */
  f = set_function_chooser(sc, sc->CDR, cdr_chooser);


  /* format */
  f = set_function_chooser(sc, sc->FORMAT, format_chooser);

  format_allg = make_function_with_class(sc, f, "format", g_format_allg, 1, 0, true, "format optimization");
  format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true, "format optimization");
  format_just_newline = make_function_with_class(sc, f, "format", g_format_just_newline, 2, 0, false, "format optimization");


  /* not */
  f = set_function_chooser(sc, sc->NOT, not_chooser);

  not_is_pair = make_function_with_class(sc, f, "not", g_not_is_pair, 1, 0, false, "not optimization");
  not_is_null = make_function_with_class(sc, f, "not", g_not_is_null, 1, 0, false, "not optimization");
  not_is_list = make_function_with_class(sc, f, "not", g_not_is_list, 1, 0, false, "not optimization");
  not_is_symbol = make_function_with_class(sc, f, "not", g_not_is_symbol, 1, 0, false, "not optimization");
  not_is_number = make_function_with_class(sc, f, "not", g_not_is_number, 1, 0, false, "not optimization");
  not_is_real = make_function_with_class(sc, f, "not", g_not_is_real, 1, 0, false, "not optimization");
  not_is_rational = make_function_with_class(sc, f, "not", g_not_is_rational, 1, 0, false, "not optimization");
  not_is_integer = make_function_with_class(sc, f, "not", g_not_is_integer, 1, 0, false, "not optimization");
  not_is_boolean = make_function_with_class(sc, f, "not", g_not_is_boolean, 1, 0, false, "not optimization");
  not_is_string = make_function_with_class(sc, f, "not", g_not_is_string, 1, 0, false, "not optimization");
  not_is_char = make_function_with_class(sc, f, "not", g_not_is_char, 1, 0, false, "not optimization");
  not_is_eof = make_function_with_class(sc, f, "not", g_not_is_eof, 1, 0, false, "not optimization");
  not_is_eq_ss = make_function_with_class(sc, f, "not", g_not_is_eq_ss, 1, 0, false, "not optimization");
  not_is_eq_sq = make_function_with_class(sc, f, "not", g_not_is_eq_sq, 1, 0, false, "not optimization");
  not_is_pair_car = make_function_with_class(sc, f, "not", g_not_is_pair_car, 1, 0, false, "not optimization");
  not_is_null_cdr = make_function_with_class(sc, f, "not", g_not_is_null_cdr, 1, 0, false, "not optimization");
  not_c_c = make_function_with_class(sc, f, "not", g_not_c_c, 1, 0, false, "not optimization");


  /* pair? */
  f = set_function_chooser(sc, sc->PAIRP, is_pair_chooser);

  is_pair_car = make_function_with_class(sc, f, "pair?", g_is_pair_car, 1, 0, false, "pair? optimization");
  is_pair_cdr = make_function_with_class(sc, f, "pair?", g_is_pair_cdr, 1, 0, false, "pair? optimization");
  is_pair_cadr = make_function_with_class(sc, f, "pair?", g_is_pair_cadr, 1, 0, false, "pair? optimization");


  /* null? */
  f = set_function_chooser(sc, sc->NULLP, is_null_chooser);
  is_null_cdr = make_function_with_class(sc, f, "null?", g_is_null_cdr, 1, 0, false, "null? optimization");


  /* eq? */
  f = set_function_chooser(sc, sc->EQP, is_eq_chooser);

  is_eq_car = make_function_with_class(sc, f, "eq?", g_is_eq_car, 2, 0, false, "eq? optimization");
  is_eq_car_q = make_function_with_class(sc, f, "eq?", g_is_eq_car_q, 2, 0, false, "eq? optimization");
  is_eq_caar_q = make_function_with_class(sc, f, "eq?", g_is_eq_caar_q, 2, 0, false, "eq? optimization");


  /* memq */
  f = set_function_chooser(sc, sc->MEMQ, memq_chooser);
  
  memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false, "memq optimization");
  memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false, "memq optimization");
  memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false, "memq optimization");
  memq_car = make_function_with_class(sc, f, "memq", g_memq_car, 2, 0, false, "memq optimization");


  /* member */
  f = set_function_chooser(sc, sc->MEMBER, member_chooser);
  
  member_ss = make_function_with_class(sc, f, "member", g_member_ss, 2, 0, false, "member optimization");
  member_sq = make_function_with_class(sc, f, "member", g_member_sq, 2, 0, false, "member optimization");
  member_sym_s = make_function_with_class(sc, f, "member", g_member_sym_s, 2, 0, false, "member optimization");
  member_num_s = make_function_with_class(sc, f, "member", g_member_num_s, 2, 0, false, "member optimization");


  /* read-char */
  f = set_function_chooser(sc, sc->READ_CHAR, read_char_chooser);
  
  read_char_0 = make_function_with_class(sc, f, "read-char", g_read_char_0, 0, 0, false, "read-char optimization");
  read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false, "read-char optimization");


  /* write-char */
  f = set_function_chooser(sc, sc->WRITE_CHAR, write_char_chooser);
  
  write_char_1 = make_function_with_class(sc, f, "write-char", g_write_char_1, 1, 0, false, "write-char optimization");
  write_char_a_s = make_function_with_class(sc, f, "write-char", g_write_char_a_s, 2, 0, false, "write-char optimization");

  write_char_a_s_looped = s7_make_function(sc, "write-char", g_write_char_a_s_looped, 2, 0, false, "write-char optimization");
  s7_function_set_class(write_char_a_s_looped, f);
  s7_function_set_looped(write_char_a_s, write_char_a_s_looped);


  /* or and if simple cases */
  or_direct = s7_make_function(sc, "or", g_or_direct, 0, 0, true, "or optimization");
  and_direct = s7_make_function(sc, "and", g_and_direct, 0, 0, true, "and optimization");
  if_direct = s7_make_function(sc, "if", g_if_direct, 2, 1, false, "if optimization");

  or_all_x = s7_make_function(sc, "or", g_or_all_x, 0, 0, true, "or optimization");
  and_all_x = s7_make_function(sc, "and", g_and_all_x, 0, 0, true, "and optimization");
  if_all_x = s7_make_function(sc, "if", g_if_all_x, 2, 1, false, "if optimization");
  if_all_x_qq = s7_make_function(sc, "if", g_if_all_x_qq, 3, 0, false, "if optimization");
  if_all_x_qa = s7_make_function(sc, "if", g_if_all_x_qa, 3, 0, false, "if optimization");

  or_s_direct = s7_make_function(sc, "or", g_or_s_direct, 0, 0, true, "or optimization");
  and_s_direct = s7_make_function(sc, "and", g_and_s_direct, 0, 0, true, "and optimization");
  if_s_direct = s7_make_function(sc, "if", g_if_s_direct, 2, 1, false, "if optimization");
}


static bool optimize_expression(s7_scheme *sc, s7_pointer x, int hop, s7_pointer e);

static s7_pointer collect_collisions(s7_scheme *sc, s7_pointer lst, s7_pointer e)
{
  s7_pointer p;
  sc->w = e;
  for (p = lst; is_pair(p); p = cdr(p))
    {
      if ((is_symbol(car(p))) &&
	  (global_slot(car(p)) != sc->NIL))
	sc->w = cons(sc, car(p), sc->w);
      else
	{
	  if ((is_pair(car(p))) &&
	      (is_symbol(caar(p))) &&
	      (global_slot(caar(p)) != sc->NIL))
	    sc->w = cons(sc, caar(p), sc->w);
	}
    }
  return(sc->w);
}


static bool is_all_x_op(int op)
{
  return((op == HOP_SAFE_C_S) ||
	 (op == HOP_SAFE_C_C) ||
	 (op == HOP_SAFE_C_Q) ||
	 (op == HOP_SAFE_C_SS) ||
	 (op == HOP_SAFE_C_SSS) ||
	 (op == HOP_SAFE_C_SC) ||
	 (op == HOP_SAFE_C_CS) ||
	 (op == HOP_SAFE_C_SQ) ||
	 (op == HOP_SAFE_C_opCq) ||
	 (op == HOP_SAFE_C_opSq) ||
	 (op == HOP_SAFE_C_opSSq) ||
	 (op == HOP_SAFE_C_opSSq_S) ||
	 (op == HOP_SAFE_C_S_opSSq) ||
	 (op == HOP_SAFE_C_S_opSq) ||
	 (op == HOP_SAFE_C_S_opCq) ||
	 (op == HOP_SAFE_C_C_opSq) ||
	 (op == HOP_SAFE_C_C_opCq) ||
	 (op == HOP_SAFE_C_opCq_S) ||
	 (op == HOP_SAFE_C_opSq_S) ||
	 (op == HOP_SAFE_C_opSq_C) ||
	 (op == HOP_SAFE_C_opCq_C) ||
	 (op == HOP_SAFE_C_opSq_opSq) ||
	 (op == HOP_SAFE_C_opSSq_opSSq));
}


static bool is_all_x_safe(s7_scheme *sc, s7_pointer p)
{
  if ((!is_pair(p)) ||
      ((car(p) == sc->QUOTE) &&
       (is_pair(cdr(p)))))   /* (if #t (quote . -1)) */
    return(true);
  if (!is_optimized(p))
    return(false);
  return(is_all_x_op(optimize_data(p)));
}


static int all_x_count(s7_pointer x)
{
  int count = 0;
  s7_pointer p;
  for (p = cdr(x); is_pair(p); p = cdr(p))
    if ((is_pair(car(p))) &&
	(is_optimized(car(p))) &&
	(is_all_x_op(optimize_data(car(p)))))
      count++;
  return(count);
}


/* arg here is the full expression */

static s7_pointer all_x_else(s7_scheme *sc, s7_pointer arg)
{
  return(sc->T); /* used in cond_all_x */
}

static s7_pointer all_x_c(s7_scheme *sc, s7_pointer arg)
{
  return(arg);
}

static s7_pointer all_x_q(s7_scheme *sc, s7_pointer arg)
{
  return(cadr(arg));
}

static s7_pointer all_x_s(s7_scheme *sc, s7_pointer arg)
{
  return(finder(sc, arg));
}

static s7_pointer all_x_c_c(s7_scheme *sc, s7_pointer arg)
{
  return(c_call(arg)(sc, cdr(arg)));
}

static s7_pointer all_x_c_q(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T1_1) = cadr(cadr(arg));
  return(c_call(arg)(sc, sc->T1_1));
}

static s7_pointer all_x_c_s(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T1_1) = finder(sc, cadr(arg));
  return(c_call(arg)(sc, sc->T1_1));
}
		    
static s7_pointer all_x_cdr_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer val;
  val = finder(sc, cadr(arg));
  return((is_pair(val)) ? cdr(val) : g_cdr(sc, list_1(sc, val)));
}
		    
static s7_pointer all_x_car_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer val;
  val = finder(sc, cadr(arg));
  return((is_pair(val)) ? car(val) : g_car(sc, list_1(sc, val)));
}
		    
static s7_pointer all_x_null_s(s7_scheme *sc, s7_pointer arg)
{
  return(make_boolean(sc, is_null(finder(sc, cadr(arg)))));
}
		    
static s7_pointer all_x_c_sc(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T2_1) = finder(sc, cadr(arg));
  car(sc->T2_2) = caddr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_pointer all_x_c_cs(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T2_2) = finder(sc, caddr(arg));
  car(sc->T2_1) = cadr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_pointer all_x_c_ss(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T2_1) = finder(sc, cadr(arg));
  car(sc->T2_2) = finder(sc, caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}		    

static s7_pointer all_x_c_s1s2(s7_scheme *sc, s7_pointer arg)
{
  /* (define (hi a b) (if (> a b) a b)) */
  s7_pointer slots;
  slots = environment_slots(sc->envir);
  if (slot_symbol(slots) == cadr(arg))
    {
      car(sc->T2_1) = slot_value(slots);
      car(sc->T2_2) = slot_value(next_slot(slots));
    }
  else
    {
      car(sc->T2_2) = slot_value(slots);
      car(sc->T2_1) = slot_value(next_slot(slots));
    }
  return(c_call(arg)(sc, sc->T2_1));
}		    

static s7_pointer all_x_c_is_eq_ss(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer slots;
  slots = environment_slots(sc->envir);
  return(make_boolean(sc, slot_value(slots) == slot_value(next_slot(slots))));
}		    

static s7_pointer all_x_c_sss(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T3_1) = finder(sc, cadr(arg));
  car(sc->T3_2) = finder(sc, caddr(arg));
  car(sc->T3_3) = finder(sc, cadddr(arg));
  return(c_call(arg)(sc, sc->T3_1));
}		    

static s7_pointer all_x_c_sq(s7_scheme *sc, s7_pointer arg)
{
  car(sc->T2_1) = finder(sc, cadr(arg));
  car(sc->T2_2) = cadr(caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_pointer all_x_c_s12q(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer slots;
  slots = environment_slots(sc->envir);
  if (slot_symbol(slots) == cadr(arg))
    car(sc->T2_1) = slot_value(slots);
  else car(sc->T2_1) = slot_value(next_slot(slots));
  car(sc->T2_2) = cadr(caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_pointer all_x_c_is_eq_s2q(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer slots;
  slots = environment_slots(sc->envir);
  if (slot_symbol(slots) == cadr(arg))
    return(make_boolean(sc, slot_value(slots) == cadr(caddr(arg))));
  return(make_boolean(sc, slot_value(next_slot(slots)) == cadr(caddr(arg))));
}

#if 0
static s7_pointer all_x_c_if_sq_qq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer slots, eq_expr;
  slots = environment_slots(sc->envir);
  eq_expr = cadr(arg);
  if (slot_symbol(slots) != cadr(eq_expr))
    slots = next_slot(slots);
  return((slot_value(slots) == cadr(caddr(eq_expr))) ? cadr(caddr(arg)) : cadr(cadddr(arg)));
}
#endif

static s7_pointer all_x_c_opcq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T1_1) = c_call(largs)(sc, cdr(largs));
  return(c_call(arg)(sc, sc->T1_1));
}
		    
static s7_pointer all_x_c_s_opcq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  car(sc->T2_2) = c_call(largs)(sc, cdr(largs));
  car(sc->T2_1) = finder(sc, cadr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_c_opcq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  car(sc->T2_2) = c_call(largs)(sc, cdr(largs));
  car(sc->T2_1) = cadr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opcq_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T2_1) = c_call(largs)(sc, cdr(largs));
  car(sc->T2_2) = finder(sc, caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opcq_c(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T2_1) = c_call(largs)(sc, cdr(largs));
  car(sc->T2_2) = caddr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opsq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T1_1) = c_call(largs)(sc, sc->T1_1);
  return(c_call(arg)(sc, sc->T1_1));
}
		    
static s7_pointer all_x_c_opssq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T2_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = finder(sc, caddr(largs));
  car(sc->T1_1) = c_call(largs)(sc, sc->T2_1);
  return(c_call(arg)(sc, sc->T1_1));
}
		    
static s7_pointer all_x_c_opssq_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T2_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = finder(sc, caddr(largs));
  car(sc->T2_1) = c_call(largs)(sc, sc->T2_1);
  car(sc->T2_2) = finder(sc, caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opsq_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T2_1) = c_call(largs)(sc, sc->T1_1);
  car(sc->T2_2) = finder(sc, caddr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opsq_c(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T2_1) = c_call(largs)(sc, sc->T1_1);
  car(sc->T2_2) = caddr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_s_opssq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  car(sc->T2_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = finder(sc, caddr(largs));
  car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
  car(sc->T2_1) = finder(sc, cadr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_s_opsq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
  car(sc->T2_1) = finder(sc, cadr(arg));
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_c_opsq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
  car(sc->T2_1) = cadr(arg);
  return(c_call(arg)(sc, sc->T2_1));
}
		    
static s7_pointer all_x_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cdr(arg);
  car(sc->T1_1) = finder(sc, cadr(car(largs)));
  sc->temp4 = c_call(car(largs))(sc, sc->T1_1);
  largs = cadr(largs);
  car(sc->T1_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = c_call(largs)(sc, sc->T1_1);
  car(sc->T2_1) = sc->temp4;
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_pointer all_x_c_opssq_opssq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cdr(arg);
  car(sc->T2_1) = finder(sc, cadr(car(largs)));
  car(sc->T2_2) = finder(sc, caddr(car(largs)));
  sc->temp4 = c_call(car(largs))(sc, sc->T2_1);
  largs = cadr(largs);
  car(sc->T2_1) = finder(sc, cadr(largs));
  car(sc->T2_2) = finder(sc, caddr(largs));
  car(sc->T2_2) = c_call(largs)(sc, sc->T2_1);
  car(sc->T2_1) = sc->temp4;
  return(c_call(arg)(sc, sc->T2_1));
}

static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg)
{
  if (is_pair(arg))
    {
      if (is_optimized(arg))
	{
	  set_annotated(arg);
	  /* fprintf(stderr, "annotate %s %s\n", DISPLAY(arg), opt_name(arg)); */
	  switch (optimize_data(arg))
	    {
	    case HOP_SAFE_C_C:         return(all_x_c_c);
	    case HOP_SAFE_C_Q:         return(all_x_c_q);
	    case HOP_SAFE_C_S:         
	      if (car(arg) == sc->CDR)
		return(all_x_cdr_s);
	      if (car(arg) == sc->CAR)
		return(all_x_car_s);
	      if (car(arg) == sc->NULLP)
		return(all_x_null_s);
	      return(all_x_c_s);
	    case HOP_SAFE_C_SC:        return(all_x_c_sc);
	    case HOP_SAFE_C_CS:        return(all_x_c_cs);
	    case HOP_SAFE_C_SS:        return(all_x_c_ss);
	    case HOP_SAFE_C_SSS:       return(all_x_c_sss);
	    case HOP_SAFE_C_SQ:        return(all_x_c_sq);
	    case HOP_SAFE_C_opCq:      return(all_x_c_opcq);
	    case HOP_SAFE_C_opSq:      return(all_x_c_opsq);
	    case HOP_SAFE_C_opSSq:     return(all_x_c_opssq);
	    case HOP_SAFE_C_opSq_S:    return(all_x_c_opsq_s);
	    case HOP_SAFE_C_opSq_C:    return(all_x_c_opsq_c);
	    case HOP_SAFE_C_S_opSq:    return(all_x_c_s_opsq);
	    case HOP_SAFE_C_S_opCq:    return(all_x_c_s_opcq);
	    case HOP_SAFE_C_opCq_S:    return(all_x_c_opcq_s);
	    case HOP_SAFE_C_opCq_C:    return(all_x_c_opcq_c);
	    case HOP_SAFE_C_C_opSq:    return(all_x_c_c_opsq);
	    case HOP_SAFE_C_C_opCq:    return(all_x_c_c_opcq);
	    case HOP_SAFE_C_opSSq_S:   return(all_x_c_opssq_s);
	    case HOP_SAFE_C_S_opSSq:   return(all_x_c_s_opssq);
	    case HOP_SAFE_C_opSq_opSq: return(all_x_c_opsq_opsq);
	    case HOP_SAFE_C_opSSq_opSSq: return(all_x_c_opssq_opssq);
	    }
	}
      return(all_x_q);
    }
  if (is_symbol(arg))
    return(all_x_s);
  return(all_x_c);
}


static s7_function orp_all_x_eval(s7_scheme *sc, s7_pointer arg)
{
  if ((!is_pair(arg)) ||
      ((is_optimized(arg)) &&
       (is_all_x_op(optimize_data(arg)))))
    return(all_x_eval(sc, arg));
  return(NULL);
}

static s7_function cond_all_x_eval(s7_scheme *sc, s7_pointer arg)
{
  if (arg == sc->ELSE)
    return(all_x_else);
  return(all_x_eval(sc, arg));
}



static void choose_c_function(s7_scheme *sc, s7_pointer expr, s7_pointer func, int args)
{
  set_c_function(expr, c_function_chooser(func)(sc, func, args, expr));
}


static bool optimize_thunk(s7_scheme *sc, s7_pointer car_x, s7_pointer func, int hop)
{
  /* fprintf(stderr, "thunk: %s\n", DISPLAY(car_x)); */
  if ((is_c_function(func)) &&
      ((is_safe_procedure(func)) ||
       (c_function_call(func) == g_list) ||          /* (list) is safe */
       (c_function_call(func) == g_values)))         /* (values) is safe */
    {
      set_optimized(car_x);
      set_optimize_data(car_x, hop + OP_SAFE_C_C);
      choose_c_function(sc, car_x, func, 0);
      return(true);
    }
  
  if ((is_closure(func)) &&
      (is_null(closure_args(func))))                 /* no rest arg funny business */
    {
      /* look for a case like (define (version) (s7-version)) 
       */
      if (is_null(cdr(closure_body(func))))          /* I think if the body is hop_safe_c_c, the current hop setting is irrelevant (local func -> 1 etc) */
	{
	  s7_pointer body;
	  body = car(closure_body(func));
	  if ((is_optimized(body)) &&
	      (!is_unsafe(body)) &&
	      (is_null(cdr(body))) &&                /* else (define (hi) (vector 0.0)) (define (ho) (hi)) -- the "C"'s don't match */
	      (optimize_data(body) == HOP_SAFE_C_C)) /* see above */
	    {
	      set_optimized(car_x);
	      set_optimize_data(car_x, HOP_SAFE_C_C);
	      set_ecdr(car_x, ecdr(body));
	      set_fcdr(car_x, fcdr(body));
	      return(true);
	    }
	}

      set_unsafely_optimized(car_x);
      set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_THUNK : OP_THUNK));
      set_ecdr(car_x, func);
      return(false);                                /* false because currently the C_PP stuff assumes safe procedure calls */
    }

  if ((is_closure_star(func)) &&
      (is_proper_list(sc, closure_args(func))) &&
      (has_simple_args(closure_body(func))))
    {
      set_unsafely_optimized(car_x);
      set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR : OP_CLOSURE_STAR));
      set_ecdr(car_x, func);
      return(false); 
    }

  return(false);
}


static int combine_ops(s7_scheme *sc, combine_op_t op1, s7_pointer e1, s7_pointer e2)
{
  int op2;
  op2 = op_no_hop(e2);
  /* fprintf(stderr, "    %s %s\n", opt_names[optimize_data(e2)], DISPLAY_80(e2)); */

  switch (op1)
    {
    case E_C_P:
      switch (op2)
	{
	case OP_SAFE_C_C: 
	  return(OP_SAFE_C_opCq); /* this includes the multi-arg C_C cases */

	case OP_SAFE_C_S: 
	  return(OP_SAFE_C_opSq);

	case OP_SAFE_C_Q: 
	  return(OP_SAFE_C_opQq);

	case OP_SAFE_C_SS: 
	  return(OP_SAFE_C_opSSq);

	case OP_SAFE_C_SQ: 
	  return(OP_SAFE_C_opSQq);

	case OP_SAFE_C_SC: 
	  return(OP_SAFE_C_opSCq);

	case OP_SAFE_C_CS: 
	  return(OP_SAFE_C_opCSq);
	}
      return(OP_SAFE_C_Z); /* this splits out to A in optimize_func_one_arg */
      break;
      

    case E_C_SP:
      switch (op2)
	{
	case OP_SAFE_C_S:
	  set_ecdr(cdr(e1), cadr(e2));
	  return(OP_SAFE_C_S_opSq);

	case OP_SAFE_C_C:
	  set_ecdr(cdr(e1), cdr(e2));
	  return(OP_SAFE_C_S_opCq);

	case OP_SAFE_C_SC:
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_S_opSCq);
	  
	case OP_SAFE_C_CS:
	  /* (* a (- 1 b)), e1 is the full expr, e2 is (- 1 b) */
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_S_opCSq);

	case OP_SAFE_C_SS:
	  /* (* a (- b c)) */
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_S_opSSq);

	case OP_SAFE_C_opSSq_S:
	  return(OP_SAFE_C_S_op_opSSq_Sq);

	case OP_SAFE_C_S_opSSq:
	  return(OP_SAFE_C_S_op_S_opSSqq);

	case OP_SAFE_C_SZ:
	  return(OP_SAFE_C_S_opSZq);

	case OP_SAFE_C_AA:
	  return(OP_SAFE_C_S_opAAq);

	case OP_SAFE_C_CSA:
	case OP_SAFE_C_SSA:
	case OP_SAFE_C_AAA:
	  return(OP_SAFE_C_S_opAAAq);
	}
      return(OP_SAFE_C_SZ);
      break;


    case E_C_PS:
      switch (op2)
	{
	case OP_SAFE_C_C:
	  return(OP_SAFE_C_opCq_S);

	case OP_SAFE_C_S:
	  return(OP_SAFE_C_opSq_S);
	  
	case OP_SAFE_C_CS:
	  return(OP_SAFE_C_opCSq_S);

	case OP_SAFE_C_SC:
	  return(OP_SAFE_C_opSCq_S);

	case OP_SAFE_C_SS:
	  return(OP_SAFE_C_opSSq_S);
	}
      return(OP_SAFE_C_ZS);
      break;


    case E_C_PC:
      switch (op2)
	{
	case OP_SAFE_C_C:
	  return(OP_SAFE_C_opCq_C);

	case OP_SAFE_C_S:
	  return(OP_SAFE_C_opSq_C);

	case OP_SAFE_C_CS:
	  return(OP_SAFE_C_opCSq_C);

	case OP_SAFE_C_SS:
	  return(OP_SAFE_C_opSSq_C);

	case OP_SAFE_C_SC:
	  return(OP_SAFE_C_opSCq_C);

	case OP_SAFE_C_opSSq:
	  return(OP_SAFE_C_op_opSSq_q_C);
	}
      return(OP_SAFE_C_ZC);
      break;


    case E_C_CP:
      switch (op2)
	{
	case OP_SAFE_C_C:
	  set_ecdr(cdr(e1), cdr(e2));
	  return(OP_SAFE_C_C_opCq);

	case OP_SAFE_C_S:
	  set_ecdr(cdr(e1), cadr(e2));
	  return(OP_SAFE_C_C_opSq);

	case OP_SAFE_C_CS:
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opCSq);

	case OP_SAFE_C_SC:
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opSCq);
	  
	case OP_SAFE_C_SS:
	  set_ecdr(cdr(e1), cadr(e2));
	  set_fcdr(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opSSq);
	}
      return(OP_SAFE_C_CZ);
      break;


    case E_C_PP:
      switch (op2)
	{
	case OP_SAFE_C_S:
	  if (optimize_data_match(e1, OP_SAFE_C_S))
	    return(OP_SAFE_C_opSq_opSq);
	  if (optimize_data_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opSq);
	  break;

	case OP_SAFE_C_C:
	  if (optimize_data_match(e1, OP_SAFE_C_C))
	    return(OP_SAFE_C_opCq_opCq);
	  if (optimize_data_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opCq);
	  break;

	case OP_SAFE_C_SC:
	  if (optimize_data_match(e1, OP_SAFE_C_SC))
	    return(OP_SAFE_C_opSCq_opSCq);
	  break;

	case OP_SAFE_C_SS:
	  if (optimize_data_match(e1, OP_SAFE_C_C))
	    return(OP_SAFE_C_opCq_opSSq);
	  if (optimize_data_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opSSq);
	  if (optimize_data_match(e1, OP_SAFE_C_S))
	    return(OP_SAFE_C_opSq_opSSq);
	  break;
	}
      return(OP_SAFE_C_ZZ);
      break;

    default:
      break;
    }
  return(OP_NO_OP);
}


#define arglist_length(P) gcdr(cdr(P))
#define set_arglist_length(P, X) set_gcdr(cdr(P), X)

static void annotate_args(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    set_fcdr(p, (s7_pointer)all_x_eval(sc, car(p)));
}

static void annotate_arg(s7_scheme *sc, s7_pointer arg)
{
  set_fcdr(arg, (s7_pointer)all_x_eval(sc, car(arg)));
}

static s7_pointer check_or(s7_scheme *sc);

static bool optimize_func_one_arg(s7_scheme *sc, s7_pointer car_x, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs)
{
  bool func_is_safe, func_is_c_function, func_is_closure;
  s7_pointer cadar_x;

  /* fprintf(stderr, "%s: %d\n", DISPLAY_80(car_x), hop); */

  func_is_closure = is_closure(func);

  if ((func_is_closure) &&
      (closure_arity_to_int(sc, func) != 1))
    return(false);

  if ((is_closure_star(func)) &&
      ((!has_simple_args(closure_body(func))) || 
       (is_null(closure_args(func)))))
    return(false);

  func_is_safe = is_safe_procedure(func);
  func_is_c_function = is_c_function(func);
  cadar_x = cadr(car_x);

  if (pairs == 0)
    {
      if (func_is_c_function)
	{
	  if (func_is_safe)                  /* safe c function */
	    {     
	      set_optimized(car_x);
	      set_optimize_data(car_x, hop + ((symbols == 0) ? OP_SAFE_C_C : OP_SAFE_C_S));

	      /* we can't simply check is_global here to forego symbol value lookup later because we aren't
	       *    tracking local vars, so the global bit may be on right now, but won't be when
	       *    this code is evaluated.  But memq(sym, e) would catch such cases.
	       *    I think it has already been checked for func, so we only need to look for cadar_x.
	       *    But global symbols are rare, and I don't see a huge savings in the lookup time --
	       *    in callgrind it's about 7/lookup in both cases.
	       */

	      choose_c_function(sc, car_x, func, 1);
	      return(true);
	    }
	  else                               /* c function is not safe */
	    {
	      set_unsafely_optimized(car_x);
	      if (symbols == 0)
		{
		  set_optimize_data(car_x, hop + OP_C_A);
		  annotate_arg(sc, cdr(car_x));
		  set_arglist_length(car_x, small_int(1));
		}
	      else 
		{
		  if (c_function_call(func) == g_read)
		    set_optimize_data(car_x, hop + OP_READ_S);
		  else set_optimize_data(car_x, hop + OP_C_S);
		}
	      choose_c_function(sc, car_x, func, 1);
	      return(false); 
	    }
	}
      else                                   /* func is from scheme */
	{
	  if (func_is_closure)
	    {
	      if (is_symbol(cadar_x))
		{
		  bool safe_case;
		  safe_case = is_safe_closure(func);
		  if (safe_case)
		    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_S);
		  else
		    {
		      if ((is_null(cdr(closure_body(func)))) &&
			  (!symbol_has_accessor(car(closure_args(func)))))
			set_optimize_data(car_x, hop + OP_CLOSURE_Sp);
		      else set_optimize_data(car_x, hop + OP_CLOSURE_S);
		    }
		}
	      else set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_C : OP_CLOSURE_C));
	      set_ecdr(car_x, func);
	      set_fcdr(car_x, cadar_x);
	      set_unsafely_optimized(car_x);

	      if ((optimize_data_match(car_x, OP_SAFE_CLOSURE_S)) &&
		  (is_null(cdr(closure_body(func)))))
		{
		  s7_pointer body;
		  body = closure_body(func);
		  if (is_h_optimized(car(body)))
		    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_S_Z);
		  else set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_S_P);
		}
	      return(false); 
	    }
	  else /* not closure with normal arglist */
	    {
	      if (s7_is_vector(func))
		{
		  set_optimized(car_x);
		  set_optimize_data(car_x, hop + ((is_symbol(cadar_x)) ? OP_VECTOR_S : OP_VECTOR_C));
		  set_ecdr(car_x, func);
		  return(true);
		}

	      if ((is_environment(func)) &&
		  (symbols == 1))
		{
		  set_optimized(car_x);
		  set_optimize_data(car_x, hop + OP_ENVIRONMENT_S);
		  set_ecdr(car_x, func);
		  return(true);
		}

	      /* pairs == 0 here */
	      if ((is_closure_star(func)) &&
		  (symbols == 1))
		{
		  set_unsafely_optimized(car_x);
		  if (is_safe_closure(func))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_STAR_S);
		      if (closure_star_arity_to_int(sc, func) == 2)
			{
			  s7_pointer defarg2;
			  defarg2 = cadr(closure_args(func));
			  /* fprintf(stderr, "look for s0: %s %s\n", DISPLAY(func), DISPLAY(defarg2)); */
			  if ((is_pair(defarg2)) &&
			      (is_real(cadr(defarg2))) &&
			      (real(cadr(defarg2)) == 0.0))
			    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_STAR_S0);
			}
		    }
		  else set_optimize_data(car_x, hop + OP_CLOSURE_STAR_S);
		  set_ecdr(car_x, func);
		  set_fcdr(car_x, cadar_x);
		  return(false); 
		}
	    }
	}
    }
  
  if (pairs == 1)
    {
      if (bad_pairs == 0)
	{
	  /* we can optimize whatever the arg involves */
	  if (func_is_c_function)
	    {
	      if (func_is_safe)
		{
		  int op;
		  op = combine_ops(sc, E_C_P, car_x, cadar_x);
		  /* fallback is Z */

		  set_optimized(car_x);
		  set_optimize_data(car_x, hop + op);
		  if ((op == OP_SAFE_C_Z) &&
		      (is_all_x_op(optimize_data(cadar_x))))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_A);
		      annotate_arg(sc, cdr(car_x));
		    }
		  choose_c_function(sc, car_x, func, 1);
		}
	      else
		{
		  if (is_all_x_op(optimize_data(cadar_x)))
		    {
		      set_unsafely_optimized(car_x);
		      set_optimize_data(car_x, hop + OP_C_A);
		      annotate_arg(sc, cdr(car_x));
		      set_arglist_length(car_x, small_int(1));
		      choose_c_function(sc, car_x, func, 1);
		      return(false); 
		    }
		}
	    }
	  else      /* func is from scheme */
	    {
	      if ((func_is_closure) &&
		  ((is_safe_c_s(cadar_x)) ||
		   (optimize_data_match(cadar_x, OP_SAFE_C_C))))
		{
		  if (is_safe_c_s(cadar_x))
		    {
		      set_unsafely_optimized(car_x);
		      if (is_safe_closure(func))
			set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_opSq);
		      else
			{
			  if ((c_call(cadar_x) == g_cdr) &&
			      (symbol_id(sc->CDR) == 0))
			    set_optimize_data(car_x, hop + OP_CLOSURE_CDR_S);
			  else set_optimize_data(car_x, hop + OP_CLOSURE_opSq);
			}
		      set_fcdr(car_x, cadr(cadar_x));
		      set_ecdr(car_x, func);
		      return(false); 
		    }
		  else 
		    {
		      set_unsafely_optimized(car_x);
		      if (is_safe_closure(func))
			set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_opCq);
		      else set_optimize_data(car_x, hop + OP_CLOSURE_opCq);
		      set_fcdr(car_x, cadar_x);
		      set_ecdr(car_x, func);
		      return(false); 
		    }
		}
	    }
	}
      else      /* bad_pairs is 1 */
	{
	  if (quotes == 1)
	    {
	      if (func_is_c_function)
		{
		  if (func_is_safe)
		    {
		      set_optimized(car_x);
		      set_optimize_data(car_x, hop + OP_SAFE_C_Q);
		      choose_c_function(sc, car_x, func, 1);
		    }
		  else
		    {
		      set_unsafely_optimized(car_x);
		      set_optimize_data(car_x, hop + OP_C_A);
		      annotate_arg(sc, cdr(car_x));
		      set_arglist_length(car_x, small_int(1));
		      choose_c_function(sc, car_x, func, 1);
		      return(false); 
		    }
		}
	      else
		{
		  if (func_is_closure)
		    {
		      set_unsafely_optimized(car_x);
		      set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_Q : OP_CLOSURE_Q));
		      set_ecdr(car_x, func);
		      return(false); 
		    }
		}
	    }
	  else    /* bad pair is not quoted */
	    {
	      if (func_is_c_function)
		{
		  if (!func_is_safe)
		    {
		      s7_pointer lambda_expr;
		      lambda_expr = cadar_x;
		      if ((is_pair(lambda_expr)) &&
			  (is_lambda(sc, car(lambda_expr))) && /* check for stuff like (define (f) (eval (lambda 2))) */
			  (is_pair(cdr(lambda_expr))) &&   
			  (is_pair(cddr(lambda_expr))))
			{
			  if ((c_function_call(func) == g_call_with_exit) &&
			      (is_pair(cadr(lambda_expr))) &&
			      (is_null(cdadr(lambda_expr))))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + OP_CALL_WITH_EXIT);
			      choose_c_function(sc, car_x, func, 1);
			      set_fcdr(car_x, cdr(lambda_expr));
			      return(false);
			    }
			}
		    }
		}
	    }
	}

      if ((!is_optimized(car_x)) &&
	  (quotes == 0) &&
	  (func_is_c_function))
	{
	  if (func_is_safe)
	    {
	      set_optimized(car_x);
	      if (bad_pairs == 0)
		{
		  if (is_all_x_safe(sc, cadar_x))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_A);
		      annotate_arg(sc, cdr(car_x));
		    }
		  else set_optimize_data(car_x, hop + OP_SAFE_C_Z); 
		  choose_c_function(sc, car_x, func, 1);
		  set_arglist_length(car_x, small_int(1));
		  return(true);
		}
	      else
		{
		  set_unsafe(car_x);
		  set_optimize_data(car_x, hop + OP_SAFE_C_P);
		  choose_c_function(sc, car_x, func, 1);
		  return(false);
		}
	      /* didn't we do all this already? */
	    }
	  else
	    {
	      set_unsafely_optimized(car_x);
	      set_optimize_data(car_x, hop + OP_C_P);
	      choose_c_function(sc, car_x, func, 1);
	      return(false);
	    }
	}
    }

  if ((!is_optimized(car_x)) &&
      (pairs == (quotes + all_x_count(car_x))))
    {
      if (((func_is_closure) ||
	   (is_closure_star(func))) &&
	  (!arglist_has_accessed_symbol(closure_args(func))))
	{
	  set_unsafely_optimized(car_x);
	  if (func_is_closure)
	    set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_X)));
	  else set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X))); 
	  annotate_arg(sc, cdr(car_x));
	  set_ecdr(car_x, func);
	  set_arglist_length(car_x, small_int(1));
	  return(false);
	}
    }

  return(is_optimized(car_x));  
}


static bool optimize_func_two_args(s7_scheme *sc, s7_pointer car_x, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs)
{
  s7_pointer cadar_x, caddar_x;
  bool func_is_safe, func_is_c_function, func_is_closure;

  /* fprintf(stderr, "opt func %s %s %d %d\n", DISPLAY(func), DISPLAY_80(car_x), pairs, bad_pairs); */

  func_is_closure = is_closure(func);

  if ((func_is_closure) &&
      (closure_arity_to_int(sc, func) != 2))
    return(false);

  if ((is_closure_star(func)) &&
      ((!has_simple_args(closure_body(func))) ||
       (closure_star_arity_to_int(sc, func) < 2) ||
       (arglist_has_keyword(cdr(car_x)))))
    return(false);

  func_is_safe = is_safe_procedure(func);
  func_is_c_function = is_c_function(func);
  cadar_x = cadr(car_x);
  caddar_x = caddr(car_x);

  if (pairs == 0)
    {
      if (func_is_c_function)
	{
	  if ((func_is_safe) ||
	      (c_function_call(func) == g_member) || /* the unsafe case has a third arg */
	      (c_function_call(func) == g_assoc))
	    {
	      /* another case here: set-car! and set-cdr! are safe if symbols==1 and cadar_x is the symbol (i.e. caddar_x is a constant) */

	      if (symbols == 0)
		set_optimize_data(car_x, hop + OP_SAFE_C_C);
	      else
		{
		  if (symbols == 2)
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_SS); /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */
		      if (c_function_call(func) == g_cons)
			set_optimize_op(car_x, hop + OP_SAFE_CONS_SS);
		    }
		  else set_optimize_data(car_x, hop + ((is_symbol(cadar_x)) ? OP_SAFE_C_SC : OP_SAFE_C_CS));
		}
	      set_optimized(car_x);
	      choose_c_function(sc, car_x, func, 2);
	      return(true);
	    }
	  else
	    {
	      set_unsafely_optimized(car_x);
	      if ((symbols == 2) &&
		  (c_function_call(func) == g_apply))
		{
		  set_optimize_data(car_x, hop + OP_APPLY_SS);
		  set_ecdr(car_x, func);
		  set_fcdr(car_x, caddar_x);
		}
	      else 
		{
		  set_optimize_data(car_x, hop + OP_C_ALL_X);
		  annotate_args(sc, cdr(car_x));
		  set_arglist_length(car_x, small_int(2));
		  choose_c_function(sc, car_x, func, 2);
		}
	      return(false); 
	    }
	}
      else
	{
	  if ((func_is_closure) &&
	      (symbols >= 1))
	    {
	      set_unsafely_optimized(car_x);
	      if (symbols == 2)
		{
		  bool safe_case;
		  safe_case = is_safe_closure(func);
		  if (safe_case)
		    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_SS);
		  else
		    {
		      if (!arglist_has_accessed_symbol(closure_args(func)))
			set_optimize_data(car_x, hop + ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_SSp : OP_CLOSURE_SSb));
		      else set_optimize_data(car_x, hop + OP_CLOSURE_SS);
		    }
		}
	      else
		{
		  if (is_symbol(cadar_x))
		    set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)));
		  else set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_CS : OP_CLOSURE_CS)));
		}
	      set_ecdr(car_x, func);
	      set_fcdr(car_x, caddar_x);
	      return(false);
	    }
	  else
	    {
	      if ((is_closure_star(func)) &&
		  (symbols >= 1) &&
		  (is_symbol(cadar_x)))
		{
		  set_unsafely_optimized(car_x);
		  if (symbols == 2)
		    set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_SS : OP_CLOSURE_STAR_SX));
		  else set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_SC : OP_CLOSURE_STAR_SX));
		  set_ecdr(car_x, func);
		  set_fcdr(car_x, caddar_x);
		  return(false); 
		}
	    }
	}
    }
  else /* pairs != 0 */
    {
      if (bad_pairs == 0)
	{
	  /* using safe_c_aa here whenever possible was much slower */
	  
	  if (pairs == 2)
	    {
	      if (func_is_c_function)
		{
		  if ((func_is_safe) ||
		      (c_function_call(func) == g_member) ||
		      (c_function_call(func) == g_assoc))
		    {
		      int op;
		      op = combine_ops(sc, E_C_PP, cadar_x, caddar_x);
		      /* fallback here is ZZ */

		      set_optimized(car_x);
		      set_optimize_data(car_x, hop + op);
		      
		      if (op == OP_SAFE_C_ZZ)
			{
			  if (is_all_x_safe(sc, cadar_x))
			    {
			      if (is_all_x_safe(sc, caddar_x))
				{
				  set_optimize_data(car_x, hop + OP_SAFE_C_AA);
				  annotate_args(sc, cdr(car_x));
				  set_arglist_length(car_x, small_int(2));
				}
			      else
				{
				  if (optimize_data(cadar_x) == HOP_SAFE_C_C)
				    set_optimize_data(car_x, hop + OP_SAFE_C_opCq_Z);
				  else 
				    {
				      set_optimize_data(car_x, hop + OP_SAFE_C_AZ);
				      annotate_arg(sc, cdr(car_x));
				      set_arglist_length(car_x, small_int(2));
				    }
				}
			    }
			  else
			    {
			      if (is_all_x_safe(sc, caddar_x))
				{
				  set_optimize_data(car_x, hop + OP_SAFE_C_ZA);
				  annotate_arg(sc, cddr(car_x));
				  set_arglist_length(car_x, small_int(2));
				}
			    }
			}
		      choose_c_function(sc, car_x, func, 2); /* this might change the op to safe_c_c, so it has to be last */
		    }
		}
	      else
		{
		  if ((func_is_closure) &&
		      (is_safe_c_s(cadar_x)) &&
		      (is_safe_c_s(caddar_x)))
		    {
		      set_unsafely_optimized(car_x);
		      if (is_safe_closure(func))
			set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_opSq_opSq);
		      else set_optimize_data(car_x, hop + OP_CLOSURE_opSq_opSq);
		      if ((is_null(cdr(closure_body(func)))) &&
			  (is_safe_closure(func)) &&
			  (!arglist_has_accessed_symbol(closure_args(func))))
			{
			  if ((c_call(cadar_x) == g_car) &&
			      (c_call(caddar_x) == g_car) &&
			      (symbol_id(sc->CAR) == 0))
			    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_CAR_CAR);
			  else
			    {
			      if ((c_call(cadar_x) == g_cdr) &&
				  (c_call(caddar_x) == g_cdr) &&
				  (symbol_id(sc->CDR) == 0))
				set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_CDR_CDR);
			    }
			}
		      set_ecdr(car_x, func);
		      set_fcdr(car_x, cadr(caddar_x));
		      set_fcdr(cdr(car_x), cadr(cadar_x));
		      return(false);
		    }
		}
	    }
	  if (pairs == 1)
	    {
	      if (func_is_c_function)
		{
		  if ((func_is_safe) ||
		      (c_function_call(func) == g_member) ||
		      (c_function_call(func) == g_assoc))
		    {
		      combine_op_t orig_op;
		      int op;
		      
		      if (is_pair(cadar_x))
			{
			  if (is_symbol(caddar_x))
			    orig_op = E_C_PS;
			  else orig_op = E_C_PC;
			  op = combine_ops(sc, orig_op, car_x, cadar_x);
			}
		      else 
			{
			  if (is_symbol(cadar_x))
			    orig_op = E_C_SP;
			  else orig_op = E_C_CP;
			  op = combine_ops(sc, orig_op, car_x, caddar_x);
			}
		      
		      set_optimized(car_x);
		      set_optimize_data(car_x, hop + op);
		      choose_c_function(sc, car_x, func, 2);
		    }
		  else
		    {
		      if (symbols == 1)
			{
			  if (is_symbol(cadar_x))
			    {
			      if (is_safe_c_s(caddar_x))
				{
				  set_unsafely_optimized(car_x);
				  set_optimize_data(car_x, hop + OP_C_S_opSq);
				  set_ecdr(cdr(car_x), cadr(caddar_x));
				  choose_c_function(sc, car_x, func, 2);
				  return(false);
				}
			      if (optimize_data_match(caddar_x, OP_SAFE_C_C))
				{
				  set_unsafely_optimized(car_x);
				  set_optimize_data(car_x, hop + OP_C_S_opCq);
				  set_ecdr(cdr(car_x), cdr(caddar_x));
				  choose_c_function(sc, car_x, func, 2);
				  return(false);
				}
			    }
			}
		    }
		}
	      else
		{
		  if (func_is_closure)
		    {
		      if (is_symbol(cadar_x))
			{
			  if (is_safe_c_s(caddar_x))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_S_opSq : OP_CLOSURE_S_opSq)));
			      set_ecdr(car_x, func);
			      return(false); 
			    }
			  if ((is_optimized(caddar_x)) &&
			      (op_no_hop(caddar_x) == OP_SAFE_C_SS))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_S_opSSq : OP_CLOSURE_S_opSSq)));
			      set_ecdr(car_x, func);
			      return(false); 
			    }
			}
		      if (is_symbol(caddar_x))
			{
			  if (is_safe_c_s(cadar_x))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_opSq_S : OP_CLOSURE_opSq_S)));
			      set_ecdr(car_x, func);
			      set_fcdr(car_x, caddar_x);
			      return(false); 
			    }
			  if ((is_optimized(cadar_x)) &&
			      (op_no_hop(cadar_x) == OP_SAFE_C_SS))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_opSSq_S : OP_CLOSURE_opSSq_S)));
			      set_ecdr(car_x, func);
			      return(false); 
			    }
			}
		    }
		}
	    }
	}
      else /* pairs != 0 and bad_pairs != 0 */
	{
	  if ((bad_pairs == 1) && (quotes == 1))
	    {
	      if (func_is_c_function)
		{
		  if ((func_is_safe) ||
		      (c_function_call(func) == g_member) ||
		      (c_function_call(func) == g_assoc))
		    {
		      if  (symbols == 1)
			{
			  set_optimized(car_x);
			  if (is_symbol(cadar_x))
			    set_optimize_data(car_x, hop + OP_SAFE_C_SQ);
			  else set_optimize_data(car_x, hop + OP_SAFE_C_QS);
			  choose_c_function(sc, car_x, func, 2);
			}
		      else
			{
			  if (pairs == 2)
			    {
			      set_optimized(car_x);
			      set_optimize_data(car_x, hop + ((car(cadar_x) == sc->QUOTE) ? OP_SAFE_C_QZ : OP_SAFE_C_ZQ));
			      choose_c_function(sc, car_x, func, 2);
			    }
			}
		    }
		  else
		    {
		      if (pairs == 1)
			{
			  set_unsafely_optimized(car_x);
			  set_optimize_data(car_x, hop + OP_C_ALL_X);
			  annotate_args(sc, cdr(car_x));
			  set_arglist_length(car_x, small_int(2));
			  choose_c_function(sc, car_x, func, 2);
			  return(false); 
			}
		    }
		}
	    }
	  else
	    {
	      if (quotes == 2)
		{
		  if (func_is_c_function)
		    {
		      if ((func_is_safe) ||
			  (c_function_call(func) == g_member) ||
			  (c_function_call(func) == g_assoc))
			{
			  set_optimized(car_x);
			  set_optimize_data(car_x, hop + OP_SAFE_C_QQ);
 			  choose_c_function(sc, car_x, func, 2);
			}
		      else
			{
			  set_unsafely_optimized(car_x);
			  set_optimize_data(car_x, hop + OP_C_ALL_X);
			  annotate_args(sc, cdr(car_x));
			  set_arglist_length(car_x, small_int(2));
			  choose_c_function(sc, car_x, func, 2);
			  return(false); 
			}
		    }
		}
	      else
		{
		  if ((bad_pairs == 1) &&
		      (is_pair(cadar_x)) &&
		      (func_is_c_function) &&
		      ((is_symbol(caddar_x)) ||
		       ((pairs == 2) &&
			(is_safe_c_s(caddar_x)))))
		    {
		      s7_pointer lambda_expr;
		      lambda_expr = cadar_x;
		      
		      if ((is_pair(lambda_expr)) &&
			  (is_lambda(sc, car(lambda_expr))) && /* check for stuff like (define (f) (for-each (lambda 2) ...)) */
			  (is_pair(cdr(lambda_expr))) &&   
			  (is_pair(cddr(lambda_expr))) &&
			  (s7_list_length(sc, cadr(lambda_expr)) == 1) &&
			  (is_symbol(caadr(lambda_expr))) &&
			  (!is_immutable(caadr(lambda_expr))))
			{
			  choose_c_function(sc, car_x, func, 2);
			  if ((c_call(car_x) == g_for_each_1) &&
			      (is_symbol(caddar_x)))
			    {
			      set_unsafely_optimized(car_x);
			      set_optimize_data(car_x, hop + OP_C_FOR_EACH_LS);
			    }
			  else
			    {
			      if (c_call(car_x) == g_for_each_2)
				{
				  /* args are safe, body is one-liner */
				  set_unsafely_optimized(car_x);
				  if (is_symbol(caddar_x))
				    set_optimize_data(car_x, hop + OP_C_FOR_EACH_LS_2);
				  else set_optimize_data(car_x, hop + OP_C_FOR_EACH_L_opSq);
				  return(false);
				}
			    }
			}
		    }
		}
	    }
	}
    }

  if (!is_optimized(car_x))
    {
      if ((pairs == 1) &&
	  (quotes == 0) &&
	  (func_is_c_function) &&
	  ((func_is_safe) ||
	   (c_function_call(func) == g_member) ||
	   (c_function_call(func) == g_assoc)))
	{
	  if (symbols == 1)
	    {
	      set_optimized(car_x);
	      if (bad_pairs == 0)
		{
		  set_optimize_data(car_x, hop + ((is_symbol(cadar_x)) ? OP_SAFE_C_SZ : OP_SAFE_C_ZS));
		  choose_c_function(sc, car_x, func, 2);
		  return(true);
		}
	      else
		{
		  /* unknowns get here: (* amp (amps 0))
		   * also list: (make-polywave pitch (list 1 0.93 2 0.07))
		   * and (* vol (granulate gen))
		   */
		  set_unsafe(car_x);
		  set_optimize_data(car_x, hop + ((is_symbol(cadar_x)) ? OP_SAFE_C_SP : OP_SAFE_C_PS));
		  choose_c_function(sc, car_x, func, 2);
		  return(false);
		}
	    }
	  else
	    {
	      if (symbols == 0)
		{
		  set_optimized(car_x);
		  if (bad_pairs == 0)
		    {
		      set_optimize_data(car_x, hop + ((is_symbol(cadar_x)) ? OP_SAFE_C_CZ : OP_SAFE_C_ZC));
		      choose_c_function(sc, car_x, func, 2);
		      return(true);
		    }
		  else
		    {
		      set_unsafe(car_x);
		      set_optimize_data(car_x, hop + ((is_pair(cadar_x)) ? OP_SAFE_C_PC : OP_SAFE_C_CP));
		      choose_c_function(sc, car_x, func, 2);
		      return(false);
		    }
		}
	    }
	}

      if ((pairs == 2) &&
	  (func_is_c_function) &&
	  ((func_is_safe) ||
	   (c_function_call(func) == g_member) ||
	   (c_function_call(func) == g_assoc)))
	{
	  if ((bad_pairs == 1) &&
	      (is_safe_c_s(cadar_x)))
	    {
	      /* unsafe func here won't work unless we check that later and make the new arg list (for {list} etc)
	       *   (and it has to be the last pair else the unknown_s stuff can mess up)
	       */
	      set_unsafely_optimized(car_x);
	      set_optimize_data(car_x, hop + OP_SAFE_C_opSq_P);
	      choose_c_function(sc, car_x, func, 2);
	      return(false);
	    }
	  else
	    {
	      if (quotes == 0) 
		{
		  set_unsafely_optimized(car_x);
		  set_optimize_data(car_x, hop + OP_SAFE_C_PP); /* unP case? */
		  choose_c_function(sc, car_x, func, 2);
		  return(false);
		}
	      else
		{
		  if (quotes == 1)
		    {
		      if (car(cadar_x) == sc->QUOTE)
			set_optimize_data(car_x, hop + OP_SAFE_C_QP);
		      else set_optimize_data(car_x, hop + OP_SAFE_C_PQ);
		      set_unsafely_optimized(car_x);
		      choose_c_function(sc, car_x, func, 2);
		      return(false);
		    }
		}
	    }
	}
    }

  if ((!is_optimized(car_x)) &&
      (pairs == (quotes + all_x_count(car_x))))
    {
      if ((func_is_c_function) &&
	  (func_is_safe))
	{
	  set_optimized(car_x);
	  set_optimize_data(car_x, hop + OP_SAFE_C_AA);
	  annotate_args(sc, cdr(car_x));
	  set_arglist_length(car_x, small_int(2));
	  choose_c_function(sc, car_x, func, 2);
	  return(true);
	}
      else 
	{
	  if (((func_is_closure) ||
	       (is_closure_star(func))) &&
	      (!arglist_has_accessed_symbol(closure_args(func))))
	    {
	      set_unsafely_optimized(car_x);
	      if (func_is_closure)
		{
		  if (is_safe_closure(func))
		    {
		      if (is_symbol(cadar_x))
			set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_SA);
		      else set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_ALL_X);
		    }
		  else set_optimize_data(car_x, hop + OP_CLOSURE_ALL_X);
		}
	      else 
		{
		  if (is_safe_closure(func))
		    {
		      if ((is_symbol(cadar_x)) &&
			  (closure_star_arity_to_int(sc, func) == 2))
			  set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_STAR_SA);
		      else set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_STAR_ALL_X);
		    }
		  else set_optimize_data(car_x, hop + OP_CLOSURE_STAR_ALL_X);
		}
	      annotate_args(sc, cdr(car_x));
	      set_ecdr(car_x, func);
	      set_arglist_length(car_x, small_int(2));
	      return(false);
	    }
	}
    }

  if ((!is_optimized(car_x)) &&
      (pairs == 1) &&
      (symbols == 1) &&
      (quotes == 0) &&
      (func_is_c_function) &&
      (!func_is_safe) &&
      (is_symbol(cadar_x)))
    {
      set_unsafely_optimized(car_x);
      set_optimize_data(car_x, hop + OP_C_SP);
      choose_c_function(sc, car_x, func, 2);
      return(false);
    }

  return(is_optimized(car_x));  
}


static bool optimize_func_three_args(s7_scheme *sc, s7_pointer car_x, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs)
{
  s7_pointer cadar_x, caddar_x, cadddar_x;
  bool func_is_safe, func_is_c_function, func_is_closure;

  func_is_closure = is_closure(func);

  if ((func_is_closure) &&
      (closure_arity_to_int(sc, func) != 3))
    return(false);

  if ((is_closure_star(func)) &&
      ((!has_simple_args(closure_body(func))) ||
       (closure_star_arity_to_int(sc, func) < 3) ||
       (arglist_has_keyword(cdr(car_x)))))
    return(false);

  func_is_safe = is_safe_procedure(func);
  func_is_c_function = is_c_function(func);
  cadar_x = cadr(car_x);
  caddar_x = caddr(car_x);
  cadddar_x = cadddr(car_x);

  /* here quotes in safe functions are somewhat rare: list-ref, format, etc */
  if (pairs == 0)
    {
      if (func_is_c_function)
	{
	  if (func_is_safe)
	    {
	      set_optimized(car_x);
	      if (symbols == 0)
		set_optimize_data(car_x, hop + OP_SAFE_C_C);
	      else 
		{
		  if (symbols == 3)
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_SSS);
		      set_ecdr(cdr(car_x), caddar_x);
		      set_fcdr(cdr(car_x), cadddar_x);
		    }
		  else
		    {
		      if (symbols == 2)
			{
			  set_ecdr(cdr(car_x), caddar_x);
			  set_fcdr(cdr(car_x), cadddar_x);
			  if (!is_symbol(cadar_x))
			    set_optimize_data(car_x, hop + OP_SAFE_C_CSS);
			  else
			    {
			      if (!is_symbol(cadddar_x))
				set_optimize_data(car_x, hop + OP_SAFE_C_SSC);
			      else set_optimize_data(car_x, hop + OP_SAFE_C_SCS);
			    }
			}
		      else 
			{
			  set_optimize_data(car_x, hop + OP_SAFE_C_AAA); /* fallback on all_x_c and s here -- a kludge */
			  annotate_args(sc, cdr(car_x));
			  set_arglist_length(car_x, small_int(3));
			}
		    }
		}
	      choose_c_function(sc, car_x, func, 3);
	      return(true);
	    }
	}
      else
	{
	  if ((func_is_closure) &&
	      (symbols == 3))
	    {
	      bool safe_case;
	      safe_case = is_safe_closure(func);
	      set_unsafely_optimized(car_x);
	      set_ecdr(car_x, func);

	      if (safe_case)
		{
		  set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_SSS);
		  set_fcdr(car_x, cadddar_x);
		  return(false);
		}
	      
	      if (!arglist_has_accessed_symbol(closure_args(func)))
		{
		  set_arglist_length(car_x, small_int(3));
		  set_optimize_data(car_x, hop + OP_CLOSURE_ALL_S);
		}
	      else
		{
		  set_optimize_data(car_x, hop + OP_CLOSURE_SSS);
		  set_fcdr(car_x, cadddar_x);
		}
	      return(false);
	    }
	}
    }


  /*
  fprintf(stderr, "%s: %d [%s] %d %d %d\n", 
	  DISPLAY(car_x),
	  is_optimized(car_x), (is_optimized(car_x) ? opt_names[optimize_data(car_x)] : ""),
	  pairs, quotes, all_x_count(car_x));
  */

  if (pairs == quotes + all_x_count(car_x))
    {
      if (func_is_c_function)
	{
	  set_optimized(car_x);
	  if (func_is_safe)
	    {
	      if ((symbols == 2) &&
		  (quotes == 1))
		{
		  if ((is_symbol(cadar_x)) &&
		      (is_symbol(cadddar_x)))
		    {
		      set_ecdr(cdr(car_x), cadr(caddar_x));
		      set_fcdr(cdr(car_x), cadddar_x);
		      set_optimize_data(car_x, hop + OP_SAFE_C_SQS);
		      choose_c_function(sc, car_x, func, 3);
		      return(true);
		    }
		}
	      annotate_args(sc, cdr(car_x));
	      set_arglist_length(car_x, small_int(3));

	      if ((pairs == 1) &&
		  (symbols == 1) &&
		  (is_symbol(caddar_x)) &&
		  (!is_pair(cadar_x)))
		set_optimize_data(car_x, hop + OP_SAFE_C_CSA);
	      else
		{
		  if ((is_symbol(cadar_x)) &&
		      (is_symbol(caddar_x)))
		    set_optimize_data(car_x, hop + OP_SAFE_C_SSA);
		  else set_optimize_data(car_x, hop + OP_SAFE_C_AAA);
		}
	      choose_c_function(sc, car_x, func, 3);
	    }
	  else 
	    {
	      annotate_args(sc, cdr(car_x));
	      set_arglist_length(car_x, small_int(3));
	      set_optimize_data(car_x, hop + OP_C_ALL_X);
	      choose_c_function(sc, car_x, func, 3);
	      if (optimize_data(car_x) != HOP_SAFE_C_C) /* did chooser fix it up? */
		{
		  set_unsafe(car_x);
		  return(false); 
		}
	    }
	  return(true);
	}
      else 
	{
	  if (((func_is_closure) ||
	       (is_closure_star(func))) &&
	      (!arglist_has_accessed_symbol(closure_args(func))))
	    {
	      set_unsafely_optimized(car_x);
	      if (func_is_closure)
		{
		  if (is_safe_closure(func))
		    {
		      if (is_symbol(cadar_x))
			{
			  if ((c_call(caddar_x) == g_cdr) &&
			      (c_call(cadddar_x) == g_cdr) &&
			      (symbol_id(sc->CDR) == 0))
			    set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_S_CDR_CDR);
			  else set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_SAA);
			}
		      else set_optimize_data(car_x, hop + OP_SAFE_CLOSURE_ALL_X);
		    }
		  else set_optimize_data(car_x, hop + OP_CLOSURE_ALL_X);
		}
	      else set_optimize_data(car_x, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X)));
	      annotate_args(sc, cdr(car_x));
	      set_ecdr(car_x, func);
	      set_arglist_length(car_x, small_int(3));
	      return(false);
	    }
	}
    }

  if ((bad_pairs == 0) &&
      (func_is_c_function) &&
      (func_is_safe) &&
      (pairs > 0))
    {
      if ((symbols == 2) &&
	  (is_symbol(cadar_x)) &&
	  (is_symbol(caddar_x)))
	{
	  set_optimize_data(car_x, hop + OP_SAFE_C_SSZ);
	}
      else
	{
	  /* use either X or Z in all 8 choices */
	  if ((!is_pair(cadar_x)) ||
	      (is_all_x_op(optimize_data(cadar_x))))
	    {
	      annotate_arg(sc, cdr(car_x));
	      if ((!is_pair(caddar_x)) ||
		  (is_all_x_op(optimize_data(caddar_x))))
		{
		  set_optimize_data(car_x, hop + OP_SAFE_C_AAZ); /* here last can't be A because we checked for that above */
		  annotate_arg(sc, cddr(car_x));
		}
	      else
		{
		  if ((!is_pair(cadddar_x)) ||
		      (is_all_x_op(optimize_data(cadddar_x))))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_AZA); 
		      annotate_arg(sc, cdddr(car_x));
		    }
		  else set_optimize_data(car_x, hop + OP_SAFE_C_AZZ); 
		}
	    }
	  else
	    {
	      if ((!is_pair(caddar_x)) ||
		  (is_all_x_op(optimize_data(caddar_x))))
		{
		  annotate_arg(sc, cddr(car_x));
		  if ((!is_pair(cadddar_x)) ||
		      (is_all_x_op(optimize_data(cadddar_x))))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_ZAA); 
		      annotate_arg(sc, cdddr(car_x));
		    }
		  else set_optimize_data(car_x, hop + OP_SAFE_C_ZAZ); 
		}
	      else
		{
		  if ((!is_pair(cadddar_x)) ||
		      (is_all_x_op(optimize_data(cadddar_x))))
		    {
		      set_optimize_data(car_x, hop + OP_SAFE_C_ZZA); 
		      annotate_arg(sc, cdddr(car_x));
		    }
		  else set_optimize_data(car_x, hop + OP_SAFE_C_ZZZ); 
		}
	    }
	}
      set_optimized(car_x);		  
      choose_c_function(sc, car_x, func, 3);
      set_arglist_length(car_x, small_int(3));
    }

  if ((pairs == 1) &&
      (bad_pairs == 1) &&
      (symbols == 2) &&
      (func_is_c_function) &&
      (func_is_safe) &&
      (is_pair(cadddar_x)))
    {
      set_optimized(car_x);
      set_unsafe(car_x);
      set_optimize_data(car_x, hop + OP_SAFE_C_SSP);
      choose_c_function(sc, car_x, func, 3);
      return(false);
    }

  /* bad pairs 1 here and others all_x_safe (i.e. safe_c_aap etc) in old/apa-s7.c --
   *   works, costs 140 lines of code, gains only about 40 in calls/502, 30 in lg, nothing elsewhere.
   */
  /* (define (hi) (catch #t (lambda () 1) (lambda args 2))) 
   *   first arg list must be (), second a symbol
   */
  if ((func_is_c_function) &&
      (c_function_call(func) == g_catch))
    {
      if (bad_pairs == 2)
	{
	  s7_pointer body_lambda, error_lambda;
	  body_lambda = caddar_x;
	  error_lambda = cadddar_x;
	  
	  if ((is_pair(body_lambda)) &&
	      (is_lambda(sc, car(body_lambda))) &&
	      (is_pair(error_lambda)) &&
	      (is_lambda(sc, car(error_lambda))) &&
	      (is_null(cadr(body_lambda))) &&
	      (is_not_null(cddr(body_lambda))) &&
	      (is_symbol(cadr(error_lambda))) &&
	      (!is_immutable(cadr(error_lambda))) &&
	      (is_not_null(cddr(error_lambda))))
	    {
	      s7_pointer error_result;
	      error_result = caddr(error_lambda);
	      set_unsafely_optimized(car_x);
	      if ((cadar_x == sc->T) &&
		  (is_null(cdddr(error_lambda))) &&
		  (!is_symbol(error_result)) &&
		  ((!is_pair(error_result)) || (car(error_result) == sc->QUOTE)))
		{
		  set_optimize_data(car_x, hop + OP_C_CATCH_ALL);
		  set_c_function(car_x, func);
		  if (is_pair(error_result))
		    set_fcdr(car_x, cadr(error_result));
		  else set_fcdr(car_x, error_result);
		  set_ecdr(cdr(car_x), cddr(body_lambda));
		}
	      else 
		{
		  set_optimize_data(car_x, hop + OP_C_CATCH);
		  choose_c_function(sc, car_x, func, 3);
		}
	      return(false);
	    }
	}
      else
	{
	  if ((bad_pairs == 1) &&
	      (is_symbol(caddar_x)))
	    {
	      s7_pointer error_lambda;
	      error_lambda = cadddar_x;
	      
	      if ((is_pair(error_lambda)) &&
		  (is_lambda(sc, car(error_lambda))) &&
		  (is_symbol(cadr(error_lambda))) &&
		  (!is_immutable(cadr(error_lambda))) &&
		  (is_not_null(cddr(error_lambda))))
		{
		  /* hop = 0; */
		  set_unsafely_optimized(car_x);
		  set_optimize_data(car_x, hop + OP_C_CATCH);
		  choose_c_function(sc, car_x, func, 3);
		  return(false);
		}
	    }
	}
    }

  if (bad_pairs > quotes) return(false);
  
  return(is_optimized(car_x));
}


static bool optimize_func_many_args(s7_scheme *sc, s7_pointer car_x, s7_pointer func, int hop, int args, int pairs, int symbols, int quotes, int bad_pairs)
{
  bool func_is_safe, func_is_c_function, func_is_closure;

  func_is_closure = is_closure(func);
  /*
  fprintf(stderr, "check %s: closure: %d, closure*: %d, bad: %d, q: %d, safe: %d\n", 
	  DISPLAY(car_x), func_is_closure, is_closure_star(func),
	  bad_pairs, quotes, func_is_safe);
  */
  if ((func_is_closure) &&
      (closure_arity_to_int(sc, func) != args))
    return(false);

  if ((is_closure_star(func)) &&
      ((!has_simple_args(closure_body(func))) ||
       (closure_star_arity_to_int(sc, func) < args) ||
       (arglist_has_keyword(cdr(car_x)))))
    {
      /*
      fprintf(stderr, "    not simple: %d, %d < %d, key: %d\n", 
	      has_simple_args(closure_body(func)), 
	      closure_star_arity_to_int(sc, func), args,
	      arglist_has_keyword(cdr(car_x)));
      */
      return(false);
    }

  if (bad_pairs > quotes) return(false);

  func_is_safe = is_safe_procedure(func);
  func_is_c_function = is_c_function(func);

  if (func_is_c_function)
    {
      if (func_is_safe)
	{
	  if (pairs == 0)
	    {
	      if (symbols == 0)
		{
		  set_optimized(car_x);
		  set_optimize_data(car_x, hop + OP_SAFE_C_C);
		  choose_c_function(sc, car_x, func, args);
		}
	      else
		{
		  if ((symbols == args) &&
		      (args < GC_TRIGGER_SIZE))
		    {
		      set_optimized(car_x);
		      set_optimize_data(car_x, hop + OP_SAFE_C_ALL_S);
		      if (args < NUM_SMALL_INTS)
			set_arglist_length(car_x, small_int(args));
		      else set_arglist_length(car_x, make_permanent_integer(args));
		      choose_c_function(sc, car_x, func, args);
		    }
		}
	    }
	}
    }
  else
    {
      if ((func_is_closure) &&
	  (pairs == 0) &&
	  ((symbols == args) || (symbols == 0)) &&
	  (args < GC_TRIGGER_SIZE))
	{
	  bool safe_case;
	  safe_case = is_safe_closure(func);
	  set_unsafely_optimized(car_x);
	  if (symbols == 0)
	    set_optimize_data(car_x, hop + ((safe_case) ? OP_SAFE_CLOSURE_ALL_C : OP_CLOSURE_ALL_C));
	  else set_optimize_data(car_x, hop + ((safe_case) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_X));
	  annotate_args(sc, cdr(car_x));
	  if (args < NUM_SMALL_INTS)
	    set_arglist_length(car_x, small_int(args));
	  else set_arglist_length(car_x, make_permanent_integer(args));
	  set_ecdr(car_x, func);
	      
	  if ((!safe_case) &&
	      (symbols == args) &&
	      (!arglist_has_accessed_symbol(closure_args(func))))
	    set_optimize_data(car_x, hop + OP_CLOSURE_ALL_S);
	  return(false);
	}
    }
  
  if ((func_is_c_function) &&
      (!func_is_safe) &&
      (!is_optimized(car_x)) &&
      (args < GC_TRIGGER_SIZE) &&
      (pairs == (quotes + all_x_count(car_x))))
    {
      set_unsafely_optimized(car_x);
      set_optimize_data(car_x, hop + OP_C_ALL_X);
      annotate_args(sc, cdr(car_x));
      if (args < NUM_SMALL_INTS)
	set_arglist_length(car_x, small_int(args));
      else set_arglist_length(car_x, make_permanent_integer(args));
      choose_c_function(sc, car_x, func, args);
      return(false); 
      /* else use all_x below */
    }
  
  if ((!is_optimized(car_x)) &&
      (args < GC_TRIGGER_SIZE))
    {
      if ((func_is_c_function) &&
	  (func_is_safe) &&
	  (pairs == (quotes + all_x_count(car_x))))
	{
	  set_optimized(car_x);
	  if (args == 4) 
	    set_optimize_data(car_x, hop + OP_SAFE_C_AAAA);
	  else set_optimize_data(car_x, hop + OP_SAFE_C_ALL_X);
	  annotate_args(sc, cdr(car_x));
	  if (args < NUM_SMALL_INTS)
	    set_arglist_length(car_x, small_int(args));
	  else set_arglist_length(car_x, make_permanent_integer(args));
	  choose_c_function(sc, car_x, func, args);
	}
      else
	{
	  /* 
	  fprintf(stderr, "    args: %d, p: %d, count: %d\n",
		  arglist_has_accessed_symbol(closure_args(func)),
		  pairs,
		  quotes + all_x_count(car_x));
	  */
	  if (((func_is_closure) ||
	       (is_closure_star(func))) && 
	      (!arglist_has_accessed_symbol(closure_args(func))) &&
	      (pairs == (quotes + all_x_count(car_x))))
	    {
	      set_unsafely_optimized(car_x);
	      if (func_is_closure)
		set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_X));
	      else set_optimize_data(car_x, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	      annotate_args(sc, cdr(car_x));
	      if (args < NUM_SMALL_INTS)
		set_arglist_length(car_x, small_int(args));
	      else set_arglist_length(car_x, make_permanent_integer(args));
	      set_ecdr(car_x, func);
	      return(false); 
	    }
	}
    }
  
  if ((!is_optimized(car_x)) &&
      (bad_pairs == 0) &&
      (func_is_c_function) &&
      (func_is_safe))
    {
      if ((args == 4) && (pairs == 4))
	{
	  set_optimized(car_x);
	  set_optimize_data(car_x, hop + OP_SAFE_C_ZZZZ);
	}
      choose_c_function(sc, car_x, func, args); /* don't assume hop_safe_c_c here -- let chooser set that */
    }

  return(is_optimized(car_x));
}


static bool optimize_function(s7_scheme *sc, s7_pointer x, s7_pointer func, int hop, s7_pointer e)
{
  int pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0, orig_hop;
  s7_pointer p;

  /* fprintf(stderr, "opt func %s %s %d %s\n", DISPLAY(func), DISPLAY_80(x), hop, DISPLAY(e)); */

  orig_hop = hop;

  if ((is_closure(func)) || /* can't depend on ecdr here because it might not be global, or might be redefined locally */
      (is_closure_star(func)))
    {
      /* (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
       */
      if ((!is_global(caar(x))) ||
	  (direct_memq(caar(x), e)))
	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 if we make a recursive call on a func, we've obviously already looked up that function, and
   *   if it has not been shadowed, then we don't need to check it -- so the hop but should be on
   *   for that one case.
   */

  for (p = cdar(x); is_pair(p); p = cdr(p), args++)
    {
      if (is_pair(car(p)))
	{
	  pairs++;
	  if (!is_checked(car(p)))
	    {
	      if (!optimize_expression(sc, p, orig_hop, e))
		{
		  bad_pairs++;
		  if ((caar(p) == sc->QUOTE) &&
		      (is_pair(cdar(p))) &&
		      (is_null(cddar(p))))
		    quotes++;
		}
	    }
	  else 
	    {
	      if ((!is_optimized(car(p))) ||
		  (is_unsafe(car(p))))
		{
		  bad_pairs++;
		  if ((caar(p) == sc->QUOTE) &&
		      (is_pair(cdar(p))) &&
		      (is_null(cddar(p))))
		    quotes++;
		}
	    }
	}
      else
	{
	  if (is_symbol(car(p)))
	    symbols++;
	}
    }

  if ((is_null(p)) &&                 /* if not null, dotted list of args? */
      (s7_is_aritable(sc, func, args)))  /* we have a legit call, at least syntactically */
    {
      switch (args)
	{
	case 0: 
	  return(optimize_thunk(sc, car(x), func, hop));
	  
	case 1:
	  return(optimize_func_one_arg(sc, car(x), func, hop, pairs, symbols, quotes, bad_pairs));

	case 2:
	  return(optimize_func_two_args(sc, car(x), func, hop, pairs, symbols, quotes, bad_pairs));

	case 3:
	  return(optimize_func_three_args(sc, car(x), func, hop, pairs, symbols, quotes, bad_pairs));

	default:
	  return(optimize_func_many_args(sc, car(x), func, hop, args, pairs, symbols, quotes, bad_pairs));
	}
    }
  return(false);
}


static s7_pointer check_for_global_set(s7_scheme *sc, s7_pointer tree, s7_pointer e)
{
  /* I think the main use of this is to check for set! of a built-in function that might
   *   otherwise be optimized as h_safe, but if that set happens in a loop, or perhaps call/cc,
   *   the second time through we should get the new value.  See gset-test in s7test.scm.
   */
  if (is_pair(tree))
    {
      if (is_checked_1(tree))
	return(e);
      set_checked_1(tree);
      if (car(tree) != sc->QUOTE)
	{
	  if ((car(tree) == sc->SET) &&
	      (is_pair(cdr(tree))) &&
	      (is_symbol(cadr(tree))) &&
	      (is_global(cadr(tree))))
	    return(cons(sc, cadr(tree), e));
	  
	  if (is_pair(car(tree)))
	    e = check_for_global_set(sc, car(tree), e);
	  if (is_pair(cdr(tree)))
	    return(check_for_global_set(sc, cdr(tree), e));
	}
    }
  return(e);
}


static bool optimize_syntax(s7_scheme *sc, s7_pointer x, s7_pointer func, int hop, s7_pointer e)
{
  s7_pointer p;
  opcode_t op;

  p = car(x);

  /* fprintf(stderr, "opt syntax %s\n     hop: %d, e: %s\n", DISPLAY(p), hop, DISPLAY(e)); */

  if (!is_pair(cdr(p))) /* cddr(p) might be null if, for example, (begin (let ...)) */
    return(false);

  op = (opcode_t)syntax_opcode(func);
  if (op == OP_QUOTE)
    return(false);

  sc->w = e;
  switch (op)
    {
    case OP_LET:
      if (is_symbol(cadr(p)))
	{
	  if (global_slot(cadr(p)) != sc->NIL)
	    sc->w = cons(sc, cadr(p), sc->w);
	  sc->w = collect_collisions(sc, caddr(p), sc->w);
	}
      else sc->w = collect_collisions(sc, cadr(p), sc->w);
      break;
      
    case OP_LET_STAR:
    case OP_LETREC:
      sc->w = collect_collisions(sc, cadr(p), sc->w);
      break;

    case OP_DEFINE:
    case OP_DEFINE_STAR:
    case OP_LAMBDA:
    case OP_LAMBDA_STAR:
      if (is_symbol(cadr(p))) /* (lambda args ...) */
	{
	  if (global_slot(cadr(p)) != sc->NIL)
	    sc->w = cons(sc, cadr(p), sc->w);
	}
      else sc->w = collect_collisions(sc, cadr(p), sc->w);

      if ((op == OP_DEFINE) &&
	  (is_pair(cadr(p))))
	sc->w = cons(sc, p, sc->w);
      break;

    case OP_SET:
      if ((is_symbol(cadr(p))) &&
	  (global_slot(cadr(p)) != sc->NIL))
	sc->w = cons(sc, cadr(p), sc->w);
      break;

    case OP_DO:
      sc->w = collect_collisions(sc, cadr(p), sc->w);
      break;

    case OP_WITH_ENV:
      if (sc->safety != 0)
	hop = 0;
      /* we can't trust anything here, so hop ought to be off.  For example,
       *
       *    (define (hi)
       *      (let ((e (augment-environment (current-environment)
       *                 (cons 'abs (lambda (a) (- a 1))))))
       *        (with-environment e (abs -1))))
       *
       * returns 1 if hop is 1, but -2 outside the function body.
       */
      break;

    default:
      break;
    }
  
  if (is_pair(cdar(x)))
    {
      bool happy = true;
      sc->w = check_for_global_set(sc, cdar(x), sc->w);

      for (p = cdar(x); is_pair(p); p = cdr(p))
	if ((is_pair(car(p))) &&
	    (!is_checked(car(p))))
	  optimize_expression(sc, p, hop, sc->w);
      
      if (symbol_id(caar(x)) == 0) 
	{
	  if ((op == OP_IF) || (op == OP_OR) || (op == OP_AND))
	    {
	      for (p = cdar(x); (happy) && (is_pair(p)); p = cdr(p))
		happy = is_all_x_safe(sc, car(p));

	      if ((happy) &&
		  (is_null(p)))    /* catch the syntax error later: (or #f . 2) etc */
		{
		  int args, symbols = 0, pairs = 0, rest = 0;
		  s7_pointer car_x, sym = NULL;
		  bool c_s_is_ok = true;

		  
		  car_x = car(x);

		  for (args = 0, p = cdar(x); is_pair(p); p = cdr(p), args++)
		    {
		      if (is_symbol(car(p)))
			symbols++;
		      else
			{
			  if (!is_pair(car(p)))
			    rest++;
			  else 
			    {
			      pairs++;
			      if ((c_s_is_ok) &&
				  ((!is_h_safe_c_s(car(p))) ||
				   ((sym) && (sym != cadar(p)))))
				c_s_is_ok = false;
			      else sym = cadar(p);
			    }
			}
		    }

		  if ((op == OP_IF) &&
		      ((args < 2) || (args > 3))) /* syntax error */
		    return(false); 

		  set_optimized(car_x);
		  set_optimize_data(car_x, hop + OP_SAFE_C_C);

		  if (pairs == 0)
		    {
		      if (op == OP_OR)
			set_c_function(car_x, or_direct);
		      else
			{
			  if (op == OP_AND)
			    set_c_function(car_x, and_direct);
			  else set_c_function(car_x, if_direct);
			}
		      return(true);
		    }

		  if ((pairs == args) && 
		      (c_s_is_ok)) 
		    {
		      if (op == OP_OR)
			set_c_function(car_x, or_s_direct);
		      else
			{
			  if (op == OP_AND)
			    set_c_function(car_x, and_s_direct);
			  else set_c_function(car_x, if_s_direct);
			}
		      return(true);
		    }

		  /* fprintf(stderr, "%s: %d -> %d %d %d\n", DISPLAY(car(x)), args, rest, symbols, pairs); */
		  for (p = cdar(x); is_pair(p); p = cdr(p))
		    set_fcdr(p, (s7_pointer)all_x_eval(sc, car(p)));
		  
		  if (op == OP_OR)
		    set_c_function(car_x, or_all_x);
		  else
		    {
		      if (op == OP_AND)
			set_c_function(car_x, and_all_x);
		      else 
			{
			  if ((fcdr(cddr(car_x)) == (s7_pointer)all_x_q) &&
			      (is_pair(cdddr(car_x))))
			    {
			      if (fcdr(cdddr(car_x)) == (s7_pointer)all_x_q)
				set_c_function(car_x, if_all_x_qq);
			      else set_c_function(car_x, if_all_x_qa);
			    }
			  else set_c_function(car_x, if_all_x);
			}
		      /* fprintf(stderr, "  -> %s\n", opt_name(car_x)); */
		    }
		  return(true);
		}
	    }
	}
    }
  return(false);
}


static s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer hdl, s7_pointer e)
{ 
  s7_pointer x;
  long long int id;

  if (direct_memq(hdl, e))
    return(sc->NIL);

  if (is_global(hdl))
    return(global_slot(hdl));

  id = symbol_id(hdl);
  for (x = sc->envir; id < environment_id(x); x = next_environment(x));
  for (; is_environment(x); x = next_environment(x))
    {
      s7_pointer y;
      if (environment_id(x) == id)
	return(local_slot(hdl));

      for (y = environment_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == hdl)
	  return(y);
    }
  return(sc->NIL);
} 


static bool optimize_expression(s7_scheme *sc, s7_pointer x, int hop, s7_pointer e)
{
  s7_pointer y, car_x;

  /* fprintf(stderr, "opt expr %s %d\n", DISPLAY_80(car(x)), hop); */

  car_x = car(x);
  set_checked(car_x);
  y = car(car_x);

  if (is_symbol(y))
    {
      s7_pointer func;
      
      if (is_syntactic(y))
	return(optimize_syntax(sc, x, slot_value(global_slot(y)), hop, e));

      if (y == sc->QUOTE)
	return(false);

      func = find_uncomplicated_symbol(sc, y, e);
      if (is_not_null(func))
	{
	  func = slot_value(func);
	  
	  if (is_syntactic(func))
	    return(optimize_syntax(sc, x, func, hop, e));
	  
	  /* we miss implicit indexing here because at this time, the data are not set */
	  
	  if ((is_procedure(func)) ||
	      (is_c_function(func)) ||
	      (is_safe_procedure(func))) /* built-in applicable objects like vectors */
	    return(optimize_function(sc, x, func, hop, e));
	}
      else func = sc->F;

      /* caar(x) is a symbol but it's not a known procedure or a "safe" case = vector etc */
      {
	/* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */
	s7_pointer p;
	int len = 0, pairs = 0, symbols = 0, quotes = 0;
	for (p = cdar(x); is_pair(p); p = cdr(p), len++)
	  {
	    if (is_pair(car(p)))
	      {
		pairs++;
		if ((hop != 0) && (caar(p) == sc->QUOTE))
		  quotes++;
		if (!is_checked(car(p)))
		  {
		    optimize_expression(sc, p, hop, e);
		  }
	      }
	    else
	      {
		if (is_symbol(car(p)))
		  symbols++;
	      }
	  }
	
	/* (define (hi) (let ((v (vector 1 2 3)) (i 1)) (v i)))
	 * (define (ho v) (let ((i 1)) (v i))) (ho (vector 1 2 3)) (ho (list 1 22 3))
	 */
	
#if 0	
	if ((hop == 0) &&
	    (direct_memq(y, e)))
	  hop = 1; /* ??? we're trying to catch things that are known at runtime at this point (they're in e) */
#endif

	if ((is_null(p)) &&              /* (+ 1 . 2) */
	    (!is_optimized(car_x)))
	  {
	    /* fprintf(stderr, "opt expr unknown %s %s %d\n", DISPLAY_80(car_x), DISPLAY(func), hop); */
	    /* len=0 case is almost entirely arglists */

	    if (pairs == 0)
	      {
		if (len == 0)
		  {
		    /* hoping to catch object application here, as in readers in Snd */
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN);
		    set_ecdr(car_x, NULL);
		    return(false);
		  }

		if (len == 1)
		  {
		    if (caar(x) != sc->QUOTE) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */
		      {
			set_unsafely_optimized(car_x);
			if (symbols == 1)
			  set_optimize_data(car_x, hop + OP_UNKNOWN_S);
			else set_optimize_data(car_x, hop + OP_UNKNOWN_C);
			set_ecdr(car_x, NULL);
			
			/* hooboy -- we get here in let bindings...
			 *
			 * to save access to the caller, we'd need to pass it as an arg to optimize_expression
			 */
		      }
		    return(false); 
		  }
		
		if (len == 2)
		  {
		    set_unsafely_optimized(car_x);
		    if (symbols == 2)
		      set_optimize_data(car_x, hop + OP_UNKNOWN_SS);
		    else
		      {
			if (symbols == 0)
			  set_optimize_data(car_x, hop + OP_UNKNOWN_CC);
			else
			  {
			    if (is_symbol(cadar(x)))
			      set_optimize_data(car_x, hop + OP_UNKNOWN_SC);
			    else set_optimize_data(car_x, hop + OP_UNKNOWN_CS);
			  }
		      }
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }
		
		if ((len == 3) &&
		    (symbols == 3))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_SSS);
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }

		if ((len > 3) &&
		    (len == symbols))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_ALL_S);
		    set_ecdr(car_x, NULL);
		    if (len < NUM_SMALL_INTS)
		      set_arglist_length(car_x, small_int(len));
		    else set_arglist_length(car_x, make_permanent_integer(len));
		    return(false); 
		  }
	      }
	    else /* pairs != 0 */
	      {
		s7_pointer cadar_x;
		cadar_x = cadar(x);
		/*
		  fprintf(stderr, "%s is unknown (%d %d %d %s)\n", DISPLAY_80(car_x), pairs, len, 
		  is_optimized(cadar_x), (is_optimized(cadar_x)) ? opt_names[optimize_data(cadar_x)] : "");
		*/
		if ((pairs == 1) &&
		    (len == 1) &&
		    (is_safe_c_s(cadar_x)))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_opSq);
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }
		
		if ((pairs == 1) &&
		    (len == 1) &&
		    (optimize_data_match(cadar_x, OP_SAFE_C_C)))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_opCq);
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }

		if ((pairs == 1) &&
		    (quotes == 1) &&
		    (len == 1))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_Q);
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }
		
		if ((pairs == 1) &&
		    (len == 2) &&
		    (symbols == 1))
		  {
		    if ((is_pair(cadar_x)) &&
			(is_safe_c_s(cadar_x)))
		      {
			set_unsafely_optimized(car_x);
			set_optimize_data(car_x, hop + OP_UNKNOWN_opSq_S);
			set_ecdr(car_x, NULL);
			return(false); 
		      }
		    if ((is_pair(caddar(x))) &&
			(is_safe_c_s(caddar(x))))
		      {
			set_unsafely_optimized(car_x);
			set_optimize_data(car_x, hop + OP_UNKNOWN_S_opSq);
			set_ecdr(car_x, NULL);
			return(false); 
		      }
		    if ((is_pair(caddar(x))) &&
			(is_optimized(caddar(x))) &&
			(op_no_hop(caddar(x)) == OP_SAFE_C_SS))
		      {
			set_unsafely_optimized(car_x);
			set_optimize_data(car_x, hop + OP_UNKNOWN_S_opSSq);
			set_ecdr(car_x, NULL);
			return(false); 
		      }
		    
		    if ((is_pair(cadar_x)) &&
			(is_optimized(cadar_x)) &&
			(op_no_hop(cadar_x) == OP_SAFE_C_SS))
		      {
			set_unsafely_optimized(car_x);
			set_optimize_data(car_x, hop + OP_UNKNOWN_opSSq_S);
			set_ecdr(car_x, NULL);
			return(false); 
		      }
		  }
		if ((pairs == 2) &&
		    (len == 2) &&
		    (is_safe_c_s(cadar_x)) &&
		    (is_safe_c_s(caddar(x))))
		  {
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_opSq_opSq);
		    set_ecdr(car_x, NULL);
		    return(false); 
		  }

		if ((len < GC_TRIGGER_SIZE) &&
		    (pairs == (quotes + all_x_count(car_x))))
		  {
		    /* fprintf(stderr, "all_x: %s\n", DISPLAY(car_x)); */
		    set_unsafely_optimized(car_x);
		    set_optimize_data(car_x, hop + OP_UNKNOWN_ALL_X);
		    set_ecdr(car_x, NULL);
		    if (len < NUM_SMALL_INTS)
		      set_arglist_length(car_x, small_int(len));
		    else set_arglist_length(car_x, make_permanent_integer(len));
		    return(false); 
		  }

	      }
	  }
      }
    }
  else
    {
      /* caar(x) is not a symbol, but there might be interesting stuff here */
      /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */

      s7_pointer p;
      for (p = car_x; is_pair(p); p = cdr(p))
	{
	  if (is_pair(car(p)))
	    {
	      if (!is_checked(car(p)))
		{
		  optimize_expression(sc, p, hop, e);
		}
	    }
	}
    }
  return(false);
}


static bool optimize(s7_scheme *sc, s7_pointer code, int hop, s7_pointer e)
{
  s7_pointer x;
  bool happy = true;
  /* fprintf(stderr, "optimize %s %d\n", DISPLAY_80(code), hop); */
  for (x = code; is_pair(x) && (!is_checked(x)); x = cdr(x))
    {
      set_checked(x);
      if (is_pair(car(x)))
	{
	  if (!optimize_expression(sc, x, hop, e))
	    happy = false;
	}
    }
  if ((!is_null(x)) &&
      (!is_pair(x)))
    {
      eval_error(sc, "stray dot in function body: ~S", code);
      return(false);
    }
  return(happy);
}


#define indirect_c_function_is_ok(Sc, X) (((optimize_data(X) & 0x1) != 0) || (c_function_is_ok(Sc, X)))

static bool is_hop_safe_closure(s7_pointer p)
{
  int op;
  op = optimize_data(p);
  return(((op & 1) == 1) &&
	 (op >= HOP_SAFE_THUNK) &&
	 (op < OP_SAFE_CLOSURE_STAR_S));
}

static bool tree_match(s7_scheme *sc, s7_pointer tree)
{
  if (is_null(tree))
    return(false);
  if (is_symbol(tree))
    return(is_matched(tree));
  if (is_pair(tree))
    return((tree_match(sc, car(tree))) ||
	   (tree_match(sc, cdr(tree))));
  return(false);
}

static bool arg_match(s7_scheme *sc, s7_pointer expr, s7_pointer args)
{
  s7_pointer p;
  bool unhappy = false;

  for (p = args; is_pair(p); p = cdr(p))
    if (is_pair(car(p)))
      set_matched(caar(p));
    else set_matched(car(p));
  if (!is_null(p))
    set_matched(p);

  unhappy = tree_match(sc, expr);
  for (p = args; is_pair(p); p = cdr(p))
    if (is_pair(car(p)))
      clear_matched(caar(p));
    else clear_matched(car(p));
  if (!is_null(p))
    clear_matched(p);
  return(unhappy);
}


static bool form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer args, s7_pointer x, bool at_end, bool *bad_set)
{
  /* called only from body_is_safe */
  sc->cycle_counter++;
  if ((!is_proper_list(sc, x)) ||
      (sc->cycle_counter > 5000))
    return(false);
  if (is_syntactic(car(x)))
    {
      switch (syntax_opcode(car(x)))
	{
	case OP_OR:
	case OP_AND:
	case OP_BEGIN:
	case OP_WITH_BAFFLE:
	  if (!body_is_safe(sc, func, args, cdr(x), at_end, bad_set))
	    return(false);
	  break;
	  
	case OP_QUOTE:
	  break;
	  
	  /* 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:
	  if (is_symbol(cadr(x)))
	    {
	      s7_pointer vars, p;
	      if ((!is_pair(cddr(x))) ||
		  (!is_pair(cdddr(x)))) /* (let asdf) or possibly (let asdf ()) */
		return(false);
	      for (vars = caddr(x); is_pair(vars); vars = cdr(vars))
		{
		  if ((caar(vars) == func) ||
		      (caar(vars) == cadr(x)))
		    return(false); /* it's shadowed -- all bets are off! */
		}
	      
	      for (p = cdddr(x); is_not_null(p); p = cdr(p)); /* body might be empty: (define (f x) (let asd ())) */
	      if (is_pair(car(p)))
		{
		  /* what is going on here!?!? */
		  form_is_safe(sc, cadr(x), args, car(p), true, bad_set);
		  if ((at_end) && (!*bad_set))
		    form_is_safe(sc, func, args, car(p), true, bad_set);
		}
	      return(false);
	    }
	  /* fall through */
	  
	case OP_LETREC:
	  {
	    bool happy = true;
	    if (is_pair(cadr(x)))
	      {
		s7_pointer vars;
		for (vars = cadr(x); is_pair(vars); vars = cdr(vars))
		  {
		    if ((!is_pair(car(vars))) ||
			(!is_pair(cdar(vars))))
		      return(false);
		    
		    if ((is_pair(cadar(vars))) &&
			(!form_is_safe(sc, func, args, cadar(vars), false, bad_set)))
		      happy = false;
		    
		    if (caar(vars) == func)
		      return(false); /* it's shadowed */
		  }
	      }
	    if ((!body_is_safe(sc, func, args, cddr(x), at_end, bad_set)) ||
		(!happy))
	      return(false);
	  }
	  break;
	  
	case OP_IF:
	  {
	    bool t, e1, e2;
	    if (!is_pair(cdr(x))) return(false); /* (if) ! */
	    t = ((!is_pair(cadr(x))) || (form_is_safe(sc, func, args, cadr(x), false, bad_set)));
	    e1 = ((!is_pair(caddr(x))) || (form_is_safe(sc, func, args, caddr(x), at_end, bad_set)));
	    e2 = ((!is_pair(cdddr(x))) || (!is_pair(cadddr(x))) || (form_is_safe(sc, func, args, cadddr(x), at_end, bad_set)));
	    return((t) && (e1) && (e2));
	  }
	  break;
	  
	case OP_COND:
	  {
	    s7_pointer p;
	    bool happy = true;
	    for (p = cdr(x); is_pair(p); p = cdr(p))
	      {
		s7_pointer expr;
		expr = car(p);
		if (is_pair(expr)) /* ?? */
		  {
		    if ((is_pair(car(expr))) && (!form_is_safe(sc, func, args, car(expr), false, bad_set)))
		      {
		      happy = false;
		      /* fprintf(stderr, "test %s is not safe\n", DISPLAY(car(expr))); */
		      }
		    if ((is_pair(cdr(expr))) && (!body_is_safe(sc, func, args, cdr(expr), at_end, bad_set)))
		      {
		      happy = false;
		      /* fprintf(stderr, "clause %s is not safe (%d %s)\n", DISPLAY(cdr(expr)), at_end, DISPLAY(func)); */
		      }
		  }
	      }
	    if ((!happy) || (is_not_null(p)))
	      return(false);
	  }
	  break;
	  
	case OP_CASE:
	  {
	    s7_pointer p;
	    bool happy = true;
	    if ((is_pair(cadr(x))) && (!form_is_safe(sc, func, args, cadr(x), false, bad_set))) return(false);
	    for (p = cddr(x); is_pair(p); p = cdr(p))
	      {
		if ((is_pair(car(p))) && (!body_is_safe(sc, func, args, cdar(p), at_end, bad_set)))
		  happy = false;
	      }
	    return(happy);
	  }
	  break;
	  
	case OP_DO:
	  set_safe_do_level(sc, 0); /* someday figure out how to minimize this ridiculous thing */

	  /* (do (...) (...) ...) */
	  if (!is_pair(cddr(x)))
	    return(false);
	  if (!body_is_safe(sc, func, args, cdddr(x), false, bad_set))
	    return(false);
	  if (is_pair(cadr(x)))
	    {
	      s7_pointer vars;
	      for (vars = cadr(x); is_pair(vars); vars = cdr(vars))
		{
		  if (!is_pair(car(vars)))
		    return(false);
		  
		  if (caar(vars) == func)
		    return(false);
		  
		  if ((is_pair(cadar(vars))) &&
		      (!form_is_safe(sc, func, args, cadar(vars), false, bad_set)))
		    return(false);

		  if ((is_pair(cddar(vars))) &&
		      (is_pair(caddar(vars))) &&
		      (!form_is_safe(sc, func, args, caddar(vars), false, bad_set)))
		    return(false);
		}
	    }
	  if ((is_pair(caddr(x))) &&
	      (!body_is_safe(sc, func, args, caddr(x), at_end, bad_set)))
	    return(false);
	  break;
	  
	case OP_SET:
	  /* if we set func, we have to make sure we 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(cdr(x))) return(false); /* (set!) ! */
	  if (cadr(x) == func)
	    (*bad_set) = true;
	  
	  /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */
	  /* an experiment */
	  if (is_symbol(caddr(x)))
	    return(false);

	  if (((s7_is_constant(caddr(x))) ||
	       (form_is_safe(sc, func, args, caddr(x), false, bad_set))) &&
	      (((is_pair(cadr(x))) &&
		(form_is_safe(sc, func, args, cadr(x), false, bad_set))) ||
	       ((is_symbol(cadr(x))) &&
		(!arg_match(sc, x, args)))))
	    return(true);
	  return(false);


	case OP_WITH_ENV:
	  if (is_pair(cadr(x)))
	    return(false);

	  /* here args aren't imported, nor is func -- with-environment sets up a sealed evaluation!
	   */
	  if (!body_is_safe(sc, sc->F, sc->NIL, cddr(x), at_end, bad_set))
	    return(false);
	  break;


	  /* op_define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current env,
	   *   but in a safe func, that's a constant.  See s7test L 1865 for an example.
	   */
	default:
	  /* 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))
	   */
	  
	  if ((is_pair(cdr(x))) &&
	      ((cadr(x) == func) ||
	       ((is_pair(cadr(x))) && (caadr(x) == func))))
	    (*bad_set) = true;
	  return(false);
	}
    }
  else /* car(x) is not syntactic */
    {
      /* fprintf(stderr, "%s %d %d %d\n", DISPLAY(x), is_optimized(x), is_unsafe(x), is_hop_safe_closure(x)); */
      if ((!is_optimized(x)) || 
	  ((is_unsafe(x)) &&
	   (!is_hop_safe_closure(x))))
	{
	  if (car(x) == func) /* try to catch tail call */
	    {
	      s7_pointer p;
	      /* fprintf(stderr, "%s car(x) is func\n", DISPLAY(x)); */

	      for (p = cdr(x); is_pair(p); p = cdr(p))
		if ((is_pair(car(p))) &&
		    (((!is_optimized(car(p))) &&
		      (caar(p) != sc->QUOTE)) ||
		     (is_unsafe(car(p))) ||
		     (caar(p) == func)))  /* ?? not sure about this */
		  {
		    /* fprintf(stderr, "%s false %d %d %d\n", DISPLAY(p), is_optimized(car(p)), is_unsafe(car(p)), caar(p) == func); */
		  return(false);
		  }
	      
	      /* fprintf(stderr, "%d %d %d\n", at_end, is_null(p), *bad_set); */
	      if ((at_end) && (is_null(p) && (!*bad_set)))
		{
		  /* we still miss a few cases, and need more unknown optimizations, or set them here
		   *   (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) 2)
		   */
		  return(true);
		}
	      return(false);
	    }
	  
	  if (is_symbol(car(x)))
	    {
	      if (is_global(car(x)))
		{
		  s7_pointer f;
		  f = finder(sc, car(x));
		  if (((is_c_function(f)) &&
		       ((is_safe_procedure(f)) ||
			((is_null(cdddr(x))) &&
			 ((c_function_call(f) == g_member) || (c_function_call(f) == g_assoc))))) ||
		      ((is_closure(f)) &&
		       (is_safe_closure(f))))
		    {
		      s7_pointer p;
		      for (p = cdr(x); is_pair(p); p = cdr(p))
			if ((is_pair(car(p))) &&
			    ((!is_optimized(car(p))) ||
			     ((is_unsafe(car(p))) &&
			      (!is_hop_safe_closure(car(p))))))
			  {
			    if ((caar(p) != func) ||
				(!is_null(cdr(p))))
			      return(false);
			  }
		      if (!is_null(p))
			return(false);
		    }
		}
	      else
		{
		  s7_pointer f;
		  f = find_symbol(sc, car(x));
		  if (is_slot(f))
		    {
		      if ((is_syntax(slot_value(f))) || (is_any_macro(slot_value(f))))
			(*bad_set) = true;
		      else
			{
			  if ((is_closure(slot_value(f))) &&
			      (is_safe_closure(slot_value(f))))
			    return(true);
			}
		    }
		}
	    }
	  return(false);
	}
    }
  return(true);
}


static bool body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer args, s7_pointer body, bool at_end, bool *bad_set)
{
  /* called in optimize_lambda */
  s7_pointer p;

  sc->cycle_counter++;
  if (sc->cycle_counter > 5000)
    return(false);
  for (p = body; is_pair(p); p = cdr(p))
    {
      if ((is_pair(car(p))) &&
	  (!form_is_safe(sc, func, args, car(p), (at_end) && (is_null(cdr(p))), bad_set)))
	{
	  if ((at_end) && (is_pair(cdr(p))) && (!*bad_set))
	    {
	      /* we checked in check_define that this is not a circular list, but dotted? */
	      for (p = cdr(p); is_pair(cdr(p)); p = cdr(p));
	      if ((is_pair(p)) && (is_pair(car(p))))
		form_is_safe(sc, func, args, car(p), at_end, bad_set);
	    }
	  return(false);
	}
    }
  return(is_null(p));
}


s7_pointer s7_unoptimize(s7_scheme *sc, s7_pointer code)
{
  if (is_pair(code))
    {
      if ((is_syntax(car(code))) &&                           /* (typeflag(car(code)) == SYNTACTIC_TYPE) && */
	  (is_internal_syntax_op(syntax_opcode(car(code)))))
	car(code) = car(slot_value(global_slot(car(code))));
      else s7_unoptimize(sc, car(code));
      s7_unoptimize(sc, cdr(code));
    }
  return(code);
}


static s7_pointer tree_copy(s7_scheme *sc, s7_pointer tree)
{
  /* copy entire tree, but use s7_copy for any non-pairs
   */
  s7_pointer x;
  if (!is_pair(tree))
    x = s7_copy(sc, tree);
  else
    {
      x = cons(sc, 
	       tree_copy(sc, car(tree)),
	       tree_copy(sc, cdr(tree)));
      set_ecdr(x, NULL);
      set_fcdr(x, NULL);
      set_gcdr(x, NULL);
    }
  /* fprintf(stderr, "copy %p -> %p (%s %p %p)\n", tree, x, type_name(sc, tree, NO_ARTICLE), fcdr(tree), fcdr(x)); */
  return(x);
}

static s7_pointer g_unoptimize(s7_scheme *sc, s7_pointer args)
{
  #define H_unoptimize "(unoptimize code) erases some of the optimizer info in code"
  s7_pointer code;
  code = car(args);

  if (make_shared_info(sc, code) != NULL)                      /* if not null, we found a cycle */
    return(wrong_type_argument_with_type(sc, sc->UNOPTIMIZE, small_int(1), code, A_PROPER_LIST));

  return(s7_unoptimize(sc, tree_copy(sc, code)));
}




/* ---------------------------------------- error checks ---------------------------------------- */

static s7_pointer check_lambda_args(s7_scheme *sc, s7_pointer args, int *arity)
{
  s7_pointer x;
  int i;

  if ((!is_pair(args)) && (!is_null(args)))
    {
      if (s7_is_constant(args))                       /* (lambda :a ...) */
	return(eval_error(sc, "lambda parameter '~S is a constant", args)); /* not ~A here, (lambda #\null do) for example */
      
      /* 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(sc->F);
    }

  for (i = 0, x = args; is_pair(x); i++, x = cdr(x))
    {
      if (s7_is_constant(car(x)))                       /* (lambda (pi) pi), constant here means not a symbol */
	{
	  if (is_pair(car(x)))                          /* (lambda ((:hi . "hi") . "hi") 1) */
	    return(eval_error(sc, "lambda parameter '~S is a pair (perhaps you want define* or lambda*?)", car(x)));
	  return(eval_error(sc, "lambda parameter '~S is a constant", car(x)));
	}
      if (symbol_is_in_arg_list(car(x), cdr(x)))       /* (lambda (a a) ...) or (lambda (a . a) ...) */
	return(eval_error(sc, "lambda parameter '~S is used twice in the parameter list", car(x)));
      set_local(car(x));
    }
  if (is_not_null(x))
    {
      if (s7_is_constant(x))                             /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */
	return(eval_error(sc, "lambda :rest parameter '~S is a constant", x));
      i = -i - 1;
    }

  if (arity) (*arity) = i;
  return(sc->F);
}


static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int *arity)
{
  s7_pointer top, v, w;
  int i;

  if (!s7_is_list(sc, args))
    {
      if (s7_is_constant(args))                                  /* (lambda* :a ...) */
	return(eval_error(sc, "lambda* parameter '~S is a constant", args));
      if (is_symbol(args))
	set_local(args);
      if (arity) (*arity) = -1;
      return(args);
    }

  top = args;
  v = args;
  for (i = 0, w = args; is_pair(w); i++, v = w, w = cdr(w))
    {
      if (is_pair(car(w)))
	{
	  if (s7_is_constant(caar(w)))                            /* (lambda* ((:a 1)) ...) */
	    return(eval_error_with_string(sc, CONSTANT_ARG_ERROR, caar(w)));
	  if (symbol_is_in_arg_list(caar(w), cdr(w)))             /* (lambda* ((a 1) a) ...) */
	    return(eval_error(sc, "lambda* parameter '~A is used twice in the argument list", caar(w)));
	  
	  if (!is_pair(cdar(w)))                                  /* (lambda* ((a . 0.0)) a) */
	    {
	      if (is_null(cdar(w)))                               /* (lambda* ((a)) ...) */
		return(eval_error(sc, "lambda* parameter default value missing? '~A", car(w)));
	      return(eval_error(sc, "lambda* parameter is a dotted pair? '~A", car(w)));
	    }
	  
	  if (is_not_null(cddar(w)))                              /* (lambda* ((a 0.0 'hi)) a) */
	    return(eval_error(sc, "lambda* parameter has multiple default values? '~A", car(w)));
	  
	  set_local(caar(w));
	}
      else 
	{
	  if (car(w) != sc->KEY_REST)
	    {
	      if (s7_is_constant(car(w)))
		{
		  if ((car(w) == sc->KEY_KEY) || 
		      (car(w) == sc->KEY_OPTIONAL))
		    {
		      if ((!is_pair(cdr(w))) ||                   /* (lambda* (:key) 1) or (lambda* (:key . b) 1) */
			  (is_immutable(cadr(w))))                /* (lambda* (:key :optional) 1) */
			return(eval_error(sc, "lambda* :key or :optional parameter must be a normal symbol: ~A", w));
		      if (w == top) 
			top = cdr(w);
		      else cdr(v) = cdr(w);
		    }
		  else
		    {
		      if (car(w) == sc->KEY_ALLOW_OTHER_KEYS)
			{
			  if (is_not_null(cdr(w)))                /* (lambda* (:allow-other-keys x) x) */
			    eval_error(sc, ":allow-other-keys should be the last parameter: ~A", args);
			}
		      else                                        /* (lambda* (pi) ...) */
			return(eval_error_with_string(sc, CONSTANT_ARG_ERROR, car(w)));
		    }
		}
	      if (symbol_is_in_arg_list(car(w), cdr(w)))          /* (lambda* (a a) ...) or (lambda* (a . a) ...) */
		return(eval_error(sc, "lambda* parameter '~A is used twice in the argument list", car(w)));
	      
	      if (!is_keyword(car(w))) set_local(car(w));
	    }
	  else
	    {
	      if (!is_pair(cdr(w)))                               /* (lambda* (:rest) ...) */
		return(eval_error(sc, "lambda* :rest parameter missing? ~A", w));
	      if (!is_symbol(cadr(w)))                         /* (lambda* (:rest (a 1)) ...) */
		{
		  if (!is_pair(cadr(w)))                          /* (lambda* (:rest 1) ...) */
		    return(eval_error(sc, "lambda* :rest parameter is not a symbol? ~A", w));
		  return(eval_error(sc, "lambda* :rest parameter can't have a default value. ~A", w));
		}
	      else
		{
		  if (is_immutable(cadr(w)))
		    return(s7_error(sc, sc->WRONG_TYPE_ARG,
				    list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), w)));
		}
	      set_local(cadr(w));
	    }
	}
    }
  if (is_not_null(w))
    {
      if (s7_is_constant(w))                             /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */
	return(eval_error(sc, "lambda* :rest parameter '~A is a constant", w));
      if (is_symbol(w))
	set_local(w);
      i = -1;
    }

  if (arity) (*arity) = i;
  return(top);
}


static s7_pointer check_case(s7_scheme *sc)
{
  bool keys_simple = true, has_else = false, has_feed_to = false, keys_single = true, bodies_simple = true, bodies_simplest = true;
  s7_pointer x, y;

  /* (let () (define (hi a) (case a ((0) (+ a 1)) ((1 2) a))) (define (ho) (hi 1)) (ho))
   */

  if (!is_pair(sc->code))                                            /* (case) or (case . 1) */
    return(eval_error(sc, "case has no selector:  ~A", sc->code));
  if (!is_pair(cdr(sc->code)))                                       /* (case 1) or (case 1 . 1) */
    return(eval_error(sc, "case has no clauses?:  ~A", sc->code));
  if (!is_pair(cadr(sc->code)))                                      /* (case 1 1) */
    return(eval_error(sc, "case clause is not a list? ~A", sc->code));
  
  for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
    {
      if ((!is_pair(x)) ||                                        /* (case 1 ((2) 1) . 1) */
	  (!is_pair(car(x))))
	return(eval_error(sc, "case clause ~A messed up", x));	 
      if (!is_pair(cdar(x)))                                      /* (case 1 ((1))) */
	return(eval_error(sc, "case clause result missing: ~A", car(x)));

      if ((bodies_simple) && (!is_null(cddar(x))))
	{
	  /* fprintf(stderr, "not ok: %s\n", DISPLAY(cdar(x))); */
	  bodies_simple = false;
	  bodies_simplest = false;
	}
      if (bodies_simplest)
	{
	  if ((is_pair(cadar(x))) &&
	      (caadar(x) != sc->QUOTE))
	    {
	      if (is_pair(caar(x)))
		bodies_simplest = false;
	      else
		{
		  if ((caar(x) != sc->ELSE) &&
		      ((!is_symbol(caar(x))) ||
		       (s7_symbol_value(sc, caar(x)) != sc->ELSE)))
		    bodies_simplest = false;
		}
	    }
	}
      
      y = caar(x);
      if (!is_pair(y))
	{
	  if ((y != sc->ELSE) &&                                  /* (case 1 (2 1)) */
	      ((!is_symbol(y)) ||
	       (s7_symbol_value(sc, y) != sc->ELSE)))             /* "proper list" below because: (case 1 (() 2) ... */
	    return(eval_error(sc, "case clause key list ~A is not a proper list or 'else'", y));
	  if (is_not_null(cdr(x)))                                  /* (case 1 (else 1) ((2) 1)) */
	    return(eval_error(sc, "case 'else' clause, ~A, is not the last clause", x));
	  has_else = true;
	}
      else
	{
	  /* what about (case 1 ((1) #t) ((1) #f)) [this is ok by guile]
	   *            (case 1 ((1) #t) ())
	   *            (case 1 ((2 2 2) 1)): guile says #<unspecified>
	   */
	  
	  /* the selector (sc->value) is evaluated, but the search key is not
	   *    (case '2 ((2) 3) (else 1)) -> 3
	   *    (case '2 (('2) 3) (else 1)) -> 1
	   */
	  if (!is_simple(car(y)))
	    keys_simple = false;
	  if (!is_null(cdr(y)))
	    keys_single = false;

	  for (y = cdr(y); is_not_null(y); y = cdr(y)) 
	    {
	      if (!is_pair(y))                                        /* (case () ((1 . 2) . hi) . hi) */
		return(eval_error(sc, "case key list is improper? ~A", x));
	      if (!is_simple(car(y)))
		keys_simple = false;
	    }
	}

      y = car(x);
      if ((cadr(y) == sc->FEED_TO) &&
	  (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
	{
	  has_feed_to = true;
	  if (!is_pair(cddr(y)))                                  /* (case 1 (else =>)) */
	    return(eval_error(sc, "case: '=>' target missing?  ~A", y));
	  if (is_pair(cdddr(y)))                                  /* (case 1 (else => + - *)) */
	    return(eval_error(sc, "case: '=>' has too many targets: ~A", y));
	}
    }

#if 0
  if ((!has_feed_to) &&
      (bodies_simple))
    {
      bool happy = true;
      for (x = cdr(sc->code); (happy) && is_not_null(x); x = cdr(x))
	happy = is_all_x_safe(sc, cadar(x));
      if (happy)
	fprintf(stderr, "case_direct: %s\n", DISPLAY_80(sc->code));
    }
#endif

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
	{
	  set_fcdr(x, caar(x));
	  if (is_pair(fcdr(x))) set_ecdr(x, cadar(x));
	}
      set_syntax_op(sc->code, sc->CASE_UNCHECKED);

      if ((!has_feed_to) &&
	  (keys_simple))
	{
	  if (has_else) /* don't combine ifs ! */
	    {
	      if (is_symbol(car(sc->code)))
		{
		  if (bodies_simple)
		    {
		      if (keys_single)
			{
			  if (bodies_simplest)
			    set_syntax_op(sc->code, sc->CASE_SIMPLEST_ELSE_C);
			  else set_syntax_op(sc->code, sc->CASE_SIMPLEST_ELSE);
			  for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
			    {
			      if (is_pair(caar(x)))
				{
				  set_fcdr(x, caaar(x));
				  /* ecdr(x) = cadar(x); */
				}
			      else 
				{
				  set_fcdr(x, sc->ELSE);
				  set_gcdr(sc->code, cadar(x)); 
				}
			    }
			}
		      else set_syntax_op(sc->code, sc->CASE_SIMPLE);
		    }
		  else set_syntax_op(sc->code, sc->CASE_SIMPLE);
		}
	    }
	  else 
	    {
	      if (keys_single)
		{
		  if ((bodies_simple) &&
		      (is_symbol(car(sc->code))))
		    set_syntax_op(sc->code, sc->CASE_SIMPLEST);
		  else 
		    {
		      if ((is_pair(car(sc->code))) &&
			  (is_optimized(car(sc->code))) &&
			  (optimize_data(car(sc->code)) == HOP_SAFE_C_SS))
			set_syntax_op(sc->code, sc->CASE_SIMPLEST_SS);
		    }
		  for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
		    set_fcdr(x, caaar(x));
		}
	      else 
		{
		  if (bodies_simple)
		    {
		      if (is_symbol(car(sc->code)))
			set_syntax_op(sc->code, sc->CASE_SIMPLER_1); 
		      else
			{
			  if ((is_pair(car(sc->code))) &&
			      (is_optimized(car(sc->code))) &&
			      (optimize_data(car(sc->code)) == HOP_SAFE_C_SS))
			    set_syntax_op(sc->code, sc->CASE_SIMPLER_SS);
			}
		    }
		  else 
		    {
		      if (is_symbol(car(sc->code)))
			set_syntax_op(sc->code, sc->CASE_SIMPLER); 
		    }
		}
	    }
	}
    }

  return(sc->code);
}


static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer x, s7_pointer args, s7_pointer body);

static s7_pointer check_let(s7_scheme *sc)
{
  s7_pointer x;
  bool named_let;
  int vars;

  if (!is_pair(sc->code))               /* (let . 1) */
    {
      if (is_null(sc->code))            /* (let) */
	return(eval_error(sc, "let has no variables or body: ~A", sc->code));
      return(eval_error(sc, "let form is an improper list? ~A", sc->code));
    }
  
  if (!is_pair(cdr(sc->code)))          /* (let () ) */
    return(eval_error(sc, "let has no body: ~A", sc->code));

  if ((!s7_is_list(sc, car(sc->code))) && /* (let 1 ...) */
      (!is_symbol(car(sc->code))))
    return(eval_error(sc, "let variable list is messed up or missing: ~A", sc->code));
  
  /* we accept these (other schemes complain, but I can't see why -- a no-op is the user's business!):
   *   (let () (define (hi) (+ 1 2)))
   *   (let () (begin (define x 3)))
   *   (let () 3 (begin (define x 3)))
   *   (let () (define x 3))
   *   (let () (if #t (define (x) 3)))
   *
   * similar cases:
   *   (case 0 ((0) (define (x) 3) (x)))
   *   (cond (0 (define (x) 3) (x)))
   *   (and (define (x) x) 1)
   *   (begin (define (x y) y) (x (define (x y) y)))
   *   (if (define (x) 1) 2 3)
   *   (do () ((define (x) 1) (define (y) 2)))
   *
   * but we can get some humorous results: 
   *   (let ((x (lambda () 3))) (if (define (x) 4) (x) 0)) -> 4
   */
  
  named_let = (is_symbol(car(sc->code)));

  if (named_let)
    {
      if (!s7_is_list(sc, cadr(sc->code)))      /* (let hi #t) */
	return(eval_error(sc, "let variable list is messed up: ~A", sc->code));
      if (is_null(cddr(sc->code)))              /* (let hi () ) */
	return(eval_error(sc, "named let has no body: ~A", sc->code));
      if (is_immutable(car(sc->code)))
	return(s7_error(sc, sc->WRONG_TYPE_ARG,
			list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), sc->code)));
      set_local(car(sc->code));
    }
  
  for (vars = 0, x = ((named_let) ? cadr(sc->code) : car(sc->code)); is_pair(x); vars++, x = cdr(x))
    {
      s7_pointer y, carx;
      
      carx = car(x);
      
      if (!is_pair(carx))                /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */
	return(eval_error(sc, "let variable declaration, but no value?: ~A", x));
      
      if (!(is_pair(cdr(carx))))         /* (let ((x . 1))...) */
	return(eval_error(sc, "let variable declaration is not a proper list?: ~A", x));
      
      if (is_not_null(cddr(carx)))       /* (let ((x 1 2 3)) ...) */
	return(eval_error(sc, "let variable declaration has more than one value?: ~A", x));
      
      /* currently if the extra value involves a read error, we get a kind of panicky-looking message:
       *   (let ((x . 2 . 3)) x)
       *   ;let variable declaration has more than one value?: (x error error "stray dot?: ...  ((x . 2 . 3)) x) ..")
       */
      
      if (!(is_symbol(car(carx))))
	return(eval_error(sc, "bad variable ~S in let", carx));
      
      if (is_immutable(car(carx)))
	return(s7_error(sc, sc->WRONG_TYPE_ARG,
			list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), x)));

      /* check for name collisions -- not sure this is required by Scheme */
      for (y = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); y != x; y = cdr(y))
	if (car(carx) == caar(y))
	  return(eval_error(sc, "duplicate identifier in let: ~A", carx));

      set_local(car(carx));
    }
  
  /* we accept (let ((:hi 1)) :hi)
   *           (let ('1) quote) [guile accepts this]
   */
  
  if (is_not_null(x))                  /* (let* ((a 1) . b) a) */
    return(eval_error(sc, "let var list improper?: ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (named_let)
	{
	  s7_pointer x;

	  if (is_null(cadr(sc->code)))
	    set_syntax_op(sc->code, sc->NAMED_LET_NO_VARS);
	  else set_syntax_op(sc->code, sc->NAMED_LET);

	  /* this is (let name ...) so  the initial values need to be removed from the closure arg list */
	  sc->args = sc->NIL; /* sc->args is set to nil in named_let below */
	  for (x = cadr(sc->code); is_pair(x); x = cdr(x)) 
	    sc->args = cons(sc, caar(x), sc->args);
	  optimize_lambda(sc, true, car(sc->code), safe_reverse_in_place(sc, sc->args), cddr(sc->code));

	  /* apparently these guys are almost never safe */
	  return(sc->code);
	}

      if (is_null(car(sc->code)))
	set_syntax_op(sc->code, sc->LET_NO_VARS);
      else 
	{
	  if (is_null(cdar(sc->code))) /* one binding */
	    {
	      s7_pointer binding;
	      binding = caar(sc->code);
	      if (symbol_has_accessor(car(binding)))
		set_syntax_op(sc->code, sc->LET_UNCHECKED);
	      else
		{
		  if (is_pair(cadr(binding)))
		    {
		      if (car(cadr(binding)) == sc->QUOTE)
			set_syntax_op(sc->code, sc->LET_Q);
		      else
			{
			  if (is_h_safe_c_s(cadr(binding)))
			    {
			      if ((is_null(cddr(sc->code))) &&
				  (is_pair(cadr(sc->code))))
				{
				  set_syntax_op(sc->code, sc->LET_R_P);
				  if (is_syntactic(caadr(sc->code)))
				    {
				      lifted_op(cadr(sc->code)) = syntax_opcode(caadr(sc->code));
				      if (c_call(cadr(binding)) == g_car)
					{
					  set_gcdr(sc->code, caaar(sc->code));
					  set_syntax_op(sc->code, sc->LET_CAR_P);
					}
				    }
				}
			      else set_syntax_op(sc->code, sc->LET_R);
			      set_fcdr(sc->code, cadr(cadr(binding)));
			    }
			  else 
			    {
			      set_fcdr(sc->code, cadr(binding));
			      if (is_all_x_safe(sc, cadr(binding)))
				{
				  if (optimize_data(cadr(binding)) == HOP_SAFE_C_SS)
				    set_syntax_op(sc->code, sc->LET_opSSq);
				  else
				    {
				      if (optimize_data(cadr(binding)) == HOP_SAFE_C_C)
					set_syntax_op(sc->code, sc->LET_opCq);
				      else set_syntax_op(sc->code, sc->LET_ALL_X);
				    }
				}
			      else
				{
				  set_fcdr(cdr(sc->code), car(binding));
				  if ((is_null(cddr(sc->code))) &&
				      (is_pair(cadr(sc->code))))
				    {
				      if (is_syntactic(caadr(sc->code)))
					{
					  lifted_op(cadr(sc->code)) = syntax_opcode(caadr(sc->code));
					  if (is_h_optimized(cadr(binding)))
					    set_syntax_op(sc->code, sc->LET_Z_P); 
					  else set_syntax_op(sc->code, sc->LET_O_P);
					  /* syntax_op uses ecdr */
					}
				      else
					{
					  if (is_h_optimized(cadr(binding)))
					    set_syntax_op(sc->code, sc->LET_Z_O); 
					  else set_syntax_op(sc->code, sc->LET_O_O); 
					}
				    }
				  else set_syntax_op(sc->code, sc->LET_O);
				}
			    }
			}
		    }
		  else
		    {
		      set_fcdr(sc->code, cadaar(sc->code));
		      set_gcdr(sc->code, caaar(sc->code));
		      /* should we make sure T_LINE_NUMBER is not set? -- it won't be cur_code in an error message */
		      if (is_symbol(fcdr(sc->code)))
			{
			  if (is_null(cddr(sc->code)))
			    set_syntax_op(sc->code, sc->LET_S_P);
			  else set_syntax_op(sc->code, sc->LET_S);
			}
		      else 
			{
			  if ((is_null(cddr(sc->code))) &&
			      (is_pair(cadr(sc->code))))
			    {
			      if (is_h_optimized(cadr(sc->code)))
				set_syntax_op(sc->code, sc->LET_C_D);
			      else set_syntax_op(sc->code, sc->LET_C_P); /* does not check syntax_opcode */
			    }
			  else set_syntax_op(sc->code, sc->LET_C);
			}
		    }
		}
	    }
	  else 
	    {
	      if (vars < GC_TRIGGER_SIZE)
		{
		  s7_pointer p, x, op;
		  /* set_syntax_op(sc->code, sc->LET_UNCHECKED); */
		  op = sc->NIL;
		  for (p = car(sc->code); is_pair(p); p = cdr(p))
		    {
		      x = car(p);
		      if (symbol_has_accessor(car(x)))
			{
			  op = sc->LET_UNCHECKED;
			  break;
			}
		      if (is_pair(cadr(x)))
			{
			  if (car(cadr(x)) == sc->QUOTE)
			    op = sc->LET_ALL_X;
			  else
			    {
			      if (is_h_safe_c_s(cadr(x)))
				{
				  if ((op == sc->NIL) || (op == sc->LET_ALL_R))
				    op = sc->LET_ALL_R;
				  else op = sc->LET_ALL_X;
				}
			      else 
				{
				  if (is_all_x_safe(sc, cadr(x)))
				    op = sc->LET_ALL_X;
				  else 
				    {
				      op = sc->LET_UNCHECKED;
				      break;
				    }
				}
			    }
			}
		      else
			{
			  if (is_symbol(cadr(x)))
			    {
			      if ((op == sc->NIL) || (op == sc->LET_ALL_S))
				op = sc->LET_ALL_S;
			      else op = sc->LET_ALL_X;
			    }
			  else
			    {
			      if ((op == sc->NIL) || (op == sc->LET_ALL_C))
				op = sc->LET_ALL_C;
			      else op = sc->LET_ALL_X;
			    }
			}
		    }
		  set_syntax_op(sc->code, op);
		}
	      else set_syntax_op(sc->code, sc->LET_UNCHECKED);
	    }
	}
      if (syntax_op(sc->code) == sc->LET_ALL_X)
	{
	  s7_pointer p;
	  for (p = car(sc->code); is_pair(p); p = cdr(p))
	    set_fcdr(cdar(p), (s7_pointer)all_x_eval(sc, cadar(p)));
	}
      /*
      fprintf(stderr, "%s\n    %s: %s\n", DISPLAY_80(sc->code), real_op_names[lifted_op(ecdr(sc->code))], 
	      ((!is_null(cdr(sc->code))) && (is_null(cddr(sc->code)))) ? (opt_name(cadr(sc->code))) : "()");
      */
    }
  return(sc->code);
}


static s7_pointer check_let_star(s7_scheme *sc)
{
  s7_pointer y;
  bool named_let;

  if (!is_pair(sc->code))                    /* (let* . 1) */
    return(eval_error(sc, "let* variable list is messed up: ~A", sc->code));
  
  if (!is_pair(cdr(sc->code)))               /* (let*) */
    return(eval_error(sc, "let* variable list is messed up: ~A", sc->code));
  
  named_let = (is_symbol(car(sc->code)));

  if (named_let)
    {
      if (!s7_is_list(sc, cadr(sc->code)))      /* (let* hi #t) */
	return(eval_error(sc, "let* variable list is messed up: ~A", sc->code));
      if (is_null(cddr(sc->code)))              /* (let* hi () ) */
	return(eval_error(sc, "named let* has no body: ~A", sc->code));
      if (is_immutable(car(sc->code)))
	return(s7_error(sc, sc->WRONG_TYPE_ARG,
			list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), sc->code)));
      set_local(car(sc->code));
      if ((!is_null(cadr(sc->code))) &&
	  ((!is_pair(cadr(sc->code))) ||            /* (let* hi x ... ) */
	   (!is_pair(caadr(sc->code))) ||           /* (let* hi (x) ...) */
	   (!is_pair(cdaadr(sc->code)))))           /* (let* hi ((x . 1)) ...) */
	return(eval_error(sc, "named let* variable declaration value is missing: ~A", sc->code));
    }
  else
    {
      if ((!is_null(car(sc->code))) &&
	  ((!is_pair(car(sc->code))) ||            /* (let* x ... ) */
	   (!is_pair(caar(sc->code))) ||           /* (let* (x) ...) */
	   (!is_pair(cdaar(sc->code)))))            /* (let* ((x . 1)) ...) */
	return(eval_error(sc, "let* variable declaration value is missing: ~A", sc->code));
    }

  for (y = ((named_let) ? cadr(sc->code) : car(sc->code)); is_pair(y); y = cdr(y))
    {
      s7_pointer x, z;
      x = car(y);
      if (!(is_symbol(car(x))))     /* (let* ((3 1)) 1) */
	return(eval_error(sc, "bad variable ~S in let*", x));

      z = car(x);
      if (is_immutable(z))
	return(s7_error(sc, sc->WRONG_TYPE_ARG,
			list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), x)));

      if (!is_pair(x))                 /* (let* ((x)) ...) */
	return(eval_error(sc, "let* variable declaration, but no value?: ~A", x));
      
      if (!(is_pair(cdr(x))))          /* (let* ((x . 1))...) */
	return(eval_error(sc, "let* variable declaration is not a proper list?: ~A", x));
      
      if (is_not_null(cddr(x)))        /* (let* ((x 1 2 3)) ...) */
	return(eval_error(sc, "let* variable declaration has more than one value?: ~A", x));
      
      x = cdr(y);
      if (is_pair(x)) 
	{ 
	  if (!is_pair(car(x)))             /* (let* ((x -1) 2) 3) */
	    return(eval_error(sc, "let* variable/binding is ~S?", car(x)));
	  
	  if (!is_pair(cdar(x)))            /* (let* ((a 1) (b . 2)) ...) */
	    return(eval_error(sc, "let* variable list is messed up? ~A", x));
	}
      else
	{
	  if (is_not_null(x))               /* (let* ((a 1) . b) a) */
	    return(eval_error(sc, "let* var list improper?: ~A", x));
	}
      set_local(z);
    }

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (named_let)
	{
	  if (is_null(cadr(sc->code)))
	    set_syntax_op(sc->code, sc->NAMED_LET_NO_VARS);
	  else 
	    {
	      set_syntax_op(sc->code, sc->NAMED_LET_STAR);
	      set_fcdr(sc->code, cadr(car(cadr(sc->code))));
	    }
	  return(sc->code);
	}

      set_syntax_op(sc->code, sc->LET_STAR_UNCHECKED);
      if (is_null(car(sc->code)))
	set_syntax_op(sc->code, sc->LET_NO_VARS); /* (let* () ...) */
      else 
	{
	  if (is_null(cdar(sc->code)))
	    {
	      s7_pointer binding;
	      binding = caar(sc->code);
	      if (symbol_has_accessor(car(binding)))
		set_syntax_op(sc->code, sc->LET_STAR_UNCHECKED);
	      else
		{
		  if (is_pair(cadr(binding)))
		    {
		      if (car(cadr(binding)) == sc->QUOTE)
			set_syntax_op(sc->code, sc->LET_Q);
		      else
			{
			  if (is_h_safe_c_s(cadr(binding)))
			    {
			      if ((is_null(cddr(sc->code))) &&
				  (is_pair(cadr(sc->code))))
				{
				  set_syntax_op(sc->code, sc->LET_R_P);
				  if (is_syntactic(caadr(sc->code)))
				    {
				      lifted_op(cadr(sc->code)) = syntax_opcode(caadr(sc->code));
				      if (c_call(cadr(binding)) == g_car)
					{
					  set_gcdr(sc->code, caaar(sc->code));
					  set_syntax_op(sc->code, sc->LET_CAR_P);
					}
				    }
				}
			      else set_syntax_op(sc->code, sc->LET_R);
			      set_fcdr(sc->code, cadr(cadr(binding)));
			    }
			  else 
			    {
			      set_fcdr(sc->code, cadr(binding));
			      if (is_all_x_safe(sc, cadr(binding)))
				set_syntax_op(sc->code, sc->LET_ALL_X);
			      else
				{
				  set_fcdr(cdr(sc->code), car(binding));
				  if ((is_null(cddr(sc->code))) &&
				      (is_pair(cadr(sc->code))))
				    {
				      if (is_syntactic(caadr(sc->code)))
					{
					  lifted_op(cadr(sc->code)) = syntax_opcode(caadr(sc->code));
					  if (is_h_optimized(cadr(binding)))
					    set_syntax_op(sc->code, sc->LET_Z_P); 
					  else set_syntax_op(sc->code, sc->LET_O_P); 
					}
				      else
					{
					  if (is_h_optimized(cadr(binding)))
					    set_syntax_op(sc->code, sc->LET_Z_O); 
					  else set_syntax_op(sc->code, sc->LET_O_O); 
					}
				    }
				  else set_syntax_op(sc->code, sc->LET_O);
				}
			    }
			}
		    }
		  else
		    {
		      set_fcdr(sc->code, cadaar(sc->code));
		      set_gcdr(sc->code, caaar(sc->code)); /* added 18-Jun-13 to parallel LET_C_D cases above */
		      if (is_symbol(cadaar(sc->code)))
			{
			  if (is_null(cddr(sc->code)))
			    set_syntax_op(sc->code, sc->LET_S_P);
			  else set_syntax_op(sc->code, sc->LET_S);
			}
		      else 
			{
			  if ((is_null(cddr(sc->code))) &&
			      (is_pair(cadr(sc->code))))
			    {
			      if (is_h_optimized(cadr(sc->code)))
				set_syntax_op(sc->code, sc->LET_C_D);
			      else set_syntax_op(sc->code, sc->LET_C_P);
			    }
			  else set_syntax_op(sc->code, sc->LET_C);
			}
		    }
		}
	    }
	  else  /* more than one entry */
	    {
	      s7_pointer p, x, op;
	      op = sc->LET_STAR_ALL_X;
	      set_fcdr(sc->code, cadaar(sc->code));
	      for (p = car(sc->code); is_pair(p); p = cdr(p))
		{
		  x = car(p);
		  if (symbol_has_accessor(car(x)))
		    {
		      op = sc->LET_STAR2;
		      break;
		    }
		  if (is_pair(cadr(x)))
		    {
		      if ((!is_all_x_safe(sc, cadr(x))) &&
			  (car(cadr(x)) != sc->QUOTE))
			{
			  op = sc->LET_STAR2;
			  break;
			}
		    }
		}
	      set_syntax_op(sc->code, op);
	    }
	}
      if ((syntax_op(sc->code) == sc->LET_ALL_X) ||
	  (syntax_op(sc->code) == sc->LET_STAR_ALL_X))
	{
	  s7_pointer p;
	  for (p = car(sc->code); is_pair(p); p = cdr(p))
	    set_fcdr(cdar(p), (s7_pointer)all_x_eval(sc, cadar(p)));
	}
    }
  return(sc->code);
}


static s7_pointer check_letrec(s7_scheme *sc)
{
  s7_pointer x;
  if ((!is_pair(sc->code)) ||                 /* (letrec . 1) */
      (!is_pair(cdr(sc->code))) ||            /* (letrec) */
      (!s7_is_list(sc, car(sc->code))))       /* (letrec 1 ...) */
    return(eval_error(sc, "letrec variable list is messed up: ~A", sc->code));
  
  for (x = car(sc->code); is_not_null(x); x = cdr(x))
    {
      if (!is_pair(x))                        /* (letrec ((a 1) . 2) ...) */
	return(eval_error(sc, "improper list of letrec variables? ~A", sc->code));
      
      if ((!is_pair(car(x))) ||               /* (letrec (1 2) #t) */
	  (!(is_symbol(caar(x)))))
	return(eval_error(sc, "bad variable ~S in letrec", car(x)));
      
      if (is_immutable(caar(x)))
	return(s7_error(sc, sc->WRONG_TYPE_ARG,
			list_2(sc, make_protected_string(sc, "can't bind an immutable object: ~S"), x)));

      if (!is_pair(cdar(x)))                  /* (letrec ((x . 1))...) */
	{
	  if (is_null(cdar(x)))               /* (letrec ((x)) x) -- perhaps this is legal? */
	    return(eval_error(sc, "letrec variable declaration has no value?: ~A", car(x)));
	  return(eval_error(sc, "letrec variable declaration is not a proper list?: ~A", car(x)));
	}
      if (is_not_null(cddar(x)))              /* (letrec ((x 1 2 3)) ...) */
	return(eval_error(sc, "letrec variable declaration has more than one value?: ~A", car(x)));

      set_local(caar(x));
    }

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    set_syntax_op(sc->code, sc->LETREC_UNCHECKED);

  return(sc->code);
}


static s7_pointer check_quote(s7_scheme *sc)
{
  if (!is_pair(sc->code))                    /* (quote . -1) */
    {
      if (is_null(sc->code))
	return(eval_error(sc, "quote: not enough arguments: ~A", sc->code));
      return(eval_error(sc, "quote: stray dot?: ~A", sc->code));
    }
  if (is_not_null(cdr(sc->code)))             /* (quote . (1 2)) or (quote 1 1) */
    return(eval_error(sc, "quote: too many arguments ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      set_syntax_op(sc->code, sc->QUOTE_UNCHECKED);
    }

  return(sc->code);
}


static s7_pointer check_and(s7_scheme *sc)
{
  s7_pointer p;
  bool all_pairs;

  if (is_null(sc->code))
    return(sc->code);

  all_pairs = is_pair(sc->code);
  for (p = sc->code; is_pair(p); p = cdr(p))
    {
      if (!is_pair(car(p)))
	all_pairs = false;
    }

  if (is_not_null(p))                                    /* (and . 1) (and #t . 1) */
    return(eval_error(sc, "and: stray dot?: ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (all_pairs)
	{
	  for (p = sc->code; is_pair(p); p = cdr(p))
	    {
	      set_fcdr(p, (s7_pointer)orp_all_x_eval(sc, car(p))); /* this can be nil! */
	      /* fprintf(stderr, "%sset %s fcdr (%p) to %p%s\n", BOLD_TEXT, DISPLAY(p), p, fcdr(p), UNBOLD_TEXT); */
	    }
	  set_syntax_op(sc->code, sc->AND_P);
	}
      else set_syntax_op(sc->code, sc->AND_UNCHECKED);
    }
  return(sc->code);
}


/* (define (hi a b) (if (or (pair? a) (= a b)) a))
 */

static s7_pointer check_or(s7_scheme *sc)
{
  s7_pointer p;
  bool all_pairs;

  if (is_null(sc->code))
    return(sc->code);

  all_pairs = is_pair(sc->code);
  for (p = sc->code; is_pair(p); p = cdr(p))
    {
      if (!is_pair(car(p)))
	all_pairs = false;
    }

  if (is_not_null(p))
    return(eval_error(sc, "or: stray dot?: ~A", sc->code));
  
  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (all_pairs)
	{
	  s7_pointer p;
	  for (p = sc->code; is_pair(p); p = cdr(p))
	    set_fcdr(p, (s7_pointer)orp_all_x_eval(sc, car(p)));
	  set_syntax_op(sc->code, sc->OR_P);
	}
      else set_syntax_op(sc->code, sc->OR_UNCHECKED);
    }
  return(sc->code);
}


static s7_pointer check_if(s7_scheme *sc)
{
  s7_pointer cdr_code;

  if (!is_pair(sc->code))                               /* (if) or (if . 1) */
    return(eval_error(sc, "(if): if needs at least 2 expressions: ~A", sc->code));
  
  cdr_code = cdr(sc->code);
  if (!is_pair(cdr_code))                          /* (if 1) */
    return(eval_error(sc, "(if ~A): if needs another clause", car(sc->code)));
  
  if (is_pair(cdr(cdr_code)))
    {
      if (is_not_null(cddr(cdr_code)))                   /* (if 1 2 3 4) */
	return(eval_error(sc, "too many clauses for if: ~A", sc->code));
    }
  else
    {
      if (is_not_null(cdr(cdr_code)))                    /* (if 1 2 . 3) */
	return(eval_error(sc, "if: ~A has improper list?", sc->code));
    }

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      s7_pointer test, t, f;

      test = car(sc->code);
      t = car(cdr_code);
      if (is_pair(cdr(cdr_code)))
	f = cadr(cdr_code);
      else f = sc->UNSPECIFIED;

      if (is_pair(test))
	{
	  if (is_pair(t))
	    {
	      if (is_pair(f))
		{
 		  if (is_h_optimized(test))
		    {
		      if (optimize_data(test) == HOP_SAFE_C_C)
			set_syntax_op(sc->code, sc->SAFE_IF_CC_P_P);
		      else 
			{
			  if (is_h_safe_c_s(test))
			    {
			      if ((car(t) == sc->QUOTE) &&
				  (car(test) == sc->NULLP) &&
				  (is_syntactic(car(f))))
				{
				  lifted_op(f) = syntax_opcode(car(f));
				  set_syntax_op(sc->code, sc->SAFE_IF_IS_NULL_Q_P);
				  set_fcdr(sc->code, cadr(test));
				}
			      else 
				{
				  if (car(test) == sc->PAIRP)
				    {
				      set_syntax_op(sc->code, sc->SAFE_IF_IS_PAIR_P_P);
				      set_fcdr(sc->code, cadr(test));
				    }
				  else
				    {
				      if (car(test) == sc->SYMBOLP)
					set_syntax_op(sc->code, sc->SAFE_IF_IS_SYMBOL_P_P);
				      else set_syntax_op(sc->code, sc->SAFE_IF_CS_P_P);
				      set_fcdr(sc->code, cadr(test));
				    }
				}
			    }
			  else
			    {
			      if (optimize_data(test) == HOP_SAFE_C_SQ)
				{
				  set_syntax_op(sc->code, sc->SAFE_IF_CSQ_P_P);
				  set_fcdr(sc->code, cadr(caddr(test)));
				}
			      else
				{
				  if (optimize_data(test) == HOP_SAFE_C_SS)
				    {
				      set_syntax_op(sc->code, sc->SAFE_IF_CSS_P_P);
				      set_fcdr(sc->code, caddr(test));
				    }
				  else
				    {
				      if (optimize_data(test) == HOP_SAFE_C_SC)
					{
					  set_syntax_op(sc->code, sc->SAFE_IF_CSC_P_P);
					  set_fcdr(sc->code, caddr(test));
					}
				      else 
					{
					  if (is_all_x_safe(sc, test))
					    {
					      set_syntax_op(sc->code, sc->IF_A_P_P);
					      set_fcdr(sc->code, (s7_pointer)all_x_eval(sc, test));
					    }
					  else set_syntax_op(sc->code, sc->IF_Z_P_P);
					}
				    }
				}
			    }
			}
		    }
		  else
		    {
		      if (is_syntactic(car(test)))
			{
			  opcode_t new_op;
			  lifted_op(test) = syntax_opcode(car(test));
			  set_syntax_op(sc->code, sc->IF_B_P_P);

			  if (syntax_opcode(car(test)) == OP_AND)
			    {
			      s7_pointer old_code;
			      old_code = sc->code;
			      sc->code = cdr(test);
			      check_and(sc);
			      new_op = syntax_opcode(car(test));
			      sc->code = old_code;
			      if (new_op == OP_AND_P)
				set_syntax_op(sc->code, sc->IF_ANDP_P_P);
			    }
			  else
			    {
			      if (syntax_opcode(car(test)) == OP_OR)
				{
				  s7_pointer old_code;
				  old_code = sc->code;
				  sc->code = cdr(test);
				  check_or(sc);
				  new_op = syntax_opcode(car(test));
				  sc->code = old_code;
				      
				  if (new_op == OP_OR_P)
				    set_syntax_op(sc->code, sc->IF_ORP_P_P);
				}
			    }
			}
		      else set_syntax_op(sc->code, sc->IF_P_P_P);
		    }
		}
	      else 
		{
		  if (is_null(cdr(cdr_code)))
		    {
		      if (is_h_optimized(test))
			{
			  if (optimize_data(test) == HOP_SAFE_C_C)
			    set_syntax_op(sc->code, sc->SAFE_IF_CC_P);
			  else 
			    {
			      if (is_h_safe_c_s(test))
				{
				  if (car(test) == sc->PAIRP)
				    {
				      set_syntax_op(sc->code, sc->SAFE_IF_IS_PAIR_P);
				      set_fcdr(sc->code, cadr(test));
				    }
				  else
				    {
				      if (car(test) == sc->SYMBOLP)
					set_syntax_op(sc->code, sc->SAFE_IF_IS_SYMBOL_P);
				      else set_syntax_op(sc->code, sc->SAFE_IF_CS_P); 
				      set_fcdr(sc->code, cadr(test));
				    }
				}
			      else
				{
				  if (optimize_data(test) == HOP_SAFE_C_SQ)
				    {
				      set_syntax_op(sc->code, sc->SAFE_IF_CSQ_P);
				      set_fcdr(sc->code, cadr(caddr(test)));
				    }
				  else
				    {
				      if (optimize_data(test) == HOP_SAFE_C_SS)
					{
					  set_syntax_op(sc->code, sc->SAFE_IF_CSS_P);
					  set_fcdr(sc->code, caddr(test));
					}
				      else
					{
					  if (optimize_data(test) == HOP_SAFE_C_SC)
					    {
					      set_syntax_op(sc->code, sc->SAFE_IF_CSC_P);
					      set_fcdr(sc->code, caddr(test));
					    }
					  else				
					    {
					      if (optimize_data(test) == HOP_SAFE_C_opSSq)
						{
						  set_syntax_op(sc->code, sc->SAFE_IF_C_SS_P);
						  set_fcdr(sc->code, cadar(sc->code));
						}
					      else
						{
						  /* test is h_optimized here
						   */
						  if (is_all_x_safe(sc, test))
						    {
						      if (is_h_optimized(t))
							{
							  set_fcdr(sc->code, cadr(sc->code));
							  set_syntax_op(sc->code, sc->SAFE_IF_Z_Z);
							}
						      else 
							{
							  set_fcdr(sc->code, (s7_pointer)all_x_eval(sc, test));
							  set_syntax_op(sc->code, sc->IF_A_P);
							}
						    }
						  else
						    {
#if (!WITH_GMP)
						      if ((optimize_data(test) == HOP_SAFE_C_op_opSSq_q_C) &&
							  (c_call(test) == g_greater_s_fc) && /* this checks that caddr is T_REAL, and args == 2 */
							  ((c_call(cadr(test)) == g_magnitude) || (c_call(cadr(test)) == g_abs)) &&
							  (c_call(cadr(cadr(test))) == g_subtract_2))
							{
							  set_syntax_op(sc->code, sc->IF_GT_P);
							  set_fcdr(sc->code, cadr(cadr(test)));
							}
						      else
#endif
							{
							  set_fcdr(sc->code, cadr(sc->code));
							  if (is_h_optimized(t))
							    set_syntax_op(sc->code, sc->SAFE_IF_Z_Z);
							  else set_syntax_op(sc->code, sc->IF_Z_P);
							}
						    }
						}
					    }
					}
				    }
				}
			    }
			}
		      else 
			{
			  if (is_syntactic(car(test)))
			    {
			      opcode_t new_op;
			      set_syntax_op(sc->code, sc->IF_B_P);
			      lifted_op(test) = syntax_opcode(car(test));
			      if (syntax_opcode(car(test)) == OP_AND)
				{
				  s7_pointer old_code;
				  old_code = sc->code;
				  sc->code = cdr(test);
				  check_and(sc);
				  new_op = syntax_opcode(car(test));
				  sc->code = old_code;

				  if (new_op == OP_AND_P)
				    set_syntax_op(sc->code, sc->IF_ANDP_P);
				}
			      else
				{
				  if (syntax_opcode(car(test)) == OP_OR)
				    {
				      s7_pointer old_code;
				      old_code = sc->code;
				      sc->code = cdr(test);
				      check_or(sc);
				      new_op = syntax_opcode(car(test));
				      sc->code = old_code;
				      
				      if (new_op == OP_OR_P)
					set_syntax_op(sc->code, sc->IF_ORP_P);
				    }
				}
			    }
			  else set_syntax_op(sc->code, sc->IF_P_P);
			}
		    }
		  else
		    {
		      if (is_h_safe_c_s(test))
			{
			  if (car(test) == sc->PAIRP)
			    {
			      set_syntax_op(sc->code, sc->SAFE_IF_IS_PAIR_P_X);
			      set_fcdr(sc->code, cadr(test));
			    }
			  else
			    {
			      set_syntax_op(sc->code, sc->SAFE_IF_CS_P_X);
			      set_fcdr(sc->code, cadr(test));
			    }
			}
		      else set_syntax_op(sc->code, sc->IF_P_P_X);
		    }
		}
	    }
	  else 
	    {
	      if (is_pair(f))
		{
		  if (is_h_optimized(test))
		    {
		      if (optimize_data(test) == HOP_SAFE_C_C)
			set_syntax_op(sc->code, sc->SAFE_IF_CC_X_P);
		      else
			{
			  if (is_h_safe_c_s(test))
			    {
			      set_syntax_op(sc->code, sc->SAFE_IF_CS_X_P);
			      set_fcdr(sc->code, cadr(test));
			      if ((is_symbol(t)) &&
				  (car(test) == sc->NULLP) &&
				  (is_syntactic(car(f))))
				{
				  lifted_op(f) = syntax_opcode(car(f));
				  set_syntax_op(sc->code, sc->SAFE_IF_IS_NULL_S_P);
				}
			    }
			  else 
			    {
			      if (optimize_data(test) == HOP_SAFE_C_SS)
				{
				  set_syntax_op(sc->code, sc->SAFE_IF_CSS_X_P);
				  set_fcdr(sc->code, caddr(test));
				}
			      else
				{
				  if (optimize_data(test) == HOP_SAFE_C_SC)
				    {
				      if ((t == cadr(test)) &&
					  (is_h_optimized(f)))
					set_syntax_op(sc->code, sc->SAFE_IF_CSC_X_O_A);
				      else set_syntax_op(sc->code, sc->SAFE_IF_CSC_X_P);
				      set_fcdr(sc->code, caddr(test));
				    }
				  else set_syntax_op(sc->code, sc->IF_P_X_P);
				}
			    }
			}
		    }
		  else set_syntax_op(sc->code, sc->IF_P_X_P);
		}
	    }
	}
      else /* test is symbol or constant, but constant here is nutty */
	{
	  if (is_symbol(test))
	    {
	      if (is_pair(t))
		{
		  if (is_pair(f))
		    set_syntax_op(sc->code, sc->IF_S_P_P);
		  else 
		    {
		      if (is_null(cdr(cdr_code)))
			set_syntax_op(sc->code, sc->IF_S_P);
		      else set_syntax_op(sc->code, sc->IF_S_P_X);
		    }
		}
	      else 
		{
		  if (is_pair(f))
		    set_syntax_op(sc->code, sc->IF_S_X_P);
		}
	    }
	}
    }
  return(sc->code);
}


static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer x, s7_pointer args, s7_pointer body)
{
  int len;
  /* fprintf(stderr, "optimize: %s %s\n", DISPLAY(args), DISPLAY(body)); */

  len = s7_list_length(sc, body);
  if (len < 0)                                                               /* (define (hi) 1 . 2) */
    return(eval_error_with_name(sc, "~A: function body messed up, ~A", sc->code));

  if (len > 0)  /* i.e. not circular */
    {
      bool bad_set = false;
      optimize(sc, body, 1, collect_collisions(sc, args, list_1(sc, x)));
      
      /* if the body is safe, we can optimize the calling sequence */
      if ((is_proper_list(sc, args)) &&
	  (!arglist_has_accessed_symbol(args)))
	{
	  if (!unstarred_lambda)
	    {
	      s7_pointer p, arg;
	      bool happy = true;
	      /* check default vals -- if none is an expression or symbol, set simple args */
	      for (p = args; is_pair(p); p = cdr(p))
		{
		  arg = car(p);
		  if ((is_pair(arg)) &&                /* has default value */
		      ((is_symbol(cadr(arg))) ||       /*    if default value might involve eval in any way, it isn't simple */
		       ((is_pair(cadr(arg))) &&        /*    pair as default only ok if it is (quote ...) */
			(car(cadr(arg)) != sc->QUOTE))))
		    {
		      happy = false;
		      break;
		    }
		}
	      if (happy)
		set_simple_args(body);
	    }
	  
	  sc->cycle_counter = 0;
	  /* it is expensive to check for cycles with collect_shared_info, but the
	   *   body_is_safe process can get hung if the cycle is hidden from the simple
	   *   checks above. 
	   *       (define (hi) (let ((ctr 0)) #1=(begin (format #t "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline)))))
	   *   tickles this bug.  In all my current test cases, we never get over 350 (lint), so checking
	   *   for 5000 seems safe.
	   *
	   * (added later: this comment may now be out-of-date -- cycles are now easy to detect)
	   */
	  if (body_is_safe(sc, x, args, body, true, &bad_set))
	    {
	      /* (define (hi a) (+ a 1) (hi (- a 1))) */
	      /* there is one problem with closure* here -- we can't trust anything that
	       *   has fancy (non-constant) default argument values.
	       */
	      if (unstarred_lambda)
		set_safe_closure(body);
	      else
		{
		  if (has_simple_args(body))
		    set_safe_closure(body);
		}
	    }
	}
    }
  return(x);
}


/* an experiment -- prelookup static refs */

static void substitute_arg_refs(s7_scheme *sc, s7_pointer expr, s7_pointer sym1, s7_pointer sym2)
{
  /* look for all_x_[s*] where s matches sym1|2, optimize to use current env
   *   also HOP_SAFE_C_[s*] -> HOP_SAFE_C_S1|2?
   *   HOP_SAFE_CLOSURE_CAR_CAR -> HOP_SAFE_CLOSURE_CARS1_CARS2 (and CDR) (and S_CDR_CDR) via the unknown op sequence -- tricky
   *     better perhaps: remove these special cases, use _AA or _SAA with all_x_car specializations
   * stop if any new env possible (shadowing and more complex env access)
   *
   * why can't we do something similar with locals? 
   * how can slots be reversed if safe closure? -- macros and OP_APPLY handling -- apparently no way around this
   */
  s7_pointer p;
  if (!is_pair(expr)) return;
  /*
    fprintf(stderr, "%s %d %d %s\n", DISPLAY_80(expr), is_annotated(expr), is_annotated(cadr(expr)), opt_name(expr));
  */

  if (is_syntactic(car(expr)))
    {
      switch (syntax_opcode(car(expr)))
	{
	case OP_IF:
#if 0
	  for (p = cdr(expr); is_pair(p); p = cdr(p))
	    if (is_pair(car(p)))
	      substitute_arg_refs(sc, p, sym1, sym2);
	  if ((is_pair(cdddr(expr))) && 
	      (is_annotated(cadddr(expr))) &&
	      (fcdr(cdddr(expr)) == (s7_pointer)all_x_c_c) &&
	      (c_call(cadddr(expr)) == (s7_function)g_if_all_x_qq) &&
	      (fcdr(cdr(cadddr(expr))) == (s7_pointer)all_x_c_is_eq_s2q))
	    {
	      /* an experiment in combining these guys -- it was not a big win
	       */
	      set_fcdr(cdddr(expr), (s7_pointer)all_x_c_if_sq_qq);
	    }
	  break;
#endif

	case OP_OR:
	case OP_AND:
	case OP_BEGIN:
	case OP_COND:
	case OP_CASE:
	  for (p = cdr(expr); is_pair(p); p = cdr(p))
	    if (is_pair(car(p)))
	      substitute_arg_refs(sc, p, sym1, sym2);
	  break;
	  
	case OP_SET:
	  substitute_arg_refs(sc, caddr(expr), sym1, sym2);
	  break;

	case OP_LET:
	case OP_LET_STAR:
	case OP_LETREC:
	  /* these can be optimized to some extent */
	  break;
	  
	case OP_WITH_BAFFLE: /* this creates a new env */
	case OP_QUOTE:
	case OP_DO:
	case OP_WITH_ENV:
	default:
	  break;
	}
    }
  else  /* car(expr) is not syntactic */
    {
      if (is_annotated(car(expr)))
	{
	  /*
	    fprintf(stderr, "  annotated %s %d %d %d %s %s %s\n", DISPLAY(expr),
	    ((s7_function)fcdr(expr) == all_x_c_sq), 
	    ((s7_function)fcdr(expr) == all_x_c_ss), 
	    ((s7_function)fcdr(expr) == all_x_c_c), 
	    DISPLAY(sym1), (sym2) ? DISPLAY(sym2) : "", 
	    opt_name(car(expr)));
	  */
	  if (((s7_function)fcdr(expr) == all_x_c_ss) &&
	      (cadr(car(expr)) == sym1) &&
	      (caddr(car(expr)) == sym2))
	    {
	      /* fprintf(stderr, "reset...\n"); */
	      if (c_call(car(expr)) == g_is_eq)
		set_fcdr(expr, (s7_pointer)all_x_c_is_eq_ss);
	      else set_fcdr(expr, (s7_pointer)all_x_c_s1s2);
	    }
	  else
	    {
	      if (((s7_function)fcdr(expr) == all_x_c_sq) &&
		  ((cadr(car(expr)) == sym1) ||
		   (cadr(car(expr)) == sym2)))
		{
		  /* fprintf(stderr, "reset...\n"); */
		  if (c_call(car(expr)) == g_is_eq)
		    set_fcdr(expr, (s7_pointer)all_x_c_is_eq_s2q);
		  else set_fcdr(expr, (s7_pointer)all_x_c_s12q);
		}
	    }
	  substitute_arg_refs(sc, car(expr), sym1, sym2);
	}
      for (p = cdr(expr); is_pair(p); p = cdr(p))
	if (is_pair(car(p)))
	      substitute_arg_refs(sc, p, sym1, sym2);
    }
}

static void optimize_safe_closure_arg_refs(s7_scheme *sc, s7_pointer func, int argn)
{
  /* we can replace all_x_c_ss (etc) with specializations that do not need to look up
   *   the function args: all_x_c_s1s2 (sc->envir slots will be in the any order!
   *
   * 1-arg: no order problem
   * 2-arg: s1s2 as above, s1c, s2c? etc -- everything splits
   * need a 2nd level all_x_eval -- all_x_prefind
   *
   * anything that introduces a new env halts our tree walker
   */
  /* if we used the arg list instead of e, I think this would also work for any closure.
   */

  s7_pointer body, p, e, sym1, sym2 = NULL;
  if ((argn == 0) || (argn > 2)) return;

  body = closure_body(func);
  e = closure_environment(func);
  sym1 = slot_symbol(environment_slots(e));
  if (argn == 2) sym2 = slot_symbol(next_slot(environment_slots(e)));

  for (p = body; is_pair(p); p = cdr(p))
    if (is_pair(p))
      substitute_arg_refs(sc, car(p), sym1, sym2);
}


static s7_pointer check_define(s7_scheme *sc)
{
  s7_pointer x;
  int arity = CLOSURE_ARITY_NOT_SET;

  if (!is_pair(sc->code))
    return(eval_error_with_name(sc, "~A: nothing to define? ~A", sc->code));   /* (define) */
  
  if (!is_pair(cdr(sc->code)))
    {
      if (is_null(cdr(sc->code)))
	return(eval_error_with_name(sc, "~A: no value? ~A", sc->code));        /* (define var) */
      return(eval_error_with_name(sc, "~A: bad form? ~A", sc->code));          /* (define var . 1) */
    }

  if (!is_pair(car(sc->code)))
    {
      if (is_not_null(cddr(sc->code)))                                           /* (define var 1 . 2) */
	return(eval_error_with_name(sc, "~A: more than 1 value? ~A", sc->code)); /* (define var 1 2) */
      if (sc->op == OP_DEFINE_STAR)
	return(eval_error(sc, "define* is restricted to functions: (define* ~{~S~^ ~})", sc->code));
      
      x = car(sc->code);
      if (!is_symbol(x))                                                        /* (define 3 a) */
	return(eval_error_with_name(sc, "~A: define a non-symbol? ~S", x));
      if (is_keyword(x))                                                        /* (define :hi 1) */
	return(eval_error_with_name(sc, "~A ~A: keywords are constants", x));
      if (is_syntactic(x))                                                      /* (define and a) */
	return(eval_error_with_name(sc, "~A ~A: syntactic keywords tend to behave badly if redefined", x));
      if ((is_pair(cadr(sc->code))) &&               /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */
	  (((symbol_id(sc->LAMBDA) == 0) && (caadr(sc->code) == sc->LAMBDA)) ||
	   ((symbol_id(sc->LAMBDA_STAR) == 0) && (caadr(sc->code) == sc->LAMBDA_STAR))))
	/* not is_global here because that bit might not be set for initial symbols (why not??) */
	optimize_lambda(sc, caadr(sc->code) == sc->LAMBDA, x, cadr(cadr(sc->code)), cddr(cadr(sc->code)));
    }
  else
    {
      x = caar(sc->code);
      if (!is_symbol(x))                                                        /* (define (3 a) a) */
	return(eval_error_with_name(sc, "~A: define a non-symbol? ~S", x));
      if (is_syntactic(x))                                                      /* (define (and a) a) */
	return(eval_error_with_name(sc, "~A ~A: syntactic keywords tend to behave badly if redefined", x));

      if (sc->op == OP_DEFINE_STAR)
	cdar(sc->code) = check_lambda_star_args(sc, cdar(sc->code), &arity);
      else check_lambda_args(sc, cdar(sc->code), &arity);

      optimize_lambda(sc, sc->op == OP_DEFINE, x, cdar(sc->code), cdr(sc->code));
    }

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if ((arity >= 0) &&
	  (arity < NUM_SMALL_INTS))
	set_fcdr(sc->code, small_int(arity));
      else set_fcdr(sc->code, make_permanent_integer(arity));
      
      if (sc->op == OP_DEFINE)
	{
	  if ((is_pair(car(sc->code))) &&
	      (!symbol_has_accessor(x)) &&
	      (!is_immutable(x)))
	    set_syntax_op(sc->code, sc->DEFINE_FUNCHECKED);
	  else set_syntax_op(sc->code, sc->DEFINE_UNCHECKED);
	}
      else set_syntax_op(sc->code, sc->DEFINE_STAR_UNCHECKED);
    }
  else set_fcdr(sc->code, sc->F);

  return(sc->code);
}


static s7_pointer check_with_env(s7_scheme *sc)
{
  if (!is_pair(sc->code))                            /* (with-environment . "hi") */
    return(eval_error(sc, "with-environment takes an environment argument: ~A", sc->code));
  if (!is_pair(cdr(sc->code)))                       /* (with-environment e) -> an error? */
    return(eval_error(sc, "with-environment body is messed up: ~A", sc->code));
  if ((!is_pair(cddr(sc->code))) &&
      (!is_null(cddr(sc->code))))
    return(eval_error(sc, "with-environment body has stray dot? ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      set_syntax_op(sc->code, sc->WITH_ENV_UNCHECKED);
      if ((is_symbol(car(sc->code))) &&
	  (is_pair(cadr(sc->code))))
	set_syntax_op(sc->code, sc->WITH_ENV_S);
    }
  return(sc->code);
}


static s7_pointer check_set(s7_scheme *sc)
{
  if (!is_pair(sc->code))
    {
      if (is_null(sc->code))                                             /* (set!) */
	return(eval_error(sc, "set!: not enough arguments: ~A", sc->code));
      return(eval_error(sc, "set!: stray dot? ~A", sc->code));           /* (set! . 1) */
    }
  if (!is_pair(cdr(sc->code)))                                
    {
      if (is_null(cdr(sc->code)))                                         /* (set! var) */
	return(eval_error(sc, "set!: not enough arguments: ~A", sc->code));
      return(eval_error(sc, "set!: stray dot? ~A", sc->code));           /* (set! var . 1) */
    }
  if (is_not_null(cddr(sc->code)))                                       /* (set! var 1 2) */
    return(eval_error(sc, "~A: too many arguments to set!", sc->code));
  
  /* cadr (the value) has not yet been evaluated */
  
  if (is_immutable(car(sc->code)))                                       /* (set! pi 3) */
    return(eval_error(sc, "set!: can't alter immutable object: ~S", car(sc->code)));
  
  if (is_pair(car(sc->code)))
    {
      if (is_pair(caar(sc->code)))
	{
	  if (!s7_is_list(sc, cdar(sc->code)))                          /* (set! ('(1 2) . 0) 1) */
	    eval_error(sc, "improper list of args to set!: ~A", sc->code);
	}
      if (!is_proper_list(sc, car(sc->code)))                           /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */
	eval_error(sc, "set! target is an improper list: (set! ~A ...)", car(sc->code));
    }
  else
    {
      if (!is_symbol(car(sc->code)))                                 /* (set! 12345 1) */
	return(eval_error(sc, "set! can't change ~S", car(sc->code)));

      /* now check for (set! abs 3) and the like -- in this case (safe function, abs currently refers to the global value)
       *   turn off optimization.
       */
      if ((is_global(car(sc->code))) &&
	  (is_c_function(slot_value(global_slot(car(sc->code))))) &&
	  (is_safe_procedure(slot_value(global_slot(car(sc->code))))))
	t_optimized = 0;
    }

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (is_pair(car(sc->code)))
	{
	  s7_pointer inner, value;
	  inner = car(sc->code);
	  value = cadr(sc->code);

	  set_syntax_op(sc->code, sc->SET_UNCHECKED);
	  if (is_symbol(car(inner)))
	    {
	      if ((is_null(cdr(inner))) &&
		  (!is_pair(value)) &&
		  (is_global(car(inner))) &&
		  (is_c_function(slot_value(global_slot(car(inner))))) &&
		  (c_function_required_args(slot_value(global_slot(car(inner)))) == 0))
		set_syntax_op(sc->code, sc->SET_PWS);
	      else
		{
		  if ((is_pair(cdr(inner))) &&
		      (!is_pair(cddr(inner)))) /* we check cddr(sc->code) above */
		    {
		      if (!is_pair(cadr(inner)))
			{
			  if (!is_pair(value))
			    set_syntax_op(sc->code, sc->SET_PAIR);
			  else 
			    {
			      set_syntax_op(sc->code, sc->SET_PAIR_P);
			      /* splice_in_values protects us here from values */
			      if (is_h_optimized(value))
				{
				  set_syntax_op(sc->code, sc->SET_PAIR_Z);
				  if (is_all_x_safe(sc, value))
				    {
				      s7_pointer obj;
				      obj = finder(sc, car(inner));
				      if ((is_c_function(obj)) &&
					  (is_c_function(c_function_setter(obj))))
					{
					  annotate_arg(sc, cdr(sc->code));
					  set_syntax_op(sc->code, sc->SET_PAIR_A);
					}
				    }
				}
			    }
			}
		      else
			{
			  if ((car(cadr(inner)) == sc->QUOTE) &&
			      (is_symbol(car(inner))) &&
			      ((is_symbol(value)) || (is_all_x_safe(sc, value))))
			    {
			      if (is_symbol(value))
				set_syntax_op(sc->code, sc->SET_ENV_S);
			      else 
				{
				  set_syntax_op(sc->code, sc->SET_ENV_ALL_X);
				  set_fcdr(cdr(sc->code), (s7_pointer)all_x_eval(sc, value));
				}
			    }
			  else
			    {
			      if ((is_optimized(cadr(inner))) &&
				  (optimize_data(cadr(inner)) == HOP_SAFE_C_C))
				{
				  if (!is_pair(value))
				    set_syntax_op(sc->code, sc->SET_PAIR_C);
				  else 
				    {
				      /* splice_in_values protects us here from values */
				      set_syntax_op(sc->code, sc->SET_PAIR_C_P);
				    }
				}
			    }
			}
		    }
		}
	    }
	}
      else set_syntax_op(sc->code, sc->SET_NORMAL);
      
      if (is_symbol(car(sc->code)))
	{
	  if ((!symbol_has_accessor(car(sc->code))) &&
	      (!is_syntactic(car(sc->code))))
	    {
	      if (is_symbol(cadr(sc->code)))
		set_syntax_op(sc->code, sc->SET_SYMBOL_S);
	      else
		{
		  if (!is_pair(cadr(sc->code)))
		    set_syntax_op(sc->code, sc->SET_SYMBOL_C);
		  else
		    {
		      if (car(cadr(sc->code)) == sc->QUOTE)
			set_syntax_op(sc->code, sc->SET_SYMBOL_Q);
		      else
			{
			  /* if cadr(cadr) == car, or cdr(cadr) not null and cadr(cadr) == car, and cddr(cadr) == null,
			   *   it's (set! <var> (<op> <var> val)) or (<op> val <var>) or (<op> <var>)
			   *   in the set code, we get the slot as usual, then in case 1 above,
			   *   car(sc->T2_1) = slot_value(slot), car(sc->T2_2) = increment, call <op>, set slot_value(slot)
			   *
			   * this can be done in all combined cases where a symbol is repeated (do in particular)
			   */
			  
			  /* (define (hi) (let ((x 1)) (set! x (+ x 1)))) 
			   *   but the value might be values:
			   *   (let () (define (hi) (let ((x 0)) (set! x (values 1 2)) x)) (catch #t hi (lambda a a)) (hi))
			   *   which is caught in splice_in_values
			   */
			  set_syntax_op(sc->code, sc->SET_SYMBOL_P);
			  /*
			    if ((is_pair(cadr(sc->code))) &&
			    (is_optimized(cadr(sc->code))))
			      fprintf(stderr, "setp: %s %s\n", DISPLAY_80(cadr(sc->code)), opt_name(cadr(sc->code)));
			  */
			  if (is_h_safe_c_s(cadr(sc->code)))
			    {
			      set_syntax_op(sc->code, sc->SET_SYMBOL_SAFE_S);
			      set_fcdr(sc->code, cadr(cadr(sc->code)));
			    }
			  else
			    {
			      if (is_optimized(cadr(sc->code)))
				{
				  set_syntax_op(sc->code, sc->SET_SYMBOL_Z);

				  if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_C)
				    {
				      if ((car(sc->code) == cadr(cadr(sc->code))) &&
					  (caadr(sc->code) == sc->ADD) &&
					  (is_null(cdddr(cadr(sc->code)))) &&
					  (is_optimized(caddr(cadr(sc->code)))) &&
					  (optimize_data(caddr(cadr(sc->code))) == HOP_SAFE_C_C) && /* paranoia... */
					  (s7_function_returns_temp(sc, caddr(cadr(sc->code)))))
					{
					  set_syntax_op(sc->code, sc->INCREMENT_C_TEMP);
					  set_fcdr(sc->code, caddr(cadr(sc->code)));
					}
				      else
					{
					  set_syntax_op(sc->code, sc->SET_SYMBOL_SAFE_C);
					  /* ecdr here points back? */
					  set_fcdr(sc->code, cdr(cadr(sc->code)));
					}
				    }
				  else
				    {
				      /* most of these special cases probably don't matter -- should use the all_x case below instead */
				      if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_SS)
					{
					  if (car(sc->code) == cadr(cadr(sc->code)))
					    set_syntax_op(sc->code, sc->INCREMENT_SS);
					  else set_syntax_op(sc->code, sc->SET_SYMBOL_SAFE_SS);
					  set_fcdr(sc->code, cdr(cadr(sc->code)));
					}
				      else
					{
					  if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_SSS)
					    {
					      if ((car(sc->code) == cadr(cadr(sc->code))) &&
						  (car(cadr(sc->code)) == sc->ADD))
						set_syntax_op(sc->code, sc->INCREMENT_SSS);
					      else set_syntax_op(sc->code, sc->SET_SYMBOL_SAFE_SSS);
					      set_fcdr(sc->code, cdr(cadr(sc->code)));
					    }
					  else
					    {
					      if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_opSSq_S)
						{
						  set_syntax_op(sc->code, sc->SET_SYMBOL_SAFE_opSSq_S);
						  set_fcdr(sc->code, cdadr(sc->code));
						}
					      else
						{
						  if (is_all_x_safe(sc, cadr(sc->code)))
						    {
						      set_syntax_op(sc->code, sc->SET_SYMBOL_ALL_X);
						      annotate_arg(sc, cdr(sc->code));
						    }
						  
						  /* look for increments.  The other two common cases are
						   *   s_opssq and s_opsq: 210832: (+ num (* x1 x2)), 96774: (+ ampsum (abs samp0))
						   */
						  if (car(sc->code) == cadr(cadr(sc->code)))
						    {
						      if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_S_opCq)
							{
							  /* (define (hi) (let ((x 0)) (set! x (+ x (abs -1))) x)) */
							  set_syntax_op(sc->code, sc->INCREMENT_S_opCq); 
							  set_fcdr(sc->code, cdadr(sc->code));
							}
						      else 
							{
							  if (optimize_data(cadr(sc->code)) == HOP_SAFE_C_SZ)
							    {
							      set_syntax_op(sc->code, sc->INCREMENT_SZ);
							      set_fcdr(sc->code, caddr(cadr(sc->code)));
							    }
							}
						    }
						}
					    }
					}
				    }
				}
			    }
			  
			  if ((is_h_optimized(cadr(sc->code))) &&
			      (!is_unsafe(cadr(sc->code))) &&
			      (is_not_null(cdr(cadr(sc->code)))))               /* (set! x (y)) */
			    {
			      if (is_not_null(cddr(cadr(sc->code))))
				{
				  if ((caddr(cadr(sc->code)) == small_int(1)) &&
				      (cadr(cadr(sc->code)) == car(sc->code)))
				    {
				      if ((ecdr(cadr(sc->code)) == add_s1) ||
					  (ecdr(cadr(sc->code)) == add_cs1))
					set_syntax_op(sc->code, sc->INCREMENT_1);
				      else 
					{
					  if ((ecdr(cadr(sc->code)) == subtract_s1) ||
					      (ecdr(cadr(sc->code)) == subtract_cs1))
					    set_syntax_op(sc->code, sc->DECREMENT_1);
					}
				    }
				  else
				    {
				      if ((cadr(cadr(sc->code)) == small_int(1)) &&
					  (caddr(cadr(sc->code)) == car(sc->code)) &&
					  (ecdr(cadr(sc->code)) == add_1s))
					set_syntax_op(sc->code, sc->INCREMENT_1);
				      else
					{
					  if ((car(sc->code) == caddr(cadr(sc->code))) &&
					      (is_symbol(cadr(cadr(sc->code)))) &&
					      (caadr(sc->code) == sc->CONS))
					    {
					      set_syntax_op(sc->code, sc->SET_CONS);
					      set_fcdr(sc->code, cadr(cadr(sc->code)));
					    }
					}
				    }
				}
			      else
				{
				  if ((car(sc->code) == cadr(cadr(sc->code))) &&
				      (caadr(sc->code) == sc->CDR))
				    set_syntax_op(sc->code, sc->SET_CDR);
				}
			    }
			}
		    }
		}
	    }
	}
    }

  return(sc->code);
}




static bool safe_stepper(s7_scheme *sc, s7_pointer expr, s7_pointer vars)
{
  /* 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 (direct_memq(cadr(expr), vars))
    return(false);

  for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p));

  if (is_pair(p))
    {
      if ((is_optimized(p)) &&
	  ((optimize_data(p) & 1) != 0) &&
	  (is_safe_c_op(optimize_data(p))))
	return(true);

      if (direct_memq(car(p), vars))
	return(false);
    }
  else 
    {
      if (direct_memq(p, vars))
	return(false);
    }
  return(true);
}

/* (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (let ((val 1)) (set! val 2) )))
 * (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (let ((val 3)) (set! val i) )))
 * (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (display i)) (newline))
 * (define (hi) (do ((i 0 (+ i 1))) ((= i 10)) (set! i (+ i 1)) (display i)) (newline))
 *
 * (define (hi a) (do ((i 0 (+ i 1))) ((= i a)) (display i)))
 */


static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_pointer var_list, bool *has_set)
{
  /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble
   */
  s7_pointer p;
  /* if (s7_list_length(sc, body) <= 0) return(false); */
  /* fprintf(stderr, "do is safe: %s %s %s\n", DISPLAY(body), DISPLAY(steppers), DISPLAY(var_list)); */

  for (p = body; is_pair(p); p = cdr(p))
    {
      s7_pointer expr;
      expr = car(p);
      if (is_pair(expr))
	{
	  s7_pointer x;
	  x = car(expr);
	  if (is_symbol(x))
	    {
	      if (is_syntactic(x))
		{
		  opcode_t op;
		  s7_pointer func, vars;
		  func = slot_value(global_slot(x));
		  op = (opcode_t)syntax_opcode(func);
		  switch (op)
		    {
		    case OP_QUOTE:
		      break;

		    case OP_LET:
		    case OP_LET_STAR:
		      if (is_symbol(cadr(expr)))
			return(false);

		    case OP_LETREC:
		    case OP_DO:
		      for (vars = cadr(expr); is_pair(vars); vars = cdr(vars))
			{
			  s7_pointer var;
			  var = caar(vars);
			  if ((direct_memq(var, var_list)) ||
			      (direct_memq(var, steppers)))
			    return(false);

			  var_list = cons(sc, var, var_list);
			  sc->x = var_list;
			  if ((is_pair(cdar(vars))) &&
			      (!do_is_safe(sc, cdar(vars), steppers, var_list, has_set)))
			    return(false);
			}

		      if (!do_is_safe(sc, (op == OP_DO) ? cdddr(expr) : cddr(expr), steppers, var_list, has_set))
			return(false);
		      break;

		    case OP_SET:
		      if (!direct_memq(cadr(expr), var_list)) /* is some non-local variable being set? */
			(*has_set) = true;
		      if (!do_is_safe(sc, cddr(expr), steppers, var_list, has_set))
			return(false);
		      if (!safe_stepper(sc, expr, steppers))  /* is any stepper the value saved? */
			return(false);
		      break;
		      
		    case OP_IF:
		    case OP_COND:
		    case OP_CASE:
		    case OP_AND:
		    case OP_OR:
		    case OP_BEGIN:
		      if (!do_is_safe(sc, cdr(expr), steppers, var_list, has_set))
			return(false);
		      break;

		    case OP_WITH_ENV:
		      return(true);

		    default:
		      return(false);
		      break;
		    }
		}
	      else
		{
		  if ((!is_optimized(expr)) ||
		      (is_unsafe(expr)) ||
		      (!do_is_safe(sc, cdr(expr), steppers, var_list, has_set)))
		    /* this is unreasonably retrictive because optimize_expression returns "unsafe"
		     *   even when everything is safe -- it's merely saying it could not find a
		     *   special optimization case for the expression.  
		     */
		    return(false);
		  else
		    {
		      if (is_setter(car(expr))) /* "setter" includes stuff like cons and vector */
			{
			  if (!direct_memq(cadr(expr), var_list))         /* non-local is being changed */
			    {
			      if ((direct_memq(cadr(expr), steppers)) ||  /* stepper is being set? */
				  (!is_pair(cddr(expr))) ||
				  (!is_pair(cdddr(expr))) ||
				  (is_pair(cddddr(expr))) ||
				  (is_symbol(cadddr(expr))) || /* memq cadddr expr steppers? */
				  (is_pair(cadddr(expr))))
				(*has_set) = true;
			    }
			  if (!do_is_safe(sc, cddr(expr), steppers, var_list, has_set))
			    return(false);		      
			  if (!safe_stepper(sc, expr, steppers))
			    return(false);
			}
		    }
		}
	    }
	  else 
	    {
	      return(false); 
	      /* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example
	       *   but that's actually safe since it's just in effect vector-ref
	       *   there are several examples in dlocsig: ((group-speakers group) i) etc
	       */
	    }
	}
    }
  return(true);
}


static bool is_dox_safe(int op)
{
  return((op == HOP_SAFE_C_S) ||
	 (op == HOP_SAFE_C_C) ||
	 (op == HOP_SAFE_C_CS) ||
	 (op == HOP_SAFE_C_SC) ||
	 (op == HOP_SAFE_C_SS) ||
	 (op == HOP_SAFE_C_SSC) ||
	 (op == HOP_SAFE_C_QS) ||
	 (op == HOP_SAFE_C_S_opCq));
}

static bool is_init_dox_safe(s7_scheme *sc, s7_pointer p)
{
  if (!is_pair(p)) return(true);
  if (car(p) == sc->QUOTE) return(true);
  if (!is_optimized(p)) return(false);
  return(is_dox_safe(optimize_data(p)));
}

static bool is_step_dox_safe(s7_scheme *sc, s7_pointer p)
{
  if (!is_pair(p)) return(false);
  if (car(p) == sc->QUOTE) return(false);
  if (!is_optimized(p)) return(false);
  return(is_dox_safe(optimize_data(p)));
}


static bool is_end_dox_safe(s7_scheme *sc, s7_pointer p)
{
  int op;
  
  if (!is_pair(p)) return(false);
  if (car(p) == sc->QUOTE) return(false);
  if (!is_optimized(p)) return(false);

  op = optimize_data(p);
  return((op == HOP_SAFE_C_S) ||
	 (op == HOP_SAFE_C_C) ||
	 (op == HOP_SAFE_C_SS) ||
	 (op == HOP_SAFE_C_SC) ||
	 (op == HOP_SAFE_C_CS) ||
	 (op == HOP_SAFE_C_QS) ||
	 (op == HOP_SAFE_C_S_opCq) ||
	 (op == HOP_SAFE_C_opSq_S) ||
	 (op == HOP_SAFE_C_S_opSq) ||
	 (op == HOP_SAFE_C_opSq_opSq) ||
	 (op == HOP_SAFE_C_S_opSCq) ||
	 (op == HOP_SAFE_C_S_opSSq));
}


typedef s7_pointer (*dox_function)(s7_scheme *sc, s7_pointer args, s7_pointer slot);

static s7_pointer step_dox_c_c(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  return(c_call(code)(sc, cdr(code)));
}

static s7_pointer step_dox_c_c_s_indirect(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T1_1) = slot_value(slot_pending_value(slot));
  return(((s7_function)c_function_call(c_function_base(ecdr(code))))(sc, sc->T1_1));
}

static s7_pointer step_dox_c_s(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T1_1) = finder(sc, cadr(code));
  return(c_call(code)(sc, sc->T1_1));
}

static s7_pointer step_dox_c_s_indirect(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T1_1) = slot_value(slot_pending_value(slot));
  return(c_call(code)(sc, sc->T1_1));
}

static s7_pointer step_dox_c_s_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T1_1) = slot_value(slot);
  return(c_call(code)(sc, sc->T1_1));
}

static s7_pointer step_dox_read_char_s(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer port;
  port = slot_value(slot_pending_value(slot));
  if (is_input_port(port))
    return(chars[port_read_character(port)(sc, port)]);

  car(sc->T1_1) = port;
  return(g_read_char_1(sc, sc->T1_1));
}

static s7_pointer step_dox_c_sc(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_1) = finder(sc, car(args));
  car(sc->T2_2) = cadr(args);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_sc_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = caddr(code);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_cs(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = finder(sc, cadr(args));
  car(sc->T2_1) = car(args);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_cs_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_2) = slot_value(slot);
  car(sc->T2_1) = cadr(code);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_ss(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args, val;
  args = cdr(code);
  val = finder(sc, car(args));
  car(sc->T2_2) = finder(sc, cadr(args));
  car(sc->T2_1) = val;
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_ss_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_add_ss(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_add_2(sc, sc->T2_1));
}

static s7_pointer step_dox_c_subtract_ss(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_subtract_2(sc, sc->T2_1));
}

#if (!WITH_GMP)
static s7_pointer step_dox_c_subtract_i(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  /* this is hard to optimize because macros can cause hidden changes 
   */
  if ((is_integer(slot_value(slot))) &&
      (is_integer(slot_value(slot_pending_value(slot)))))
    return(make_integer(sc, integer(slot_value(slot)) - integer(slot_value(slot_pending_value(slot)))));
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_subtract_2(sc, sc->T2_1));
}

static s7_pointer step_dox_c_subtract_f(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  if ((type(slot_value(slot)) == T_REAL) &&
      (type(slot_value(slot_pending_value(slot))) == T_REAL))
    return(make_real(sc, real(slot_value(slot)) - real(slot_value(slot_pending_value(slot)))));
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_subtract_2(sc, sc->T2_1));
}

static s7_pointer step_dox_c_mutable_subtract_f(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  real(slot_value(slot)) -= real(slot_value(slot_pending_value(slot)));
  return(slot_value(slot));
}

static s7_pointer step_dox_c_mutable_add_f(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  real(slot_value(slot)) += real(slot_value(slot_pending_value(slot)));
  return(slot_value(slot));
}

static s7_pointer step_dox_c_mutable_add1(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  integer(slot_value(slot))++;
  return(slot_value(slot));
}

static s7_pointer step_dox_c_add_i(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  if ((is_integer(slot_value(slot))) &&
      (is_integer(slot_value(slot_pending_value(slot)))))
    return(make_integer(sc, integer(slot_value(slot)) + integer(slot_value(slot_pending_value(slot)))));
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_add_2(sc, sc->T2_1));
}

static s7_pointer step_dox_c_add_f(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  if ((type(slot_value(slot)) == T_REAL) &&
      (type(slot_value(slot_pending_value(slot))) == T_REAL))
    return(make_real(sc, real(slot_value(slot)) + real(slot_value(slot_pending_value(slot)))));
  car(sc->T2_1) = slot_value(slot);
  car(sc->T2_2) = slot_value(slot_pending_value(slot));
  return(g_add_2(sc, sc->T2_1));
}
#endif

static s7_pointer step_dox_c_ssc(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args, val;
  args = cdr(code);
  val = finder(sc, car(args));
  car(sc->T3_2) = finder(sc, cadr(args));
  car(sc->T3_1) = val;
  car(sc->T3_3) = caddr(args);
  return(c_call(code)(sc, sc->T3_1));
}

static s7_pointer step_dox_c_ssc_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T3_1) = slot_value(slot);
  car(sc->T3_2) = slot_value(slot_pending_value(slot));
  car(sc->T3_3) = cadddr(code);
  return(c_call(code)(sc, sc->T3_1));
}

static s7_pointer step_dox_c_ssi_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer a, b;
  a = slot_value(slot);
  b = slot_value(slot_pending_value(slot));
  if ((is_integer(a)) &&
      (is_integer(b)))
    return(make_integer(sc, integer(a) + integer(b) + integer(cadddr(code))));

  car(sc->T3_1) = a;
  car(sc->T3_2) = b;
  car(sc->T3_3) = cadddr(code);
  return(c_call(code)(sc, sc->T3_1));
}

static s7_pointer step_dox_c_qs(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = finder(sc, cadr(args));
  car(sc->T2_1) = cadr(car(args));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_qs_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  car(sc->T2_2) = slot_value(slot);
  car(sc->T2_1) = cadr(cadr(code));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_s_opcq(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args, val;
  args = cdr(code);
  val = finder(sc, car(args));
  car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args)); /* any number of constants here */
  car(sc->T2_1) = val;
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer step_dox_c_s_opcq_direct(s7_scheme *sc, s7_pointer code, s7_pointer slot)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args)); /* any number of constants here */
  car(sc->T2_1) = slot_value(slot);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer dox_add_t1(s7_scheme *sc, s7_pointer args, s7_pointer slot)
{
  s7_pointer x;
  x = slot_value(slot);
  if (is_integer(x))
    return(make_integer(sc, integer(x) + 1));
  if (type(x) == T_REAL)
    return(make_real(sc, real(x) + 1.0));

  car(sc->T2_1) = x;
  car(sc->T2_2) = small_int(1);
  return(g_add_2(sc, sc->T2_1));
}

static s7_pointer dox_sub_t1(s7_scheme *sc, s7_pointer args, s7_pointer slot)
{
  s7_pointer x;
  x = slot_value(slot);
  if (is_integer(x))
    return(make_integer(sc, integer(x) - 1));
  if (type(x) == T_REAL)
    return(make_real(sc, real(x) - 1.0));

  car(sc->T2_1) = x;
  car(sc->T2_2) = small_int(1);
  return(g_subtract_2(sc, sc->T2_1));
}

static s7_pointer dox_add_ti(s7_scheme *sc, s7_pointer args, s7_pointer slot)
{
  s7_pointer x, y;
  
  x = slot_value(slot);
  y = caddr(args);
  if (is_integer(x))
    return(make_integer(sc, integer(x) + integer(y)));

  car(sc->T2_1) = x;
  car(sc->T2_2) = y;
  return(g_add_2(sc, sc->T2_1));
}

static s7_pointer dox_cdr_s(s7_scheme *sc, s7_pointer arg, s7_pointer slot)
{
  return((is_pair(slot_value(slot))) ? cdr(slot_value(slot)) : g_cdr(sc, list_1(sc, slot_value(slot))));
}


static dox_function dox_mutate(s7_scheme *sc, s7_pointer slot)
{
  s7_pointer expr;
  expr = slot_expression(slot);
#if (!WITH_GMP) 
  if ((((dox_function)fcdr(expr)) == step_dox_c_subtract_f) ||
      (((dox_function)fcdr(expr)) == step_dox_c_add_f))
    {
      if ((type(slot_value(slot)) == T_REAL) &&
	  (type(slot_value(slot_pending_value(slot))) == T_REAL))
	{
	  slot_value(slot) = s7_make_mutable_real(sc, real(slot_value(slot)));
	  if (((dox_function)fcdr(expr)) == step_dox_c_subtract_f)
	    return(step_dox_c_mutable_subtract_f);
	  else return(step_dox_c_mutable_add_f);
	}
    }
  else
    {
      if (((dox_function)fcdr(expr)) == dox_add_t1)
	{
	  if (type(slot_value(slot)) == T_INTEGER)
	    {
	      slot_value(slot) = make_mutable_integer(sc, integer(slot_value(slot)));
	      return(step_dox_c_mutable_add1);
	    }
	}
    }
#endif
  return((dox_function)fcdr(expr));
}
		    

static dox_function step_dox_eval(s7_scheme *sc, s7_pointer code, s7_pointer var)
{
  /* called in check_do, var=NULL if this is an init (not a step) check, code is the expr for var */
  switch (optimize_data(code))
    {
    case HOP_SAFE_C_C: 
      if (var == cadr(code))
	{
	  if (fcdr(code) == (s7_pointer)g_add_cs1)
	    return(dox_add_t1);

	  if (fcdr(code) == (s7_pointer)g_subtract_cs1)
	    return(dox_sub_t1);

	  if (fcdr(code) == (s7_pointer)g_add_si)
	    return(dox_add_ti);

	  /* (+ i c) (- i c)?
	   * (+ 1 i) -> cs
	   */
#if 0
	  if (fcdr(code) == (s7_pointer)g_add_sf)
	    return(dox_add_tf);
#endif
	}
      if ((var) &&
	  (is_symbol(cadr(code))) &&
	  (is_null(cddr(code))))
	return(step_dox_c_c_s_indirect);
      return(step_dox_c_c);

    case HOP_SAFE_C_S:       
      if (var == cadr(code))
	{
	  if (fcdr(code) == (s7_pointer)g_cdr)
	    return(dox_cdr_s);
	  return(step_dox_c_s_direct);
	}
      if (var)
	{
	  if (fcdr(code) == (s7_pointer)g_read_char_1)
	    return(step_dox_read_char_s);
	  return(step_dox_c_s_indirect);
	}
      return(step_dox_c_s);

    case HOP_SAFE_C_SSC:     
      if (var == cadr(code))
	{
	  if ((is_integer(cadddr(code))) &&
	      (car(code) == sc->ADD))
	    return(step_dox_c_ssi_direct);
	  return(step_dox_c_ssc_direct);
	}
      return(step_dox_c_ssc);

    case HOP_SAFE_C_SS: 
      if (var == cadr(code))
	{
	  if (c_call(code) == g_add_2) return(step_dox_c_add_ss);
	  if (c_call(code) == g_subtract_2) return(step_dox_c_subtract_ss);
	  return(step_dox_c_ss_direct);
	}
      return(step_dox_c_ss);

    case HOP_SAFE_C_SC:      return((var == cadr(code)) ? step_dox_c_sc_direct : step_dox_c_sc);
    case HOP_SAFE_C_CS:      return((var == caddr(code)) ? step_dox_c_cs_direct : step_dox_c_cs);
    case HOP_SAFE_C_QS:      return((var == caddr(code)) ? step_dox_c_qs_direct : step_dox_c_qs);
    case HOP_SAFE_C_S_opCq:  return((var == cadr(code)) ? step_dox_c_s_opcq_direct : step_dox_c_s_opcq);
    }
  return(NULL);
}


static s7_pointer end_dox_c_c(s7_scheme *sc, s7_pointer code)
{
  return(c_call(code)(sc, cdr(code)));
}

static s7_pointer end_dox_c_s(s7_scheme *sc, s7_pointer code)
{
  car(sc->T1_1) = slot_value(environment_dox1(sc->envir));
  return(c_call(code)(sc, sc->T1_1));
}

static s7_pointer end_dox_c_sc(s7_scheme *sc, s7_pointer code)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_2) = cadr(args);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_cs(s7_scheme *sc, s7_pointer code)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_1) = car(args);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_ss(s7_scheme *sc, s7_pointer code)
{
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_qs(s7_scheme *sc, s7_pointer code)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_1) = cadr(car(args));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_s_opcq(s7_scheme *sc, s7_pointer code)
{
  s7_pointer args;
  args = cdr(code);
  car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args)); /* any number of constants here */
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_opsq_s(s7_scheme *sc, s7_pointer code)
{
  car(sc->T1_1) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
  car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_s_opsq(s7_scheme *sc, s7_pointer code)
{
  car(sc->T1_1) = slot_value(environment_dox2(sc->envir));
  car(sc->T2_2) = c_call(caddr(code))(sc, sc->T1_1);
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_opsq_opsq(s7_scheme *sc, s7_pointer code)
{
  car(sc->T1_1) = slot_value(environment_dox1(sc->envir));
  car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
  car(sc->T1_1) = slot_value(environment_dox2(sc->envir));
  car(sc->T2_2) = c_call(caddr(code))(sc, sc->T1_1);
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_s_opscq(s7_scheme *sc, s7_pointer code)
{
  car(sc->T2_1) = slot_value(environment_dox2(sc->envir));
  car(sc->T2_2) = caddr(caddr(code));
  car(sc->T2_2) = c_call(caddr(code))(sc, sc->T2_1);
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_c_s_opssq(s7_scheme *sc, s7_pointer code)
{
  car(sc->T2_1) = slot_value(environment_dox2(sc->envir));
  car(sc->T2_2) = finder(sc, caddr(caddr(code)));
  car(sc->T2_2) = c_call(caddr(code))(sc, sc->T2_1);
  car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
  return(c_call(code)(sc, sc->T2_1));
}

static s7_pointer end_dox_is_eof(s7_scheme *sc, s7_pointer code)
{
  return(make_boolean(sc, slot_value(environment_dox1(sc->envir)) == sc->EOF_OBJECT));
}

static s7_pointer end_dox_equal_s_ic(s7_scheme *sc, s7_pointer code)
{
  s7_pointer x;
  x = slot_value(environment_dox1(sc->envir));
  if (is_integer(x))
    return(make_boolean(sc, integer(x) == integer(caddr(code))));
  if (is_real(x))
    return(make_boolean(sc, real(x) == integer(caddr(code))));
  return(sc->F);
}

static s7_pointer end_dox_or_not_ic(s7_scheme *sc, s7_pointer code)
{
  s7_pointer x;

  x = slot_value(environment_dox1(sc->envir));
  if (is_false(sc, x))
    return(sc->T);

  x = slot_value(environment_dox2(sc->envir));
  if (is_integer(x))
    return(make_boolean(sc, integer(x) == integer(caddr(caddr(code)))));
  if (is_real(x))
    return(make_boolean(sc, real(x) == integer(caddr(caddr(code)))));
  return(sc->F);
}

static s7_pointer end_dox_or_not_ss(s7_scheme *sc, s7_pointer code)
{
  s7_pointer x;

  x = slot_value(environment_dox1(sc->envir));
  if (is_false(sc, x))
    return(sc->T);

  x = caddr(code);
  car(sc->T2_1) = slot_value(environment_dox2(sc->envir));
  car(sc->T2_2) = finder(sc, caddr(x));
  return(c_call(x)(sc, sc->T2_1));
}

static s7_function end_dox_eval(s7_scheme *sc, s7_pointer code)
{
  switch (optimize_data(code))
    {
    case HOP_SAFE_C_C: 
      if (fcdr(code) == (s7_pointer)g_equal_s_ic)
	{
	  set_optimize_data(code, HOP_SAFE_C_SC); /* so the dox init section will pass us the cadr slot */
	  return(end_dox_equal_s_ic);
	}					
      if (fcdr(code) == (s7_pointer)g_or_all_x)
	{
	  /* code is the full expr: (or (not happy) (= i 512)) 
	   */
	  if (s7_list_length(sc, code) == 3)
	    {
	      s7_pointer arg1, arg2;
	      arg1 = cadr(code);
	      arg2 = caddr(code);
	      if ((is_pair(arg1)) &&
		  (is_pair(arg2)) &&
		  (car(arg1) == sc->NOT) &&
		  (is_symbol(cadr(arg1))))
		{
		  if (fcdr(arg2) == (s7_pointer)g_equal_s_ic)
		    {
		      set_optimize_data(code, HOP_SAFE_C_opSq_opSq);
		      return(end_dox_or_not_ic);
		    }
		  if ((fcdr(arg2) == (s7_pointer)g_equal_2) &&
		      (is_symbol(cadr(arg2))) &&
		      (is_symbol(caddr(arg2))))
		    {
		      set_optimize_data(code, HOP_SAFE_C_opSq_opSq);
		      return(end_dox_or_not_ss);
		    }
		}
	    }
	}
      return(end_dox_c_c);

    case HOP_SAFE_C_S:       
      if (fcdr(code) == (s7_pointer)g_is_eof_object)
	return(end_dox_is_eof);
      return(end_dox_c_s);

    case HOP_SAFE_C_SC:        return(end_dox_c_sc);
    case HOP_SAFE_C_CS:        return(end_dox_c_cs);
    case HOP_SAFE_C_SS:        return(end_dox_c_ss);
    case HOP_SAFE_C_QS:        return(end_dox_c_qs);
    case HOP_SAFE_C_S_opCq:    return(end_dox_c_s_opcq);
    case HOP_SAFE_C_opSq_S:    return(end_dox_c_opsq_s);
    case HOP_SAFE_C_opSq_opSq: return(end_dox_c_opsq_opsq);
    case HOP_SAFE_C_S_opSq:    return(end_dox_c_s_opsq);
    case HOP_SAFE_C_S_opSCq:   return(end_dox_c_s_opscq);
    case HOP_SAFE_C_S_opSSq:   return(end_dox_c_s_opssq);
    }
  return(NULL);
}


static s7_pointer g_mutable_add1(s7_scheme *sc, s7_pointer args)
{
  integer(car(args))++;
  return(car(args));
}


static s7_pointer g_mutable_subtract1(s7_scheme *sc, s7_pointer args)
{
  integer(car(args))--;
  return(car(args));
}


enum {DOX_STEP_DEFAULT, DOX_STEP_SS, DOX_STEP_S, DOX_STEP_ADD, DOX_STEP_SUBTRACT};

static s7_pointer check_do(s7_scheme *sc)
{
  s7_pointer x;
  
  if ((!is_pair(sc->code)) ||                             /* (do . 1) */
      ((!is_pair(car(sc->code))) &&                       /* (do 123) */
       (is_not_null(car(sc->code)))))                     /* (do () ...) is ok */
    return(eval_error(sc, "do: var list is not a list: ~S", sc->code));
  
  if (!is_pair(cdr(sc->code)))                            /* (do () . 1) */
    return(eval_error(sc, "do body is messed up: ~A", sc->code));
  
  if ((!is_pair(cadr(sc->code))) &&                       /* (do ((i 0)) 123) */
      (is_not_null(cadr(sc->code))))                      /* no end-test? */
    return(eval_error(sc, "do: end-test and end-value list is not a list: ~A", sc->code));
  
  if (is_pair(car(sc->code)))
    {
      for (x = car(sc->code); is_pair(x); x = cdr(x))
	{
	  if (!(is_pair(car(x))))                         /* (do (4) (= 3)) */
	    return(eval_error(sc, "do: variable name missing? ~A", sc->code));

	  if (!is_symbol(caar(x)))                     /* (do ((3 2)) ()) */
	    return(eval_error(sc, "do step variable: ~S is not a symbol?", x));

	  if (is_immutable(caar(x)))                     /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */
	    return(eval_error(sc, "do step variable: ~S is immutable", x));
	  
	  if (is_pair(cdar(x)))
	    {
	      if ((!is_pair(cddar(x))) &&
		  (is_not_null(cddar(x))))               /* (do ((i 0 . 1)) ...) */
		return(eval_error(sc, "do: step variable info is an improper list?: ~A", sc->code));
	      
	      if ((is_pair(cddar(x))) && 
		  (is_not_null(cdr(cddar(x)))))          /* (do ((i 0 1 (+ i 1))) ...) */
		return(eval_error(sc, "do: step variable info has extra stuff after the increment: ~A", sc->code));
	    }
	  else return(eval_error(sc, "do: step variable has no initial value: ~A", x));

	  set_local(caar(x));

	  /* (do ((i)) ...) */
	}

      if (is_not_null(x))                                /* (do ((i 0 i) . 1) ((= i 1))) */
	return(eval_error(sc, "do: list of variables is improper: ~A", sc->code));
    }

  if (is_pair(cadr(sc->code)))
    {
      for (x = cadr(sc->code); is_pair(x); x = cdr(x));
      if (is_not_null(x))
	return(eval_error(sc, "stray dot in do end section? ~A", sc->code));
    }

  for (x = cddr(sc->code); is_pair(x); x = cdr(x));
  if (is_not_null(x))
    return(eval_error(sc, "stray dot in do body? ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      s7_pointer vars, end, body;
      bool one_line;

      vars = car(sc->code);
      end = cadr(sc->code);
      body = cddr(sc->code);
      
      one_line = ((safe_list_length(sc, body) == 1) && (is_pair(car(body))));

      set_syntax_op(sc->code, sc->DO_UNCHECKED);

      /* (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (display i)) (newline)) */
      
      /* fprintf(stderr, "do %s %s\n", DISPLAY(body), opt_name(car(body))); */
      
      /* (define (hi) (do ((i 1.5 (+ i 1))) ((= i 2.5)) (display i) (newline)))
       *   in OP_SAFE_DOTIMES, for example, if init value is not an integer, it goes to OP_SIMPLE_DO
       * remaining optimizable cases: we can step by 1 and use = for end, and yet simple_do(_p) calls the functions
       * geq happens as often as =, and -1 as step
       * also cdr as step to is_null as end
       * also what about no do-var cases? (do () ...)
       *
       * also do body is optimized expr: vector_set_3 via hop_safe_c_sss for example or (vset v i (vref w i))
       */
      if ((is_pair(end)) && (is_pair(car(end))) &&
	  (is_pair(vars)) &&
	  (is_null(cdr(vars))))
	{
	  /* loop has one step variable, and normal-looking end test
	   */
	  vars = car(vars);
	  if (symbol_has_accessor(car(vars)))
	    return(sc->code);
	  
	  if ((safe_list_length(sc, vars) == 3) &&
	      ((!is_pair(cadr(vars))) ||
	       ((is_optimized(cadr(vars))) &&
		(optimize_data(cadr(vars)) == HOP_SAFE_C_C))))
	    {
	      s7_pointer step_expr;
	      step_expr = caddr(vars);
	      
	      if ((is_optimized(step_expr)) &&
		  (((optimize_data(step_expr) == HOP_SAFE_C_SC) && (car(vars) == cadr(step_expr))) ||
		   ((optimize_data(step_expr) == HOP_SAFE_C_C) && (car(vars) == cadr(step_expr)) && 
		    ((ecdr(step_expr) == add_cs1) || (ecdr(step_expr) == subtract_cs1))) ||
		   ((optimize_data(step_expr) == HOP_SAFE_C_CS) && (car(vars) == caddr(step_expr)))))
		{
		  /* step var is (var const|symbol (op var const)|(op const var)) 
		   */
		  end = car(end);

		  if ((is_optimized(end)) &&
		      (car(vars) == cadr(end)) &&
		      (cadr(end) != caddr(end)) &&
		      ((ecdr(end) == equal_s_ic) ||
		       (optimize_data(end) == HOP_SAFE_C_SS) || 
		       (optimize_data(end) == HOP_SAFE_C_SC)))
		    {
		      /* end var is (op var const|symbol) using same var as step 
		       *   so at least we can use SIMPLE_DO
		       */
		      bool has_set = false;
		      
		      if (ecdr(step_expr) == add_cs1)
			{
			  set_c_function(step_expr, add_s1);
			  set_optimize_data(step_expr, HOP_SAFE_C_SC);
			}
		      if (ecdr(step_expr) == subtract_cs1)
			{
			  set_c_function(step_expr, subtract_s1);
			  set_optimize_data(step_expr, HOP_SAFE_C_SC);
			}
		      if (ecdr(end) == equal_s_ic)
			{
			  set_c_function(end, equal_2);
			  set_optimize_data(end, HOP_SAFE_C_SC);
			}
		      
		      if ((ecdr(step_expr) == add_s1) &&
			  (ecdr(end) == equal_2) &&
			  (s7_is_integer(caddr(step_expr))) &&
			  (s7_integer(caddr(step_expr)) == 1))
			set_syntax_op(sc->code, sc->SIMPLE_DO_A);
		      else set_syntax_op(sc->code, sc->SIMPLE_DO);

		      if ((one_line) &&
			  ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_C)) &&
			  (is_syntactic(caar(body))))
			{
			  lifted_op(car(body)) = syntax_opcode(caar(body));
			  /* fprintf(stderr, "choose simple_do_p\n"); */
			  set_syntax_op(sc->code, sc->SIMPLE_DO_P);
			  set_fcdr(sc->code, caddr(caar(sc->code)));
#if (!WITH_GMP)
			  if ((s7_is_integer(caddr(step_expr))) &&
			      (s7_integer(caddr(step_expr)) == 1) &&
			      (c_function_class(ecdr(step_expr)) == add_class) &&
			      /* we check above that (car(vars) == cadr(step_expr))
			       *    and that         (car(vars) == cadr(end))
			       */
			      ((c_function_class(ecdr(end)) == equal_class) ||
			       (ecdr(end) == geq_2)))
			    set_syntax_op(sc->code, sc->DOTIMES_P);
#endif
			}
		      
		      if (do_is_safe(sc, body, sc->w = list_1(sc, car(vars)), sc->NIL, &has_set))
			{
			  /* now look for the very common dotimes case
			   */
			  if ((((s7_is_integer(caddr(step_expr))) &&
				(s7_integer(caddr(step_expr)) == 1)) ||
			       ((s7_is_integer(cadr(step_expr))) &&
				(s7_integer(cadr(step_expr)) == 1))) &&
			      (c_function_class(ecdr(step_expr)) == add_class) &&
#if WITH_GMP
			      (c_function_class(ecdr(end)) == equal_class)
#else
			      ((c_function_class(ecdr(end)) == equal_class) ||
			       (ecdr(end) == geq_2))
#endif
			      )
			    {
			      /* we're stepping by +1 and going to =
			       *   the final integer check has to wait until run time (symbol value dependent)
			       */
			      set_syntax_op(sc->code, sc->SAFE_DO);
			      
			      if ((!has_set) &&
				  (c_function_class(ecdr(end)) == equal_class))
				{
				  /* fprintf(stderr, "dotimes\n"); */
				  set_syntax_op(sc->code, sc->SAFE_DOTIMES);
				  
				  /* what are the most common cases here?
				   */
				  
				  if (one_line)
				    {
				      if ((is_optimized(car(body))) &&
					  (optimize_data(car(body)) == HOP_SAFE_C_C))
					{
					  /* fprintf(stderr, "dotimes_c_c: %s\n", DISPLAY(body)); */
					  set_syntax_op(sc->code, sc->SAFE_DOTIMES_C_C);
					}
				      else
					{
					  /* fprintf(stderr, "car(body): %s, step_expr: %s\n", DISPLAY(car(body)), DISPLAY(vars)); */
					  if ((is_optimized(car(body))) &&
					      /* (cadar(body) != car(vars)) && */
					      /* not sure this matters -- trying to avoid special slots for step vars */
					      (is_all_x_op(optimize_data(car(body)))))
					    {
					      /* fprintf(stderr, "dotimes_c_a: %s %s\n", DISPLAY(body), opt_name(car(body))); */
					      set_syntax_op(sc->code, sc->SAFE_DOTIMES_C_A);
					    }
					  else
					    {
					      /* fprintf(stderr, "perhaps safe: %s\n", DISPLAY(body)); */
					      if ((is_syntactic(caar(body))) &&
						  (syntax_opcode(caar(body)) == OP_LET) &&
						  (!is_null(cadar(body))) && /* it has at least one let var */
						  (is_null(cdadar(body))))   /* but only one */
						{
						  s7_pointer x;
						  x = cddar(body);
						  
						  if ((is_pair(car(x))) &&
						      (is_optimized(car(x))) &&
						      (is_null(cdr(x))) && /* one liner? */
						      (optimize_data(car(x)) == HOP_SAFE_C_C))
						    {
						      x = cadar(cadar(body));
						      if ((is_pair(x)) &&
							  (is_optimized(x)) &&
							  (returns_temp(ecdr(x))) &&
							  (optimize_data(x) == HOP_SAFE_C_C)) /* all_x_safe doesn't happen much here */
							set_syntax_op(sc->code, sc->SIMPLE_SAFE_DOTIMES);
						    }
						}
					    }
					}
				    }
				  /*
				    if (car(ecdr(sc->code)) == sc->DOTIMES_P)
				    fprintf(stderr, "oops\n");
				  */
				}
			      /* else fprintf(stderr, "unsafe: %s\n", DISPLAY_80(sc->code)); */
			    }
			}
		      return(sc->NIL); /* tell OP_DO that this is a special case */
		    }
		}
	    }
	}

      /* we get here if there is more than one local var or anything "non-simple" about the rest 
       */
      /* (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (display i)) (newline)) 
       * (define (hi) (do ((i 0 (+ i 1)) (j 1 (+ j 1))) ((= i 3)) (display j))(newline))
       */
      
      vars = car(sc->code);
      end = cadr(sc->code);
      body = cddr(sc->code);
      
      if ((is_null(vars)) && /* do () () one-line safe opt body */
	  (is_null(end)) &&
	  (one_line) &&
	  (is_all_x_safe(sc, car(body))))
	{
	  annotate_arg(sc, body);
	  set_syntax_op(sc->code, sc->SIMPLE_DO_FOREVER);
	  return(sc->NIL);
	}
      
      /* check end expression first */
      if (!is_end_dox_safe(sc, car(end)))
	{
	  if ((is_pair(car(end))) &&
	      (is_syntactic(caar(end))) &&
	      (syntax_opcode(caar(end)) == OP_OR))
	    {
	      s7_pointer old_code;
	      old_code = sc->code;
	      sc->code = cdar(end);
	      check_or(sc);
	      sc->code = old_code;
	      return(sc->code);
	    }
	  else 
	    {
	      /* fprintf(stderr, "end: %s %s\n", DISPLAY(car(end)), (is_optimized(car(end))) ? opt_names[optimize_data(car(end))] : ""); */
	      return(sc->code);
	    }
	}

      /* vars can be nil (no steppers) */
      if (is_pair(vars))
	{
	  s7_pointer p, rp;
	  for (p = vars; is_pair(p); p = cdr(p))
	    {
	      s7_pointer var;
	      var = car(p);

	      if (!is_init_dox_safe(sc, cadr(var)))
		{
		  /* fprintf(stderr, "init: %s %s\n", DISPLAY(cadr(var)), (is_optimized(cadr(var))) ? opt_names[optimize_data(cadr(var))] : ""); */
		  return(sc->code);
		}
	      
	      if ((is_pair(cddr(var))) &&
		  (!is_step_dox_safe(sc, caddr(var))))
		{
		  /* fprintf(stderr, "step: %s %s\n", DISPLAY(caddr(var)), (is_optimized(caddr(var))) ? opt_names[optimize_data(caddr(var))] : ""); */
		  return(sc->code);
		}
	      /* we want to use the pending_value slot for other purposes, so make sure
	       *   the current val is not referred to in any trailing step exprs.  The inits
	       *   are ok because at init-time, the new frame is not connected.
	       *
	       * another tricky case: current var might be used in previous step expr(!)
	       */
	      var = car(var);
	      if (symbol_has_accessor(var))
		return(sc->code);
	      for (rp = vars; is_pair(rp); rp = cdr(rp)) /* look both back and forward for cross-talk */
		if ((rp != p) && 
		    (s7_tree_memq(sc, var, cddar(rp))))
		  {
		    /* fprintf(stderr, "%s found in %s\n", DISPLAY(var), DISPLAY(rp)); */
		    return(sc->code);
		  }
	    }
	}
      
      /* end and steps look ok! */
      set_syntax_op(sc->code, sc->DOX);
      set_fcdr(sc->code, car(end));      /* end expr */
      set_fcdr(cdr(sc->code), (s7_pointer)end_dox_eval(sc, fcdr(sc->code))); 

      /* each step expr is safe so not an explicit set!
       */
      if (is_pair(vars))
	{
	  s7_pointer p;
	  for (p = vars; is_pair(p); p = cdr(p))
	    {
	      s7_pointer var;
	      var = car(p);

	      if ((is_pair(cadr(var))) &&
		  (caadr(var) != sc->QUOTE))
		set_fcdr(cdr(var), (s7_pointer)step_dox_eval(sc, cadr(var), NULL));         /* init choice */

	      if (is_pair(cddr(var)))
		{
		  dox_function f;
		  f = step_dox_eval(sc, caddr(var), car(var));                           /* step choice */
		  set_fcdr(cddr(var), (s7_pointer)f);

		  if ((f == step_dox_c_ss_direct) ||
		      (f == step_dox_c_ssc_direct) ||
		      (f == step_dox_c_ssi_direct))
		    lifted_op(cddr(var)) = DOX_STEP_SS;
		  else
		    {
		      if ((f == step_dox_c_s_indirect) ||
			  (f == step_dox_c_c_s_indirect) ||
			  (f == step_dox_read_char_s))
			lifted_op(cddr(var)) = DOX_STEP_S;
#if (WITH_GMP)
		      else lifted_op(cddr(var)) = DOX_STEP_DEFAULT;
#else
		      else
			{
			  if ((f == step_dox_c_add_ss) ||
			      (f == step_dox_c_add_f) ||
			      (f == step_dox_c_add_i))
			    lifted_op(cddr(var)) = DOX_STEP_ADD;
			  else
			    {
			      if ((f == step_dox_c_subtract_ss) ||
				  (f == step_dox_c_subtract_i) ||
				  (f == step_dox_c_subtract_f))
				lifted_op(cddr(var)) = DOX_STEP_SUBTRACT;
			      else lifted_op(cddr(var)) = DOX_STEP_DEFAULT;
			    }
			}
#endif
		    }
		}
	    }
	}
      /* step var is mutable if it does not occur in the body, or only occurs outside a setter/closure
       *   or it's only an index in a setter, 
       *   and there are no unexpanded macros or unknown ops (implicit indexing).
       * We'd pass that as arg to step_dox_eval, then choose init/step funcs that do not allocate after the init
       */

      /* if ((fcdr(cdr(sc->code)) == end_dox_c_ss) &&
	     (fcdr(fcdr(sc->code)) == g_equal_2) &&
	     (body_is_dox_safe(sc, body, cdr(fcdr(sc->code)))) &&
             (!tree_memq(sc, vars, caddr(fcdr(sc->code)))) &&
	     (fcdr(step_expr_of_cadr) == g_add_t1 or g_add_csi))
         -- yow!
      */
      return(sc->NIL);
    }
  return(sc->code);
}


static s7_pointer check_defmacro(s7_scheme *sc)
{
  s7_pointer x, y, z;
  if (!is_pair(sc->code))                                               /* (defmacro . 1) */
    return(eval_error_with_name(sc, "~A name missing (stray dot?): ~A", sc->code));
  
  x = car(sc->code);
  if (!is_symbol(x))                                             /* (defmacro) or (defmacro 1 ...) */
    return(eval_error_with_name(sc, "~A name: ~S is not a symbol?", x));     
  
  if (is_immutable(x))
    return(eval_error_with_name(sc, "~A: ~S is immutable", x)); /* (defmacro pi (a) `(+ ,a 1)) */
  
  z = cdr(sc->code);
  if (!is_pair(z))                                                  /* (defmacro a) */
    return(eval_error_with_name(sc, "~A ~A, but no args or body?", sc->code));
  
  y = car(z);            /* the arglist */
  if ((!s7_is_list(sc, y)) &&
      (!is_symbol(y)))
    return(s7_error(sc, sc->SYNTAX_ERROR,                               /* (defmacro mac "hi" ...) */
		    list_3(sc, make_protected_string(sc, "defmacro ~A argument list is ~S?"), x, y)));
  
  for ( ; is_pair(y); y = cdr(y))
    if ((!is_symbol(car(y))) &&
	(sc->op == OP_DEFMACRO))
      return(s7_error(sc, sc->SYNTAX_ERROR,                             /* (defmacro mac (1) ...) */
		      list_3(sc, make_protected_string(sc, "defmacro ~A argument name is not a symbol: ~S"), x, y)));
  
  /* other parameter error checks are handled by lambda/lambda* (see OP_LAMBDA above) at macro expansion time */
  
  if (!is_pair(cdr(z)))
    {
      if (is_null(cdr(z)))                                             /* (defmacro hi ()) */
	return(eval_error_with_name(sc, "~A ~A has no body?", x));
      return(eval_error_with_name(sc, "~A ~A has stray dot?", x));
    }

  optimize_lambda(sc, sc->op == OP_DEFMACRO, x, cdar(sc->code), cdr(sc->code));

  return(sc->code);
}


static s7_pointer check_define_macro(s7_scheme *sc)
{
  s7_pointer x;
  if (!is_pair(sc->code))                                               /* (define-macro . 1) */
    return(eval_error_with_name(sc, "~A name missing (stray dot?): ~A", sc->code));
  if (!is_pair(car(sc->code)))                                          /* (define-macro a ...) */
    return(s7_wrong_type_arg_error(sc, op_names[(int)(sc->op)], 1, car(sc->code), "a list (name ...)"));
  
  x = caar(sc->code);
  if (!is_symbol(x))
    return(eval_error_with_name(sc, "~A: ~S is not a symbol?", x));
  if (dont_eval_args(x))                                            /* (define-macro (quote a) quote) */
    return(eval_error_with_name(sc, "~A: syntactic keywords (such as ~S) tend to behave badly if redefined", x));
  
  if (is_immutable(x))
    return(eval_error_with_name(sc, "~A: ~S is immutable", x));
  
  if (!is_pair(cdr(sc->code)))                /* (define-macro (...)) */
    return(eval_error_with_name(sc, "~A ~A, but no body?", x));
  
  sc->y = cdar(sc->code);            /* the arglist */
  if ((!s7_is_list(sc, sc->y)) &&
      (!is_symbol(sc->y)))
    return(s7_error(sc, sc->SYNTAX_ERROR,                                      /* (define-macro (mac . 1) ...) */
		    list_3(sc, make_protected_string(sc, "define-macro ~A argument list is ~S?"), x, sc->y)));
  
  for ( ; is_pair(sc->y); sc->y = cdr(sc->y))
    if ((!is_symbol(car(sc->y))) &&
	((sc->op == OP_DEFINE_MACRO) || (sc->op == OP_DEFINE_BACRO)))
      return(s7_error(sc, sc->SYNTAX_ERROR,                                    /* (define-macro (mac 1) ...) */
		      list_3(sc, make_protected_string(sc, "define-macro ~A argument name is not a symbol: ~S"), x, sc->y)));

  optimize_lambda(sc, (sc->op == OP_DEFINE_MACRO) || (sc->op == OP_DEFINE_BACRO), x, cdar(sc->code), cdr(sc->code));
  return(sc->code);
}


static s7_pointer check_cond(s7_scheme *sc)
{
  bool has_feed_to = false;
  s7_pointer x;
  if (!is_pair(sc->code))                                             /* (cond) or (cond . 1) */
    return(eval_error(sc, "cond, but no body: ~A", sc->code));

  for (x = sc->code; is_pair(x); x = cdr(x))
    {
      if (!is_pair(car(x)))                                           /* (cond 1) or (cond (#t 1) 3) */
	return(eval_error(sc, "every clause in cond must be a list: ~A", car(x)));
      else
	{
	  s7_pointer y;
	  y = car(x);
	  if ((!is_pair(cdr(y))) && (!is_null(cdr(y))))               /* (cond (1 . 2)) */
	    return(eval_error(sc, "cond: stray dot? ~A", sc->code));
	  if ((cadr(y) == sc->FEED_TO) &&
	      (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
	    {
	      has_feed_to = true;
	      if (!is_pair(cddr(y)))                                  /* (cond (#t =>)) or (cond (#t => . 1)) */
		return(eval_error(sc, "cond: '=>' target missing?  ~A", x));
	      if (is_pair(cdddr(y)))                                  /* (cond (1 => + abs)) */
		return(eval_error(sc, "cond: '=>' has too many targets: ~A", x));
	    }
	  /* currently we accept:
	   *     (cond (1 2) (=> . =>)) and all variants thereof, e.g. (cond (1 2) (=> 1 . 2) (1 2)) or 
	   *     (cond (1) (=>)) but Guile accepts this?
	   *     (cond (1) (1 =>))
	   * amusing (correct) case: (cond (1 => "hi")) -> #\i
	   */
	}
    }
  if (is_not_null(x))                                             /* (cond ((1 2)) . 1) */
    return(eval_error(sc, "cond: stray dot? ~A", sc->code));

  if ((is_overlaid(sc->code)) &&
      (cdr(ecdr(sc->code)) == sc->code))
    {
      if (has_feed_to)
	set_syntax_op(sc->code, sc->COND_UNCHECKED);
      else 
	{
	  s7_pointer p;
	  bool xopt = true;
	  set_syntax_op(sc->code, sc->COND_SIMPLE);
	  
	  for (p = sc->code; (xopt) && (is_pair(p)); p = cdr(p))
	    xopt = is_all_x_safe(sc, caar(p));

	  if (xopt)
	    {
	      set_syntax_op(sc->code, sc->COND_ALL_X);
	      for (p = sc->code; is_pair(p); p = cdr(p))
		set_fcdr(car(p), (s7_pointer)cond_all_x_eval(sc, caar(p))); /* handle 'else' specially here */
	    }
	}
    }
  return(sc->code);
}


#if (!WITH_GCC)

static s7_pointer fs(s7_scheme *sc, s7_pointer hdl)
{
  /* like finder, but no unbound-variable error */
  s7_pointer x;	

  if (environment_id(sc->envir) == symbol_id(hdl))
    return(slot_value(local_slot(hdl)));

  for (x = sc->envir; symbol_id(hdl) < environment_id(x); x = next_environment(x));

  if (environment_id(x) == symbol_id(hdl))
    return(slot_value(local_slot(hdl)));	

  for (; is_environment(x); x = next_environment(x))
    {
      s7_pointer y; 
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
	if (slot_symbol(y) == hdl)
	  return(slot_value(y)); 
    }
  x = global_slot(hdl);	
  if (is_not_null(x)) 
    return(slot_value(x)); 
  return(sc->UNDEFINED);
}

#define closure_is_ok(Sc, Code, Type, Args)          (fs(Sc, car(Code)) == ecdr(Code))
#define closure_star_is_ok(Sc, Code, Type, Args)     (fs(Sc, car(Code)) == ecdr(Code))
#define one_line_closure_is_ok(Sc, Code, Type, Args) (fs(Sc, car(Code)) == ecdr(Code))

#else

static s7_pointer fs(s7_scheme *sc, s7_pointer hdl)
{
  /* like finder, but no unbound-variable error */
  s7_pointer x;	

  for (x = sc->envir; symbol_id(hdl) < environment_id(x); x = next_environment(x));

  if (environment_id(x) == symbol_id(hdl))
    return(slot_value(local_slot(hdl)));	

  for (; is_environment(x); x = next_environment(x))
    {
      s7_pointer y; 
      for (y = environment_slots(x); is_slot(y); y = next_slot(y))	
	if (slot_symbol(y) == hdl)
	  return(slot_value(y)); 
    }
  x = global_slot(hdl);	
  if (is_not_null(x)) 
    return(slot_value(x)); 
  return(sc->UNDEFINED);
}


/* it is almost never the case that we already have the value and can see it in the current environment directly,
 * but once found, the value usually matches the current (ecdr(code))
 */


#define closure_is_ok(Sc, Code, Type, Args) \
  ({ s7_pointer _code_, _val_; _code_ = Code; _val_ = fs(Sc, car(_code_)); \
     ((_val_ == ecdr(_code_)) || \
      ((typesflag(_val_) == (unsigned short)Type) &&			\
       ((closure_arity(_val_) == Args) || (closure_arity_to_int(Sc, _val_) == Args)) && \
       (set_ecdr(_code_, _val_)))); })

#define one_line_closure_is_ok(Sc, Code, Type, Args)			\
      ({ s7_pointer _val_; _val_ = fs(Sc, car(Code)); \
       ((_val_ == ecdr(Code)) || \
        ((typeflag(_val_) == (Type | T_ONE_LINER | T_COPY_ARGS)) &&	\
         ((closure_arity(_val_) == Args) || (closure_arity_to_int(Sc, _val_) == Args)) && \
         (set_ecdr(Code, _val_)))); })
/* T_ONE_LINER is on if the body has only one form, T_COPY_ARGS is on in both UNSAFE and SAFE closures (but not on in the closure* cases)
 *   we ignore T_COPY_ARGS above because it is redundant given _STAR and it is not in the lower 2 bytes.
 */

#define closure_star_is_ok(Sc, Code, Type, Args) \
  ({ s7_pointer _val_; _val_ = fs(Sc, car(Code));			\
     ((_val_ == ecdr(Code)) || \
      ((typesflag(_val_) == (unsigned short)Type) &&			\
       ((closure_arity(_val_) >= Args) || (closure_star_arity_to_int(Sc, _val_) >= Args)) && \
       (set_ecdr(Code, _val_)))); })

#endif

#define MATCH_UNSAFE_CLOSURE      (T_CLOSURE |      T_PROCEDURE)
#define MATCH_SAFE_CLOSURE        (T_CLOSURE |      T_PROCEDURE | T_SAFE_CLOSURE)
#define MATCH_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_PROCEDURE)
#define MATCH_SAFE_CLOSURE_STAR   (T_CLOSURE_STAR | T_PROCEDURE | T_SAFE_CLOSURE)

/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */


static void annotate_expansion(s7_scheme *sc, s7_pointer p)
{
  s7_pointer x;
  /* p might not be a pair:
   *   (define-expansion (whatever->zero . whatever) 0)
   *   (+ 1 (whatever->zero 2 3) 4)
   *   5
   */
  if (is_pair(p))
    {
      if ((is_symbol(car(p))) &&
	  (is_pair(cdr(p))))
	{
	  set_ecdr(cdr(p), p);
	  set_overlay(cdr(p));
	}
      else
	{
	  if (is_pair(car(p)))
	    annotate_expansion(sc, car(p));
	}
      for (x = cdr(p); is_pair(x); x = cdr(x))
	if (is_pair(car(x)))
	  annotate_expansion(sc, car(x));
    }
}


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)
   */
  
  switch (type(obj))
    {
    case T_VECTOR:                       /* (#(#(1 2) #(3 4)) 1 1) -> 4 */
      return(vector_ref_1(sc, obj, indices)); 
      
    case T_STRING:                       /* (#("12" "34") 0 1) -> #\2 */
      if (is_null(cdr(indices)))
	return(string_ref_1(sc, obj, car(indices)));
      return(s7_error(sc, 
		      sc->WRONG_NUMBER_OF_ARGS, 
		      list_3(sc, sc->TOO_MANY_ARGUMENTS, obj, indices)));
      
    case T_PAIR:                         /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */
      obj = list_ref_1(sc, obj, car(indices));
      if (is_pair(cdr(indices)))
	return(implicit_index(sc, obj, cdr(indices)));
      return(obj);

    case T_HASH_TABLE:                   /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */
      obj = s7_hash_table_ref(sc, obj, car(indices));
      if (is_pair(cdr(indices)))
	return(implicit_index(sc, obj, cdr(indices)));
      return(obj);

    case T_C_OBJECT:                     /* ((vector (vct 1 2 3)) 0 2) -> 3.0 */
      return((*(c_object_ref(obj)))(sc, obj, indices));

    case T_ENVIRONMENT:
      if (is_symbol(car(indices)))
	obj = s7_environment_ref(sc, obj, car(indices));
      else return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_REF, car(indices), A_SYMBOL));
      if (is_pair(cdr(indices)))
	return(implicit_index(sc, obj, cdr(indices)));
      return(obj);

    default:                             /* (#(a b c) 0 1) -> error, but ((list (lambda (x) x)) 0 "hi") -> "hi" */
      return(g_apply(sc, list_2(sc, obj, indices)));
    }
}


/* this is transitional -- first step toward collapsing the unknown fixups */
#define set_opt_and_goto_opt_eval(Code, Func, Op)    \
  {						     \
    set_optimize_data(Code, Op);		     \
    set_ecdr(Code, Func);			     \
    goto OPT_EVAL;				     \
  }
		



/* -------------------------------- eval -------------------------------- */

/* an experiment */
#if WITH_GCC
#undef NEW_CELL
#define NEW_CELL(Sc, Obj) \
  do {						\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) {try_to_call_gc(Sc); if ((Sc->begin_hook) && (call_begin_hook(Sc))) return(Sc->F);} \
    Obj = (*(--(Sc->free_heap_top))); \
    } while (0)
#endif

static s7_pointer eval(s7_scheme *sc, opcode_t first_op) 
{
  sc->cur_code = sc->F;
  sc->op = first_op;
  
  /* this procedure can be entered recursively (via s7_call for example), so it's no place for a setjmp
   *   I don't think the recursion can hurt our continuations because s7_call is coming from hooks and
   *   callbacks that are implicit in our stack.
   */
  
  goto START_WITHOUT_POP_STACK;
  /* this ugly two-step is faster than other ways of writing this code
   */

 START:
  pop_stack(sc);

  /* syntax_opcode can be optimize_data, the field can be set at read time, we could
   *   probably combine the optimized and normal case statements, jump here if eval (eval_pair, opt_eval),
   *   and thereby save the is_syntactic and is_pair check in op_eval (still need is_optimized).
   *   To get there, the cdr(code) step in is_syntactic needs to be spread out to all the branches but
   *   all the current pops and jumps assume the cdr, op_begin would explicitly jump back here, no op_eval, 
   *   current trailers would be outside? and where would eval args go?  Huge change, might save 1% if lucky.
   *
   * about half the cases don't care about args or op, but it's not simple to distribute the sc->args
   *   setting throughout this switch statement.  Lots of branches fall through to the next and there
   *   are many internal goto's to branches, so the code becomes a mess.  sc->op is even worse because
   *   we use it in several cases for error information or choice of next op, etc.
   */

 START_WITHOUT_POP_STACK:
  switch (sc->op) 
    {
      /* --------------- */
    case OP_READ_INTERNAL:
      /* if we're loading a file, and in the file we evaluate something like:
       *
       *    (let ()
       *      (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 sc->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.
       *
       * We can't call read_error here because it assumes the input string is ok!
       */

      if (port_is_closed(sc->input_port))
	return(s7_error(sc, sc->READ_ERROR, 
			list_1(sc, make_protected_string(sc, "our input port got clobbered!"))));

      sc->tok = token(sc);

      switch (sc->tok)
	{
	case TOKEN_EOF:
	  goto START;

	case TOKEN_RIGHT_PAREN:
	  read_error(sc, "unexpected close paren");

	case TOKEN_COMMA:
	  read_error(sc, "unexpected comma");

	default:
	  sc->value = read_expression(sc);
	  sc->current_line = port_line_number(sc->input_port);  /* this info is used to track down missing close parens */
	  sc->current_file = port_filename(sc->input_port);
	  goto START;
	}

      
      /* --------------- */
      /* (read p) from scheme
       *    "p" becomes current input port for eval's duration, then pops back before returning value into calling expr
       */
    case OP_READ_DONE:
      pop_input_port(sc);

      if (sc->tok == TOKEN_EOF)
	sc->value = sc->EOF_OBJECT;
      sc->current_file = NULL; /* this is for error handling */
      goto START;
      

      /* --------------- */      
      /* load("file"); from C (g_load) -- assume caller will clean up
       *   read and evaluate exprs until EOF that matches (stack reflects nesting)
       */
    case OP_LOAD_RETURN_IF_EOF:  /* loop here until eof (via push stack below) */
      if (sc->tok != TOKEN_EOF)
	{
	  push_stack(sc, OP_LOAD_RETURN_IF_EOF, sc->NIL, sc->NIL);
	  push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
	  sc->code = sc->value;
	  goto EVAL;             /* we read an expression, now evaluate it, and return to read the next */
	}
      sc->current_file = NULL;
      return(sc->F);
      
      
      /* --------------- */
      /* (load "file") in scheme 
       *    read and evaluate all exprs, then upon EOF, close current and pop input port stack
       */
    case OP_LOAD_CLOSE_AND_POP_IF_EOF:
      if (sc->tok != TOKEN_EOF)
	{
	  push_stack(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF, sc->NIL, sc->NIL); /* was push args, code */
	  push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
	  sc->code = sc->value;
	  goto EVAL;             /* we read an expression, now evaluate it, and return to read the next */
	}
      s7_close_input_port(sc, sc->input_port);
      pop_input_port(sc);
      sc->current_file = NULL;

      if (is_multiple_value(sc->value))                    /* (load "file") where "file" is (values 1 2 3) */
	sc->value = splice_in_values(sc, multiple_value(sc->value));
      goto START;
      

      /* --------------- */
      /* read and evaluate string expression(s?)
       *    assume caller (C via g_eval_c_string) is dealing with the string port
       */
    case OP_EVAL_STRING:
      /* this is the C side s7_eval_c_string. 
       */

      /* (eval-string (string-append "(list 1 2 3)" (string #\newline) (string #\newline))) 
       *    needs to be sure to get rid of the trailing white space before checking for EOF
       *    else it tries to eval twice and gets "attempt to apply 1?, line 2"
       */
      if ((sc->tok != TOKEN_EOF) && 
	  (port_string_point(sc->input_port) < port_string_length(sc->input_port))) /* ran past end somehow? */
	{
	  unsigned char c;
	  while (white_space[c = port_string(sc->input_port)[port_string_point(sc->input_port)++]])
	    if (c == '\n')
	      port_line_number(sc->input_port)++;

	  if (c != 0)
	    {
	      backchar(c, sc->input_port);
	      push_stack(sc, OP_EVAL_STRING, sc->NIL, sc->value);
	      push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
	    }
	  else push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->value);
	}
      else push_stack(sc, OP_EVAL_DONE, sc->NIL, sc->value);
      sc->code = sc->value;
      goto EVAL;

      
      /* --------------- */
    case OP_EVAL_STRING_2:
      s7_close_input_port(sc, sc->input_port);
      pop_input_port(sc);

      if (is_multiple_value(sc->value))
	sc->value = splice_in_values(sc, multiple_value(sc->value));
      goto START;

      
      /* --------------- */
    case OP_EVAL_STRING_1:
      if ((sc->tok != TOKEN_EOF) && 
	  (port_string_point(sc->input_port) < port_string_length(sc->input_port))) /* ran past end somehow? */
	{
	  unsigned char c;
	  while (white_space[c = port_string(sc->input_port)[port_string_point(sc->input_port)++]])
	    if (c == '\n')
	      port_line_number(sc->input_port)++;

	  if (c != 0)
	    {
	      backchar(c, sc->input_port);
	      push_stack(sc, OP_EVAL_STRING_1, sc->NIL, sc->value);
	      push_stack(sc, OP_READ_INTERNAL, sc->NIL, sc->NIL);
	    }
	  else push_stack(sc, OP_EVAL_STRING_2, sc->NIL, sc->NIL);
	}
      else push_stack(sc, OP_EVAL_STRING_2, sc->NIL, sc->NIL);
      sc->code = sc->value;
      goto EVAL;


      /* -------------------- sort! (heapsort, done directly so that call/cc in the sort function will work correctly) -------------------- */

    #define SORT_N integer(vector_element(sc->code, 0))
    #define SORT_K integer(vector_element(sc->code, 1))
    #define SORT_J integer(vector_element(sc->code, 2))
    #define SORT_K1 integer(vector_element(sc->code, 3))
    #define SORT_CALLS integer(vector_element(sc->code, 4))
    #define SORT_STOP integer(vector_element(sc->code, 5))
    #define SORT_DATA(K) vector_element(car(sc->args), K)
    #define SORT_LESSP cadr(sc->args)

    HEAPSORT:
      {
	s7_Int n, j, k;
	n = SORT_N;
	k = SORT_K1;

	if ((n == k) || (k > ((s7_Int)(n / 2)))) /* k == n == 0 is the first case */
	  goto START;

	if (sc->safety != 0)
	  {
	    SORT_CALLS++;
	    if (SORT_CALLS > SORT_STOP)
	      eval_error(sc, "sort! is caught in an infinite loop, comparison: ~S", SORT_LESSP);
	  }
	j = 2 * k;
	SORT_J = j;
	if (j < n)
	  {
	    push_stack(sc, OP_SORT1, sc->args, sc->code);
	    sc->x = SORT_LESSP; /* cadr of sc->args */
	    if (needs_copied_args(sc->x))
	      sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); 
	    else 
	      {
		car(sc->T2_1) = SORT_DATA(j);
		car(sc->T2_2) = SORT_DATA(j + 1);
		sc->args = sc->T2_1;
	      }
	    sc->code = sc->x;
	    goto APPLY;
	  }
	else sc->value = sc->F;
      }

    case OP_SORT1:
      {
	s7_Int j, k;
	k = SORT_K1;
	j = SORT_J;
	if (is_true(sc, sc->value))
	  {
	    j = j + 1;
	    SORT_J = j;
	  }
	push_stack(sc, OP_SORT2, sc->args, sc->code);
	sc->x = SORT_LESSP;
	if (needs_copied_args(sc->x))
	  sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j)); 
	else 
	  {
	    car(sc->T2_1) = SORT_DATA(k);
	    car(sc->T2_2) = SORT_DATA(j);
	    sc->args = sc->T2_1;
	  }
	sc->code = sc->x;
	goto APPLY;
      }

    case OP_SORT2:
      {
	s7_Int j, k;
	k = SORT_K1;
	j = SORT_J;
	if (is_true(sc, sc->value))
	  {
	    sc->x = SORT_DATA(j);
	    SORT_DATA(j) = SORT_DATA(k);
	    SORT_DATA(k) = sc->x;
	  }
	else goto START;
	SORT_K1 = SORT_J;
	goto HEAPSORT;
      }

    case OP_SORT:
      /* coming in sc->args is sort args (data less?), sc->code = '(n k 0)
       *
       * here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value]
       */
      {
	s7_Int k;
	k = SORT_K;
	if (k <= 0)
	  goto SORT3;

	SORT_K = k - 1;
	SORT_K1 = k - 1;

	push_stack(sc, OP_SORT, sc->args, sc->code);
	goto HEAPSORT;
      }

      SORT3:
      case OP_SORT3:
	{
	  s7_Int n;
	  n = SORT_N;
	  if (n <= 0)
	    {
	      sc->value = car(sc->args);
	      goto START;
	    }
	  sc->x = SORT_DATA(0);
	  SORT_DATA(0) = SORT_DATA(n);
	  SORT_DATA(n) = sc->x;
	  SORT_N = n - 1;
	  SORT_K1 = 0;
	  push_stack(sc, OP_SORT3, sc->args, sc->code);
	  goto HEAPSORT;
	}

    case OP_SORT4:
      /* sc->value is the sort vector which needs to be turned into a list */
      sc->value = s7_vector_to_list(sc, sc->value);
      goto START;

    case OP_SORT_TWO:
      /* here we're sorting a list of 2 items */
      if (is_true(sc, sc->value))
	sc->value = sc->args;
      else sc->value = list_2(sc, cadr(sc->args), car(sc->args));
      goto START;

      /* batcher networks:
       *    ((0 2) (0 1) (1 2))
       *    ((0 2) (1 3) (0 1) (2 3) (1 2))
       *    ((0 4) (0 2) (1 3) (2 4) (0 1) (2 3) (1 4) (1 2) (3 4))
       *    ((0 4) (1 5) (0 2) (1 3) (2 4) (3 5) (0 1) (2 3) (4 5) (1 4) (1 2) (3 4))
       *    ((0 4) (1 5) (2 6) (0 2) (1 3) (4 6) (2 4) (3 5) (0 1) (2 3) (4 5) (1 4) (3 6) (1 2) (3 4) (5 6))
       *    ((0 4) (1 5) (2 6) (3 7) (0 2) (1 3) (4 6) (5 7) (2 4) (3 5) (0 1) (2 3) (4 5) (6 7) (1 4) (3 6) (1 2) (3 4) (5 6))
       *
       * but since it has to be done here by hand, it turns into too much code, 3 is:
       *    < l0 l2 ?
       *    no goto L1
       *    < l0 l1 ?
       *    no  return 1 0 2
       *    < l1 l2?
       *    yes return 0 1 2 (direct)
       *    no  return 0 2 1
       *  L1:
       *    < l0 l1 ?
       *    yes return 2 0 1
       *    < l1 l2 ?
       *    yes return 1 2 0
       *    no  return 2 1 0
       * since each "<" op above goes to OP_APPLY, we have ca 5 labels, and ca 25-50 lines
       */


      /* --------------- */
    case OP_MAP_SIMPLE:
      /* func = sc->code, func takes one arg, args = '(nil arglist) at the start with symbol_id = len
       *   the func is prechecked, as is the list.
       */
      {
	s7_pointer args;
	args = sc->args;
	if (sc->value != sc->NO_VALUE)
	  {
  	    if (is_multiple_value(sc->value))
 	      counter_result(args) = revappend(sc, multiple_value(sc->value), counter_result(args));
 	    else counter_result(args) = cons(sc, sc->value, counter_result(args));
  	  }
 	if (is_pair(counter_list(args)))
  	  {
 	    if ((--counter_count(args)) >= 0) /* protect against circular arg lists created by the map function! */
  	      {
  		s7_pointer code;
  		code = sc->code;
 		sc->x = car(counter_list(args));
 		counter_list(args) = cdr(counter_list(args));  /* move down list of args */
  		push_stack(sc, OP_MAP_SIMPLE, args, code);
		
		/* now call the function directly -- we know it is a T_CLOSURE
		 *   and that it can be called with one argument, so there's no need to go to
		 *   apply.
		 */
		if (counter_length(sc->args) != sc->capture_env_counter)
		  {
		    NEW_FRAME_WITH_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), sc->x);
		    counter_environment(args) = sc->envir;
		    counter_length(args) = sc->capture_env_counter;
		  }
		else sc->envir = old_frame_with_slot(sc, counter_environment(args), sc->x);
		sc->code = closure_body(code);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	  }
	sc->value = safe_reverse_in_place(sc, counter_result(args));
	typeflag(args) = 0;
	(*(sc->free_heap_top++)) = args;
	sc->args = sc->NIL;
	goto START;
      }


      /* --------------- */
    case OP_MAP:
      if (sc->value != sc->NO_VALUE)                   /* (map (lambda (x) (values)) (list 1)) */
	{
	  if (is_multiple_value(sc->value))            /* (map (lambda (x) (if (odd? x) (values x (* x 20)) (values))) (list 1 2 3 4)) */
	    counter_result(sc->args) = revappend(sc, multiple_value(sc->value), counter_result(sc->args));
	  /* not append_in_place here because sc->value has the multiple-values bit set */
	  else counter_result(sc->args) = cons(sc, sc->value, counter_result(sc->args));
	}

      if (counter_count(sc->args) < counter_length(sc->args))
	{
	  if (next_map(sc))
	    {
	      if (needs_copied_args(sc->code))
		sc->args = copy_list(sc, sc->args);
	      goto APPLY;
	    }
	}
      sc->value = safe_reverse_in_place(sc, counter_result(sc->args));
      typeflag(sc->args) = 0;
      (*(sc->free_heap_top++)) = sc->args;
      sc->args = sc->NIL;
      goto START;

      
      /* -------------------------------- FOR-EACH -------------------------------- */

      /* for-each et al remake the local frame, but that's only needed if the local env is exported,
       *   and that can only happen through make-closure in various guises and current-environment.
       *   error-environment captures, but it would require a deliberate error to use it in this context.
       *   c_objects call object_set_env but that requires a prior current or augment.  So we have
       *   sc->capture_env_counter that is incremented every time an environment is captured, then
       *   here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and can reuse frame.
       */

    FOR_EACH_SIMPLE:
    case OP_FOR_EACH_SIMPLE:
      /* func = sc->code, func takes one arg, args = arglist 
       */
      {
	s7_pointer args;
	args = counter_list(sc->args);

	if (is_pair(args))
	  {
	    /* now call the function directly as in map above. 
	     *    counter_environment does not need mark because it is sc->envir here
  	     */
	    s7_pointer code;
	    code = sc->code;
	    
	    if (counter_length(sc->args) != sc->capture_env_counter)
	      {
		NEW_FRAME_WITH_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), car(args));  /* set function arg value */
		counter_environment(sc->args) = sc->envir;
		counter_length(sc->args) = sc->capture_env_counter;
	      }
	    else sc->envir = old_frame_with_slot(sc, counter_environment(sc->args), car(args));
	    counter_list(sc->args) = cdr(args);
	    push_stack(sc, OP_FOR_EACH_SIMPLE, sc->args, code);
	    code = closure_body(code);
	    if (is_pair(cdr(code)))
	      push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	    sc->code = car(code);
	    goto EVAL;
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    FOR_EACH_SIMPLER:
    case OP_FOR_EACH_SIMPLER:
      {
	s7_pointer args, counter;
	counter = sc->args;
	args = counter_list(counter);
	if (is_pair(args))
	  {
	    s7_pointer code;
	    code = sc->code;
	    if (counter_length(counter) != sc->capture_env_counter)
	      {
		NEW_FRAME_WITH_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), car(args));  /* set function arg value */
		counter_environment(counter) = sc->envir;
		counter_length(counter) = sc->capture_env_counter;
	      }
	    else sc->envir = old_frame_with_slot(sc, counter_environment(counter), car(args));
	    counter_list(counter) = cdr(args);
	    push_stack(sc, OP_FOR_EACH_SIMPLER, counter, code);
	    sc->code = car(closure_body(code));
	    goto EVAL; 
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    FOR_EACH_SIMPLEST:
      NEW_FRAME(sc, counter_environment(sc->args), counter_result(sc->args));
      /* counter_result is GC protected.  This is the catch thunk's frame */

    case OP_FOR_EACH_SIMPLEST:
      {
	s7_pointer args, counter;
	counter = sc->args;
	args = counter_list(counter);
	if (is_pair(args))
	  {
	    s7_pointer code, p;
	    code = sc->code;
	    if (counter_length(counter) != sc->capture_env_counter)
	      {
		NEW_FRAME_WITH_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), car(args));  /* set function arg value */
		counter_environment(counter) = sc->envir;
		counter_length(counter) = sc->capture_env_counter;
	      }
	    else sc->envir = old_frame_with_slot(sc, counter_environment(counter), car(args));
	    counter_list(counter) = cdr(args);
	    push_stack(sc, OP_FOR_EACH_SIMPLEST, counter, code);
	    code = car(closure_body(code));

	    if (counter_count(counter) == 0)
	      {
		counter_count(counter) = 1;
		p = old_frame_in_env(sc, counter_result(counter), sc->envir);
		catch_all_goto_loc(p) = s7_stack_top(sc);
		catch_all_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
		catch_all_result(p) = fcdr(code);
	      }
	    else
	      {
		p = counter_result(counter);
		environment_slots(p) = sc->NIL;                  
		environment_id(p) = ++environment_number; 
		next_environment(p) = sc->envir;
	      }
	    sc->envir = p;
	    push_stack_no_args(sc, OP_CATCH_ALL, code);
	    sc->code = ecdr(cdr(code));                   /* the body of the first lambda */

	    if (is_pair(cdr(sc->code)))
	      push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	    sc->code = car(sc->code);
	    goto EVAL;
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    case OP_FOR_EACH:
      if (counter_count(sc->args) < counter_length(sc->args))
	{
	  if (next_for_each(sc)) 
	    {
	      if (needs_copied_args(sc->code))
		sc->args = copy_list(sc, sc->args);
	      goto APPLY;
	    }
	}
      sc->value = sc->UNSPECIFIED;
      typeflag(sc->args) = 0;
      (*(sc->free_heap_top++)) = sc->args;
      sc->args = sc->NIL;
      goto START;



      /* -------------------------------- MEMBER -------------------------------- */
    case OP_MEMBER_IF:
      /* code=func, args = (list original args) with ecdr->position in cadr (the list), value = result of comparison
       */
      if (sc->value != sc->F)            /* previous comparison was not #f -- return list */
	{
	  sc->value = ecdr(sc->args);
	  goto START;
	}

      if (!is_pair(cdr(ecdr(sc->args))))     /* no more args -- return #f */
	{
	  sc->value = sc->F;
	  goto START;
	}
      set_ecdr(sc->args, cdr(ecdr(sc->args)));  /* cdr down arg list */
      push_stack(sc, OP_MEMBER_IF1, sc->args, sc->code);
      sc->args = list_2(sc, caar(sc->args), car(ecdr(sc->args)));
      goto APPLY;


      /* --------------- */
    case OP_MEMBER_IF1:
      if (sc->value != sc->F)            /* previous comparison was not #f -- return list */
	{
	  sc->value = ecdr(sc->args);
	  goto START;
	}

      if (!is_pair(cdr(ecdr(sc->args))))     /* no more args -- return #f */
	{
	  sc->value = sc->F;
	  goto START;
	}
      set_ecdr(sc->args, cdr(ecdr(sc->args)));  /* cdr down arg list */

      /* circular list check */
      if (ecdr(sc->args) == fcdr(sc->args))
	{
	  sc->value = sc->F;
	  goto START;
	}
      set_fcdr(sc->args, cdr(fcdr(sc->args)));  /* cdr down the slow list (check for circular list) */

      push_stack(sc, OP_MEMBER_IF, sc->args, sc->code);
      sc->args = list_2(sc, caar(sc->args), car(ecdr(sc->args)));
      goto APPLY;



      /* -------------------------------- ASSOC -------------------------------- */
    case OP_ASSOC_IF1:
    case OP_ASSOC_IF:
      /* code=func, args=(list args) with f/ecdr=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(ecdr(sc->args));
	  goto START;
	}

      if (!is_pair(cdr(ecdr(sc->args))))     /* (assoc 3 '((1 . 2) . 3) =) or nil */
	{
	  sc->value = sc->F;
	  goto START;
	}
      set_ecdr(sc->args, cdr(ecdr(sc->args)));  /* cdr down arg list */

      if (sc->op == OP_ASSOC_IF1)
	{
	  /* circular list check */
	  if (ecdr(sc->args) == fcdr(sc->args))
	    {
	      sc->value = sc->F;
	      goto START;
	    }
	  set_fcdr(sc->args, cdr(fcdr(sc->args)));  /* cdr down the slow list */
	  push_stack(sc, OP_ASSOC_IF, sc->args, sc->code);
	}
      else push_stack(sc, OP_ASSOC_IF1, sc->args, sc->code);

      if (!is_pair(car(ecdr(sc->args))))     /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
	eval_error(sc, "assoc: second arg is not an alist: ~S", sc->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
       */

      sc->args = list_2(sc, caar(sc->args), caar(ecdr(sc->args)));
      goto APPLY;



      /* ---------------- OP_APPLY ---------------- */
    case OP_APPLY:      /* apply 'code' to 'args' */
      if (needs_copied_args(sc->code))
	sc->args = copy_list(sc, sc->args);
      goto APPLY;
      /* (let ((lst '((1 2)))) (define (identity x) x) (cons (apply identity lst) lst))
       */



      /* -------------------------------- DO -------------------------------- */

      /* this is the fm-violin optimization */
    SIMPLE_SAFE_DOTIMES:
    case OP_SIMPLE_SAFE_DOTIMES:
      /* set up as in SAFE_DOTIMES, pull in all the let vars
       *   run body without any jumps: update and check step,
       *   SAFE_C_C of each let var, SAFE_C_C of body
       *   goto START
       */
      {
	s7_pointer vars, init_val, func, body, stepper, lets;

	vars = car(sc->code);
	init_val = cadr(car(vars));
	if (is_symbol(init_val))
	  init_val = finder(sc, init_val);
	if (s7_is_integer(init_val))
	  {
	    s7_pointer end_expr, end_val, let_var, p;
	    end_expr = caadr(sc->code);
	    end_val = caddr(end_expr);
	    if (is_symbol(end_val))
	      end_val = finder(sc, end_val);
	    if (s7_is_integer(end_val))
	      {
		sc->envir = new_frame_in_env(sc, sc->envir); 
		sc->args = add_slot(sc, caar(vars), make_mutable_integer(sc, s7_integer(init_val)));
		if (s7_integer(init_val) == s7_integer(end_val))
		  {
		    sc->code = cdr(cadr(sc->code));
		    goto DO_BEGIN;
		  }
		denominator(slot_value(sc->args)) = s7_integer(end_val);

		/* add the let vars but not initialized yet 
		 */
		for (let_var = car(cdaddr(sc->code)); is_pair(let_var); let_var = cdr(let_var))
		  add_slot(sc, caar(let_var), s7_make_mutable_real(sc, 1.5));
		
		stepper = slot_value(sc->args);
		func = caddr(caddr(sc->code));
		
		if (c_function_let_looped(ecdr(func)))
		  {
		    s7_function f;
		    s7_pointer result;
			
		    /* fprintf(stderr, "%d: %s\n", __LINE__, DISPLAY(sc->envir)); */
		    f = (s7_function)c_function_call(c_function_let_looped(ecdr(func)));
		    car(sc->T3_1) = stepper;
		    car(sc->T3_2) = caddr(sc->code);
		    car(sc->T3_3) = next_environment(sc->envir);
		    result = f(sc, sc->T3_1);
			
		    if (result)
		      {
			sc->code = cdr(cadr(sc->code));
			goto DO_BEGIN;
		      }
		    /* else fall into the ordinary loop */
		  }

		body = cdr(caddr(caddr(sc->code)));
		lets = car(cdaddr(sc->code));

		while (true)
		  {
		    /* eval let + body  (cddr(sc->code)) */
		    for (let_var = lets; is_pair(let_var); let_var = cdr(let_var))
		      {
			p = find_local_symbol(sc, sc->envir, caar(let_var));
			slot_set_value(p, c_call(cadar(let_var))(sc, cdadar(let_var)));
		      }
		    c_call(func)(sc, body);
		    numerator(stepper)++;
		    if (numerator(stepper) == denominator(stepper))
		      {
			sc->code = cdr(cadr(sc->code));
			goto DO_BEGIN;
		      }
		  }
	      }
	  }
	set_syntax_op(sc->code, sc->SIMPLE_DO);
	goto SIMPLE_DO;
      }


      /* ---------------- */
    SAFE_DOTIMES_C_C:
    case OP_SAFE_DOTIMES_C_C:
      {
	s7_pointer vars, init_val, func, body, stepper;

	vars = car(sc->code);
	init_val = cadr(car(vars));
	if (is_symbol(init_val))
	  init_val = finder(sc, init_val);
	else
	  {
	    if (is_pair(init_val))
	      init_val = c_call(init_val)(sc, cdr(init_val));
	  }
	if (s7_is_integer(init_val))
	  {
	    s7_pointer end_expr, end_val;
	    end_expr = caadr(sc->code);
	    end_val = caddr(end_expr);
	    if (is_symbol(end_val))
	      end_val = finder(sc, end_val);
	    if (s7_is_integer(end_val))
	      {
		/* (let () (define (hi a) (do ((i a (+ i 1))) ((= i a) i) (+ a 1))) (hi 1)) */
		sc->envir = new_frame_in_env(sc, sc->envir); 
		sc->args = add_slot(sc, caar(vars), make_mutable_integer(sc, s7_integer(init_val)));

		if (s7_integer(init_val) == s7_integer(end_val))
		  {
		    sc->code = cdr(cadr(sc->code));
		    goto DO_BEGIN;
		  }

		denominator(slot_value(sc->args)) = s7_integer(end_val);

		func = caddr(sc->code);
		body = cdr(caddr(sc->code));
		stepper = slot_value(sc->args);

		if (c_function_looped(ecdr(func)))
		  {
		    s7_function f;
		    s7_pointer result;
		    f = (s7_function)c_function_call(c_function_looped(ecdr(func)));
		    result = f(sc, sc->z = cons(sc, stepper, body));
		    if (result)
		      {
			sc->code = cdr(cadr(sc->code));
			goto DO_BEGIN;
		      }
		    /* else fall into the ordinary loop */
		  }

		while (true)
		  {
		    /* eval body (cddr(sc->code)) */
		    c_call(func)(sc, body);
		    numerator(stepper)++;
		    if (numerator(stepper) == denominator(stepper))
		      {
			sc->code = cdr(cadr(sc->code));
			goto DO_BEGIN;
		      }
		  }
	      }
	  }
	set_syntax_op(sc->code, sc->SIMPLE_DO);
	goto SIMPLE_DO;
      }


      /* ---------------- */
    SAFE_DOTIMES_C_A:
    case OP_SAFE_DOTIMES_C_A:
      {
	s7_pointer vars, init_val, body, stepper;
	s7_function func;

	vars = car(sc->code);
	init_val = cadr(car(vars));
	if (is_symbol(init_val))
	  init_val = finder(sc, init_val);
	else
	  {
	    if (is_pair(init_val))
	      init_val = c_call(init_val)(sc, cdr(init_val));
	  }
	if (s7_is_integer(init_val))
	  {
	    s7_pointer end_expr, end_val;
	    end_expr = caadr(sc->code);
	    end_val = caddr(end_expr);
	    if (is_symbol(end_val))
	      end_val = finder(sc, end_val);
	    if (s7_is_integer(end_val))
	      {
		/* (let () (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (display i))) (hi))
		 */
		sc->envir = new_frame_in_env(sc, sc->envir); 
		sc->args = add_slot(sc, caar(vars), make_mutable_integer(sc, s7_integer(init_val)));

		if (s7_integer(init_val) == s7_integer(end_val))
		  {
		    sc->code = cdr(cadr(sc->code));
		    goto DO_BEGIN;
		  }

		denominator(slot_value(sc->args)) = s7_integer(end_val);

		/* func = ecdr(caddr(sc->code)); */
		body = caddr(sc->code);
		func = all_x_eval(sc, body);
		if (func == all_x_c_s)
		  {
		    environment_dox1(sc->envir) = find_symbol(sc, cadr(caddr(sc->code)));
		    func = end_dox_c_s;
		  }
		stepper = slot_value(sc->args);
		
		while (true)
		  {
		    func(sc, body);
		    numerator(stepper)++;
		    if (numerator(stepper) == denominator(stepper))
		      {
			sc->code = cdr(cadr(sc->code));
			goto DO_BEGIN;
		      }
		  }
	      }
	  }
	set_syntax_op(sc->code, sc->SIMPLE_DO);
	goto SIMPLE_DO;
      }


      /* --------------- */
    SAFE_DOTIMES:
    case OP_SAFE_DOTIMES:
      {
	s7_pointer vars, init_val;
	vars = car(sc->code);
	init_val = cadr(car(vars));
	if (is_symbol(init_val))
	  init_val = finder(sc, init_val);
	else
	  {
	    if (is_pair(init_val))
	      init_val = c_call(init_val)(sc, cdr(init_val));
	  }
	if (s7_is_integer(init_val))
	  {
	    s7_pointer end_expr, end_val, code;
	    code = sc->code;
	    end_expr = caadr(code);
	    end_val = caddr(end_expr);
	    if (is_symbol(end_val))
	      end_val = finder(sc, end_val);
	    if (s7_is_integer(end_val))
	      {
		sc->code = cddr(code);
		sc->envir = new_frame_in_env(sc, sc->envir); 
		sc->args = add_slot(sc, caar(vars), make_mutable_integer(sc, s7_integer(init_val)));

		denominator(slot_value(sc->args)) = s7_integer(end_val);
		/* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the frame even if the loop is not evaluated
		 */
		if ((is_null(sc->code)) ||
		    ((!is_pair(car(sc->code))) &&
		     (is_null(cdr(sc->code)))))
		  {
		    numerator(slot_value(sc->args)) = s7_integer(end_val);
		    sc->code = cdr(cadr(code));
		    goto DO_BEGIN;
		  }

		if (s7_integer(init_val) == s7_integer(end_val))
		  {
		    sc->code = cdr(cadr(code));
		    goto DO_BEGIN;
		  }
		if ((is_null(cdr(sc->code))) &&
		    (is_pair(car(sc->code))))
		  {
		    sc->code = car(sc->code);
		    set_fcdr(code, sc->code);

		    if ((typesflag(sc->code) == SYNTACTIC_PAIR) || 
			(typeflag(car(sc->code)) == SYNTACTIC_TYPE))
		      {
			/* (with-sound () (mosquito 0 5 560 .2))
			 */
			/* if we don't handle it here, check_let mangles it, and a subsequent return here sees OP_LET_ALL_X or whatever
			 */

			if (((syntax_opcode(car(sc->code)) == OP_LET) ||
			     (syntax_opcode(car(sc->code)) == OP_LET_STAR)) &&
			    (is_null(cdddr(sc->code))))
			  {
			    /* it's a let of some sort, and one-line body */
			    if ((is_optimized(caddr(sc->code))) &&
				(c_function_let_looped(ecdr(caddr(sc->code)))))
			      {
				bool happy = true;
				s7_pointer p;
				for (p = cadr(sc->code); is_pair(p); p = cdr(p))
				  if ((!is_pair(cadar(p))) ||
				      (!is_optimized(cadar(p))) ||
				      (optimize_data(cadar(p)) != HOP_SAFE_C_C))
				    {
				      happy = false;
				      break;
				    }
				/* fprintf(stderr, "%s%s%s is let loopable\n", (happy) ? RED_TEXT : "", DISPLAY(sc->code), (happy) ? NORMAL_TEXT : ""); */
				if (happy)
				  {
				    s7_function f;
				    s7_pointer result, old_e;
				    old_e = sc->envir;
				    sc->envir = new_frame_in_env(sc, sc->envir); 
				    for (p = cadr(sc->code); is_pair(p); p = cdr(p))
				      add_slot(sc, caar(p), s7_make_mutable_real(sc, 1.5));

				    /* fprintf(stderr, "%d: %s\n", __LINE__, DISPLAY(old_e)); */
				    f = (s7_function)c_function_call(c_function_let_looped(ecdr(caddr(sc->code))));
				    car(sc->T3_1) = slot_value(sc->args);
				    car(sc->T3_2) = sc->code;
				    car(sc->T3_3) = next_environment(old_e);
				    result = f(sc, sc->T3_1);
				    sc->envir = old_e;

				    if (result)
				      {
					sc->code = cdr(cadr(code));
					goto DO_BEGIN;
				      }
				    /* else fall into the ordinary loop */
				  }
			      }
			  }

			push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code);
			if (typesflag(sc->code) == SYNTACTIC_PAIR)
			  sc->op = (opcode_t)lifted_op(sc->code);
			else
			  {
			    sc->op = (opcode_t)syntax_opcode(car(sc->code));
			    lifted_op(sc->code) = sc->op;
			    set_type(sc->code, SYNTACTIC_PAIR);
			  }
			/* fprintf(stderr, "%d %s %s\n", __LINE__, real_op_names[sc->op], DISPLAY_80(sc->code)); */
			sc->code = cdr(sc->code);
			goto START_WITHOUT_POP_STACK;
		      }
		    else
		      {
			/* fprintf(stderr, "%d %p %s\n", is_optimized(sc->code), c_function_looped(ecdr(sc->code)), DISPLAY(sc->code)); */
			if ((is_optimized(sc->code)) &&
			    (c_function_looped(ecdr(sc->code))))
			  {
			    s7_pointer body, stepper, result;
			    s7_function f;

			    stepper = slot_value(sc->args);
			    body = cdr(sc->code);
			    
			    f = (s7_function)c_function_call(c_function_looped(ecdr(sc->code)));
			    result = f(sc, sc->z = cons(sc, stepper, body));
			    if (result)
			      {
				sc->code = cdr(cadr(code));
				goto DO_BEGIN;
			      }
			  }
			/* else {if (is_optimized(sc->code)) fprintf(stderr, "%s has no looper\n", DISPLAY(sc->code));} */
			/* no looper: write-byte|char mixer-set! locsig+constant "(locsig gen i 1.0)" locsig-set!
			 *            frame->file file->sample ina 
			 * not gf: contrast-enhancement
			 */

			if (is_optimized(sc->code))
			  {
			    if ((optimize_data(sc->code) == HOP_SAFE_C_SZ) &&
				(cadr(sc->code) == slot_symbol(sc->args)))
			      {
				push_stack(sc, OP_SAFE_DOTIMES_STEP_A, sc->args, code);
				sc->code = caddr(sc->code);
				/* fprintf(stderr, "%d %s\n", __LINE__, DISPLAY_80(sc->code)); */
				goto OPT_EVAL;
			      }
			    
			    if (optimize_data(sc->code) == HOP_SAFE_C_SSA)
			      {
				/* 1 stepper, step by 1, end test is =, no set in body, we checked above for null case, body is one-line
				 */
				s7_pointer arg1, arg2, arg3, step, end;
				s7_function f;

				end = cdr(cadr(code));
				step = slot_value(sc->args);
				code = sc->code;
				f = c_call(code);
				arg1 = find_symbol(sc, cadr(code));
				arg2 = find_symbol(sc, caddr(code));
				arg3 = cdddr(code);
				
				while (true)
				  {
				    car(sc->A3_1) = slot_value(arg1);
				    car(sc->A3_2) = slot_value(arg2);
				    car(sc->A3_3) = ((s7_function)fcdr(arg3))(sc, car(arg3));
				    f(sc, sc->A3_1);

				    numerator(step)++;
				    if (numerator(step) == denominator(step))
				      {
					sc->code = end;
					goto DO_BEGIN;
				      }
				  }
			      }
			  }
			/* fprintf(stderr, "%d %s\n", __LINE__, DISPLAY_80(sc->code));	*/
			push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code);
			goto NS_EVAL;
		      }
		  }
		/* here we know the body is not a one-liner, or something ridiculous */
		set_fcdr(code, sc->code);
		push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code);		  
		goto BEGIN;
	      }
	  }
	set_syntax_op(sc->code, sc->SIMPLE_DO);
	goto SIMPLE_DO;
      }


      /* --------------- */
    case OP_SAFE_DOTIMES_STEP_P:
      {
	s7_pointer arg;
	arg = slot_value(sc->args);
	numerator(arg)++;
	if (numerator(arg) == denominator(arg))
	  {
	    sc->code = cdr(cadr(sc->code));
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code);
	sc->code = fcdr(sc->code);
	sc->op = (opcode_t)lifted_op(sc->code);
	sc->code = cdr(sc->code);
	goto START_WITHOUT_POP_STACK;
      }


      /* --------------- */
    case OP_SAFE_DOTIMES_STEP_O:
      {
	s7_pointer arg;
	arg = slot_value(sc->args);
	numerator(arg)++;
	if (numerator(arg) == denominator(arg))
	  {
	    sc->code = cdr(cadr(sc->code));
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, sc->code);
	sc->code = fcdr(sc->code);
	goto NS_EVAL; 
      }


      /* --------------- */
    case OP_SAFE_DOTIMES_STEP_A:
      {
	s7_pointer arg;

	arg = slot_value(sc->args);
	car(sc->T2_1) = arg;
	car(sc->T2_2) = sc->value;
	c_call(fcdr(sc->code))(sc, sc->T2_1);

	numerator(arg)++;
	if (numerator(arg) == denominator(arg))
	  {
	    sc->code = cdr(cadr(sc->code));
	    goto DO_BEGIN;
	  }

	push_stack(sc, OP_SAFE_DOTIMES_STEP_A, sc->args, sc->code);
	sc->code = caddr(fcdr(sc->code));
	goto OPT_EVAL;
      }


      /* --------------- */
    case OP_SAFE_DOTIMES_STEP:
      {
	s7_pointer arg;
	arg = slot_value(sc->args);
	numerator(arg)++;
	if (numerator(arg) == denominator(arg))
	  {
	    sc->code = cdr(cadr(sc->code));
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code);

	arg = fcdr(sc->code);
	/* here we know the body has more than one form */
	push_stack_no_args(sc, OP_BEGIN1, cdr(arg));
	sc->code = car(arg);
	goto EVAL;
      }


      /* --------------- */
    SAFE_DO:
    case OP_SAFE_DO:
      {
	/* body is safe, step = +1, end is =, 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)
	 */
	s7_pointer end, init_val, end_val, code;

	code = sc->code;
	init_val = cadaar(code);
	if (is_symbol(init_val))
	  init_val = finder(sc, init_val);
	else
	  {
	    if (is_pair(init_val))
	      init_val = c_call(init_val)(sc, cdr(init_val));
	  }
	
	end = caddr(car(cadr(code)));
	if (is_symbol(end))
	  end_val = finder(sc, end);
	else end_val = end;
	
	/* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi))
	 */
	sc->envir = new_frame_in_env(sc, sc->envir);
	environment_dox1(sc->envir) = add_slot(sc, caaar(code), init_val);

#if WITH_GMP
	if (s7_integer(init_val) == s7_integer(end_val))
#else
	if ((s7_integer(init_val) == s7_integer(end_val)) ||
	    ((s7_integer(init_val) > s7_integer(end_val)) &&
	     (ecdr(car(cadr(code))) == geq_2)))
#endif
	  {
	    sc->code = cdr(cadr(code));
	    goto DO_BEGIN;
	  }
	if (is_symbol(end))
	  sc->args = find_symbol(sc, end);
	else sc->args = make_slot(sc, end, end); /* here and elsewhere sc->args is used for GC protection */
	environment_dox2(sc->envir) = sc->args;

	sc->code = cddr(code);

	/* see tmp8 */

	if ((is_null(cdr(sc->code))) &&
	    (is_pair(car(sc->code))))
	  {
	    s7_pointer body;
	    body = car(sc->code);

	    if ((typesflag(body) == SYNTACTIC_PAIR) ||
		(typeflag(car(body)) == SYNTACTIC_TYPE))
	      {
		if (typesflag(body) == SYNTACTIC_PAIR)
		  sc->op = (opcode_t)lifted_op(body);
		else
		  {
		    sc->op = (opcode_t)syntax_opcode(car(body));
		    lifted_op(body) = sc->op;
		    set_type(body, SYNTACTIC_PAIR);
		  }
		
		if (sc->op == OP_SET)
		  {
		    s7_pointer settee, val;
		    s7_Int i, start, lim;
		    settee = cadr(body);
		    val = caddr(body);

		    /* one common case: (set! (x i) c)
		     */
		    if (is_pair(settee))
		      {
			if ((cadr(settee) == caaar(code)) &&
			    (is_null(cddr(settee))) &&
			    (is_symbol(car(settee))))
			  {
			    s7_pointer obj, new_val;
			    obj = finder(sc, car(settee));
			    if (!is_pair(val))
			      {
				if (is_symbol(val))
				  new_val = finder(sc, val);
				else new_val = val;
				lim = s7_integer(end_val);
				start = s7_integer(init_val);
				if (s7_is_vector(obj))
				  {
				    if ((start < 0) || (lim > vector_length(obj)))
				      out_of_range(sc, sc->VECTOR_SET, end_val, obj, "index should be between 0 and the vector length");
				    if (is_int_vector(obj))
				      {
					s7_Int k;
					k = s7_number_to_integer(sc, new_val);
					for (i = start; i < lim; i++)
					  int_vector_element(obj, i) = k;
				      }
				    else
				      {
					if (is_float_vector(obj))
					  {
					    s7_Double x;
					    x = s7_number_to_real(sc, new_val);
					    for (i = start; i < lim; i++)
					      float_vector_element(obj, i) = x;
					  }
					else
					  {
					    for (i = start; i < lim; i++)
					      vector_element(obj, i) = new_val;
					  }
				      }
				    goto SAFE_DO_DONE;
				  }
				else
				  {
				    if ((is_c_object(obj)) &&
					(c_object_has_array(obj)))
				      {
					double x;
					double *data;
					if ((start < 0) || (lim > c_object_array_length(obj)))
					  out_of_range(sc, sc->SET, end_val, obj, "index should be between 0 and the object's array length");
					x = s7_number_to_real(sc, new_val);
					data = c_object_array(obj);
					for (i = start; i < lim; i++)
					  data[i] = x;
					goto SAFE_DO_DONE;
				      }
				  }
			      }
			    else /* is_pair(val) */
			      {
			      }
			  }
		      }
		    else /* !is_pair(settee) */
		      {
			/* this is stupid... */
			if ((is_symbol(settee)) &&
			    (settee != caaar(code)) &&
			    (is_pair(val)))
			  {
			    s7_pointer slot;
			    slot = find_symbol(sc, settee);
			    if (!is_slot(slot)) 
			      eval_error(sc, "set! ~A: unbound variable", settee);
			    if ((car(val) == sc->VECTOR_REF) &&
				(s7_list_length(sc, val) == 3) &&
				(caddr(val) == caaar(code)) &&
				(is_symbol(cadr(val))))
			      {
				car(sc->T2_1) = finder(sc, cadr(val));
				car(sc->T2_2) = make_integer(sc, integer(end_val) - 1);
				slot_set_value(slot, g_vector_ref(sc, sc->T2_1));
				goto SAFE_DO_DONE;
			      }
			    if ((car(val) == sc->MULTIPLY) &&
				(s7_list_length(sc, val) == 3) &&
				(cadr(val) == caaar(code)) &&
				(is_real(caddr(val))))
			      {
				slot_set_value(slot, make_real(sc, (integer(end_val) - 1) * s7_number_to_real(sc, caddr(val))));
				goto SAFE_DO_DONE;
			      }

			    if (is_optimized(val))
			      {
				s7_function f;
				s7_pointer args, stepper, step_val;
				
				stepper = environment_dox1(sc->envir);
				lim = s7_integer(end_val);
				start = s7_integer(init_val);
				f = (s7_function)c_call(val);
				args = cdr(val);
				slot_value(stepper) = make_mutable_integer(sc, start);
				step_val = slot_value(stepper);

				if (optimize_data(val) == HOP_SAFE_C_C)
				  {
				    for (i = start; i < lim; i++)
				      {
					integer(step_val) = i;
					slot_set_value(slot, f(sc, args));
				      }
				    goto SAFE_DO_DONE;
				  }
				else
				  {
				    if (optimize_data(val) == HOP_SAFE_C_SS)
				      {
					s7_pointer s1, s2;
					s1 = s7_slot(sc, car(args));
					s2 = s7_slot(sc, cadr(args));
					for (i = start; i < lim; i++)
					  {
					    integer(step_val) = i;
					    car(sc->T2_1) = slot_value(s1);
					    car(sc->T2_2) = slot_value(s2);
					    slot_set_value(slot, f(sc, sc->T2_1));
					  }
					goto SAFE_DO_DONE;
				      }
				  }
			      }
			  }
		      }

		    /* fprintf(stderr, "safe do set 1 line: %s\n", DISPLAY_80(code)); */
		  }
		/* else fprintf(stderr, "safe do syntax 1 line: %s\n", DISPLAY_80(code)); */
	      }
	    else
	      {
		/* fprintf(stderr, "safe do 1 line: %s\n", DISPLAY_80(code)); */
	      }
	  }
	/* else fprintf(stderr, "safe do: %s\n", DISPLAY_80(code)); */

	set_fcdr(code, sc->code);
	push_stack(sc, OP_SAFE_DO_STEP, sc->args, code);
	goto BEGIN;

      SAFE_DO_DONE:
	slot_value(environment_dox1(sc->envir)) = slot_value(environment_dox2(sc->envir));
	sc->code = cdr(cadr(code));
	goto DO_BEGIN;
      }


      /* --------------- */
    case OP_SAFE_DO_STEP:
      {
	s7_Int step, end;
	s7_pointer args, code, slot;

	args = sc->envir;
	code = sc->code;
	slot = environment_dox1(args);

	step = s7_integer(slot_value(slot)) + 1;
	slot_set_value(slot, make_integer(sc, step));
	end = s7_integer(slot_value(environment_dox2(args)));
#if WITH_GMP
	if (step == end)
#else
        if ((step == end) ||
	    ((step > end) &&
	     (ecdr(caadr(code)) == geq_2)))
#endif	      
	  {
	    sc->code = cdadr(code);
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SAFE_DO_STEP, sc->args, code);
	code = fcdr(code);
	if (is_pair(cdr(code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	sc->code = car(code);
	goto EVAL;
      }


      /* --------------- */
    SIMPLE_DO_A:
    case OP_SIMPLE_DO_A:
      sc->op = OP_SIMPLE_DO_A;

    SIMPLE_DO:
    case OP_SIMPLE_DO:
      {
	/* body might not be safe in this case, but the step and end exprs are easy
	 *   "not safe" merely means we hit something that the optimizer can't specialize like (+ (* (abs (- ...))))
	 */
	s7_pointer init, end, code;

	code = sc->code;
	sc->envir = new_frame_in_env(sc, sc->envir);
	init = cadaar(code);
	if (is_symbol(init))
	  sc->value = finder(sc, init);
	else 
	  {
	    if (is_pair(init))
	      sc->value = c_call(init)(sc, cdr(init));
	    else sc->value = init;
	  }
	environment_dox1(sc->envir) = add_slot(sc, caaar(code), sc->value);
	end = caddr(caadr(code));
	if (is_symbol(end))
	  sc->args = find_symbol(sc, end);
	else 
	  {
	    s7_pointer slot;
	    NEW_CELL_NO_CHECK(sc, slot);
	    slot_symbol(slot) = end;
	    slot_set_value(slot, end);
	    set_type(slot, T_SLOT | T_IMMUTABLE);
	    sc->args = slot;
	  }
	environment_dox2(sc->envir) = sc->args;

	car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
	car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
	if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
	  {
	    sc->code = cdadr(code);
	    goto DO_BEGIN;
	  }

	set_fcdr(code, cddr(code));
	if ((is_null(cdr(fcdr(code)))) &&
	    (is_pair(car(fcdr(code)))) &&
	    /* (is_optimized(car(fcdr(code)))) && */
	    /* (is_all_x_op(optimize_data(car(fcdr(code))))) && */
	    (is_symbol(cadr(caddr(caar(code)))))) /* caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */
	  {
	    s7_pointer step_var, ctr, end, body;
	    s7_function func = NULL, endf, stepf;
	    s7_ex *exd = NULL;

	    body = car(fcdr(code));
	    ctr = environment_dox1(sc->envir);
	    end = environment_dox2(sc->envir);
	    endf = c_call(caadr(code));
	    stepf = c_call(caddr(caar(code)));
	    step_var = caddr(caddr(caar(code))); 

	    /* fprintf(stderr, "%s\n", DISPLAY(body)); */

	    if (is_symbol(car(body)))
	      {
		s7_pointer f;
		f = s7_symbol_value(sc, car(body));

		if ((is_c_function(f)) &&
		    (c_function_ex_parser(f)))
		  {
		    exd = c_function_ex_parser(f)(sc, body);
		    if (exd)
		      {
			bool mut;
			mut = is_step_safe(f);

			if ((mut) &&
			    (type(slot_value(ctr)) == T_INTEGER) &&
			    (((s7_function)stepf == g_subtract_s1) ||
			     ((s7_function)stepf == g_add_s1)))
			  {
			    slot_value(ctr) = make_mutable_integer(sc, integer(slot_value(ctr)));
			    if ((s7_function)stepf == g_subtract_s1)
			      stepf = g_mutable_subtract1;
			    else stepf = g_mutable_add1;
			  }
			else mut = false;

			while (true)
			  {
			    exd->ex_vf(exd->ex_data);
		    
			    car(sc->T2_1) = slot_value(ctr);
			    car(sc->T2_2) = step_var;
			    slot_set_value(ctr, stepf(sc, sc->T2_1));
		    
			    car(sc->T2_1) = slot_value(ctr);
			    car(sc->T2_2) = slot_value(end);
			    if (is_true(sc, endf(sc, sc->T2_1)))
			      {
				exd->ex_free(exd->ex_data);
				free(exd);
				sc->code = cdr(cadr(code));
				if (!is_null(sc->code))
				  {
				    if (mut)
				      clear_mutable(slot_value(ctr));
				    goto BEGIN;
				  }
				sc->value = sc->NIL;
				goto START;	
			      }
			  }
		      }
		  }
	      }

	    if ((!func) &&
		(is_optimized(car(fcdr(code)))) && 
		(is_all_x_op(optimize_data(car(fcdr(code))))))
	      func = all_x_eval(sc, car(fcdr(code)));
	    
	    if (func)
	      {
		while (true)
		  {
		    func(sc, body);
		    
		    car(sc->T2_1) = slot_value(ctr);
		    car(sc->T2_2) = step_var;
		    slot_set_value(ctr, stepf(sc, sc->T2_1));
		    
		    car(sc->T2_1) = slot_value(ctr);
		    car(sc->T2_2) = slot_value(end);
		    if (is_true(sc, endf(sc, sc->T2_1)))
		      {
			sc->code = cdr(cadr(code));
			goto DO_BEGIN;
		      }
		  }
	      }
	  }

	if (sc->op == OP_SIMPLE_DO_A)
	  push_stack(sc, OP_SIMPLE_DO_STEP_A, sc->args, code);
	else push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code);

	sc->code = fcdr(code);
	goto BEGIN;
      }


      /* --------------- */
    case OP_SIMPLE_DO_STEP:
      {
	s7_pointer step, ctr, end, code;
	ctr = environment_dox1(sc->envir);
	end = environment_dox2(sc->envir);
	code = sc->code;

	step = caddr(caar(code)); 
	if (is_symbol(cadr(step))) /* bench 2006888 2006888 */
	  {
	    car(sc->T2_1) = slot_value(ctr);
	    car(sc->T2_2) = caddr(step);
	  }
	else
	  {
	    car(sc->T2_2) = slot_value(ctr);
	    car(sc->T2_1) = cadr(step);
	  }
	slot_set_value(ctr, c_call(step)(sc, sc->T2_1));

	car(sc->T2_1) = slot_value(ctr);
	car(sc->T2_2) = slot_value(end);
	if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
	  {
	    sc->code = cdr(cadr(code));
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code);
	sc->code = fcdr(code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }


      /* --------------- */
    case OP_SIMPLE_DO_STEP_A:
      {
	/* (((i 0 (+ i 1))) ((= i 1000)) (set! mx (max mx (abs (f1 signal)))) (set! signal 0.0))
	 * (((i 0 (+ i 1))) ((= i 20)) (outa i (sine-env e)))
	 */
	s7_pointer val, ctr, end, code;

	code = sc->code;
	ctr = environment_dox1(sc->envir);
	val = slot_value(ctr);
	end = slot_value(environment_dox2(sc->envir));

	if (is_integer(val))
	  {
	    slot_set_value(ctr, make_integer(sc, integer(val) + 1));
	    val = slot_value(ctr);
	    if (is_integer(end))
	      {
		if (integer(val) == integer(end))
		  {
		    sc->code = cdr(cadr(code));
		    goto DO_BEGIN;
		  }
	      }
	    else
	      {
		car(sc->T2_1) = val;
		car(sc->T2_2) = end;
		if (is_true(sc, g_equal_2(sc, sc->T2_1)))
		  {
		    sc->code = cdr(cadr(code));
		    goto DO_BEGIN;
		  }
	      }
	  }
	else
	  {
	    car(sc->T1_1) = val; /* add_s1 ignores cadr(args) */
	    slot_set_value(ctr, g_add_s1(sc, sc->T1_1));
	    val = slot_value(ctr);

	    car(sc->T2_1) = val;
	    car(sc->T2_2) = end;
	    if (is_true(sc, g_equal_2(sc, sc->T2_1)))
	      {
		sc->code = cdr(cadr(code));
		goto DO_BEGIN;
	      }
	  }
	push_stack(sc, OP_SIMPLE_DO_STEP_A, sc->args, code);
	sc->code = fcdr(code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));

	sc->code = car(sc->code);
	goto EVAL;
      }


      /* --------------- */
    SIMPLE_DO_FOREVER:
    case OP_SIMPLE_DO_FOREVER:
      {
	s7_pointer body, args;
	s7_function func;

	/* sc->envir = new_frame_in_env(sc, sc->envir); */
	body = caddr(sc->code);
	args = cdr(body);

	if (c_function_looped(ecdr(body)))
	  {
	    func = (s7_function)c_function_call(c_function_looped(ecdr(body)));
	    if (func(sc, sc->z = cons(sc, small_int(0), args))) /* make it compatible with the other looped calls */
	      goto START; /* won't happen? */
	    /* else fall into the ordinary loop */
	  }

	func = (s7_function)fcdr(body);
	while (true) {func(sc, args);}
      }


      /* --------------- */
    SIMPLE_DO_P:
    case OP_SIMPLE_DO_P:
      {
	/* body is one line, syntactic */
	s7_pointer init, end, code;
	code = sc->code;
	sc->envir = new_frame_in_env(sc, sc->envir);

	init = cadaar(code);
	if (is_symbol(init))
	  sc->value = finder(sc, init);
	else 
	  {
	    if (is_pair(init))
	      sc->value = c_call(init)(sc, cdr(init));
	    else sc->value = init;
	  }
	environment_dox1(sc->envir) = add_slot(sc, caaar(code), sc->value);
	
	end = caddr(caadr(code));
	if (is_symbol(end))
	  sc->args = find_symbol(sc, end);
	else 
	  {
	    s7_pointer slot;
	    NEW_CELL_NO_CHECK(sc, slot);
	    slot_symbol(slot) = end;
	    slot_set_value(slot, end);
	    set_type(slot, T_SLOT | T_IMMUTABLE);
	    sc->args = slot;
	  }
	environment_dox2(sc->envir) = sc->args;

	car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
	car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
	if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
	  {
	    sc->code = cdadr(code);
	    goto DO_BEGIN;
	  }

	/* (((i 0 (+ 1 i))) ((= i len)) (set! (v i) (read-mix-sample reader)))
	 */
	push_stack(sc, OP_SIMPLE_DO_STEP_P, sc->args, code);
	sc->code = caddr(code);
	goto EVAL;
      }


      /* --------------- */
    case OP_SIMPLE_DO_STEP_P:
      {
	s7_pointer step, ctr, code;
	code = sc->code;
	ctr = environment_dox1(sc->envir);

	step = fcdr(code);                   /* caddr(caar(sc->code)) */
	if (is_symbol(cadr(step)))
	  {
	    car(sc->T2_1) = slot_value(ctr);
	    car(sc->T2_2) = caddr(step);
	  }
	else
	  {
	    car(sc->T2_2) = slot_value(ctr);
	    car(sc->T2_1) = cadr(step);
	  }
	slot_set_value(ctr, c_call(step)(sc, sc->T2_1));

	car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
	car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
	if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
	  {
	    sc->code = cdadr(code);
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_SIMPLE_DO_STEP_P, sc->args, code);
	code = caddr(code);
	sc->cur_code = code;
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }


      /* --------------- */
    DOTIMES_P:
    case OP_DOTIMES_P:
      {
	s7_pointer init, end, code;
	code = sc->code;
	sc->envir = new_frame_in_env(sc, sc->envir);

	init = cadaar(code);
	if (is_symbol(init))
	  sc->value = finder(sc, init);
	else 
	  {
	    if (is_pair(init))
	      sc->value = c_call(init)(sc, cdr(init));
	    else sc->value = init;
	  }
	environment_dox1(sc->envir) = add_slot(sc, caaar(code), sc->value);
	
	set_fcdr(code, caadr(code));
	end = caddr(fcdr(code));
	if (is_symbol(end))
	  sc->args = find_symbol(sc, end);
	else 
	  {
	    s7_pointer slot;
	    NEW_CELL_NO_CHECK(sc, slot);
	    slot_symbol(slot) = end;
	    slot_set_value(slot, end);
	    set_type(slot, T_SLOT | T_IMMUTABLE);
	    sc->args = slot;
	  }
	environment_dox2(sc->envir) = sc->args;

	car(sc->T2_1) = slot_value(environment_dox1(sc->envir));
	car(sc->T2_2) = slot_value(environment_dox2(sc->envir));
	if (is_true(sc, c_call(caadr(code))(sc, sc->T2_1)))
	  {
	    sc->code = cdadr(code);
	    goto DO_BEGIN;
	  }
	push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
	sc->code = caddr(code);
	goto EVAL;
      }


      /* --------------- */
    case OP_DOTIMES_STEP_P:
      {
	s7_pointer ctr, now, end, code, end_test;

	code = sc->code;
	ctr = environment_dox1(sc->envir);
	now = slot_value(ctr);
	end = slot_value(environment_dox2(sc->envir));
	end_test = fcdr(code);

	if (is_integer(now))
	  {
	    slot_set_value(ctr, make_integer(sc, integer(now) + 1));
	    now = slot_value(ctr);
	    if (is_integer(end))
	      {
#if (!WITH_GMP)
		if ((integer(now) == integer(end)) ||
		    ((integer(now) > integer(end)) && 
		     (ecdr(end_test) == geq_2)))
#else
	        if (integer(now) == integer(end))
#endif
		  { 
		    sc->code = cdadr(code);
		    goto DO_BEGIN;
		  }
	      }
	    else
	      {
		car(sc->T2_1) = now;
		car(sc->T2_2) = end;
		if (is_true(sc, c_call(end_test)(sc, sc->T2_1)))
		  {
		    sc->code = cdadr(code);
		    goto DO_BEGIN;
		  }
	      }
	  }
	else
	  {
	    car(sc->T1_1) = now;
	    slot_set_value(ctr, g_add_s1(sc, sc->T1_1)); 
	    /* (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))
	     */
	    car(sc->T2_1) = slot_value(ctr);
	    car(sc->T2_2) = end;
	    if (is_true(sc, c_call(end_test)(sc, sc->T2_1)))
	      {
		sc->code = cdadr(code);
		goto DO_BEGIN;
	      }
	  }
	push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
	code = caddr(code);
	sc->cur_code = code;
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }



      /* --------------- */
      /* DOX cases */
    DOX:
    case OP_DOX:
      /* 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
       */
      {
	long long int id;
	s7_pointer frame, vars, slot;

	NEW_FRAME(sc, sc->envir, frame); /* new frame is not tied into the symbol lookup process yet */
	for (vars = car(sc->code); is_pair(vars); vars = cdr(vars))
	  {
	    s7_pointer expr;
	    NEW_CELL_NO_CHECK(sc, slot);	
	    slot_symbol(slot) = caar(vars);
	    
	    expr = cadar(vars);
	    if (is_pair(expr))
	      {
		if (car(expr) == sc->QUOTE)
		  slot_set_value(slot, cadr(expr));
		else slot_set_value(slot, ((dox_function)fcdr(cdar(vars)))(sc, expr, NULL));
	      }
	    else
	      {
		if (is_symbol(expr))
		  slot_set_value(slot, finder(sc, expr));
		else slot_set_value(slot, expr);
	      }
	    slot_expression(slot) = cddar(vars);
	    set_type(slot, T_SLOT | T_IMMUTABLE);
	    next_slot(slot) = environment_slots(frame);
	    environment_slots(frame) = slot;
	  }
	sc->envir = frame;
	id = environment_id(frame);
	for (slot = environment_slots(frame); is_slot(slot); slot = next_slot(slot))
	  symbol_set_local(slot_symbol(slot), id, slot);

	for (slot = environment_slots(frame); is_slot(slot); slot = next_slot(slot))
	  if (is_pair(slot_expression(slot)))
	    switch (lifted_op(slot_expression(slot)))
	      {
	      case DOX_STEP_SS: 
		slot_pending_value(slot) = find_symbol(sc, caddar(slot_expression(slot))); 
		break;

	      case DOX_STEP_S: 
		slot_pending_value(slot) = find_symbol(sc, cadar(slot_expression(slot)));  
		break;

	      case DOX_STEP_ADD:
		slot_pending_value(slot) = find_symbol(sc, caddar(slot_expression(slot))); 
		set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_add_ss);
#if (!WITH_GMP)
		if (type(slot_value(slot_pending_value(slot))) == type(slot_value(slot)))
		  {
		    if (is_integer(slot_value(slot)))
		      set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_add_i);
		    else
		      {
			if (type(slot_value(slot)) == T_REAL)
			  set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_add_f);
		      }
		  }
#endif
		break;

	      case DOX_STEP_SUBTRACT:
		slot_pending_value(slot) = find_symbol(sc, caddar(slot_expression(slot))); 
		set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_subtract_ss);
#if (!WITH_GMP)
		if (type(slot_value(slot_pending_value(slot))) == type(slot_value(slot)))
		  {
		    if (is_integer(slot_value(slot)))
		      set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_subtract_i);
		    else
		      {
			if (type(slot_value(slot)) == T_REAL)
			  set_fcdr(slot_expression(slot), (s7_pointer)step_dox_c_subtract_f);
		      }
		  }
#endif
		break;

	      case DOX_STEP_DEFAULT:
		break;
	      }

	initialize_dox_end_vars(sc, fcdr(sc->code));
	
	if (is_true(sc, ((s7_function)fcdr(cdr(sc->code)))(sc, fcdr(sc->code))))
	  {
	    /* if no end result exprs, we return nil, but others probably #<unspecified>
	     *    (let ((x (do ((i 0 (+ i 1))) (#t)))) x) -> '()
	     */
	    sc->code = cdadr(sc->code);
	    goto DO_BEGIN;
	  }

	{
	  s7_pointer code;
	  code = cddr(sc->code);

	  if (is_null(code))
	    {
	      s7_function endf;
	      s7_pointer endp, slots;
	      endf = (s7_function)fcdr(cdr(sc->code));
	      endp = fcdr(sc->code);
	      slots = environment_slots(sc->envir);
	      while (true)
		{
		  s7_pointer slot;
		  for (slot = slots; is_slot(slot); slot = next_slot(slot))
		    if (is_pair(slot_expression(slot)))
		      slot_set_value(slot, ((dox_function)fcdr(slot_expression(slot)))(sc, car(slot_expression(slot)), slot));
		  if (is_true(sc, endf(sc, endp)))
		    {
		      sc->code = cdadr(sc->code);
		      goto DO_BEGIN;
		    }
		}
	    }
	  if ((is_null(cdr(code))) &&
	      (is_pair(car(code))))
	    {
	      code = car(code);

	      if ((typesflag(code) == SYNTACTIC_PAIR) ||
		  (typeflag(car(code)) == SYNTACTIC_TYPE))
		{
		  push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);

		  if (typesflag(code) == SYNTACTIC_PAIR)
		    sc->op = (opcode_t)lifted_op(code);
		  else
		    {
		      sc->op = (opcode_t)syntax_opcode(car(code));
		      lifted_op(code) = sc->op;
		      set_type(code, SYNTACTIC_PAIR);
		    }

		  /* fprintf(stderr, "%d (dox) %s\n", __LINE__, DISPLAY_80(code)); */
		  sc->code = cdr(code);

		  goto START_WITHOUT_POP_STACK;
		}
	      
	    if (is_symbol(car(code)))
	      {
		s7_pointer f;
		f = s7_symbol_value(sc, car(code));

		if ((is_c_function(f)) &&
		    (c_function_ex_parser(f)))
		  {
		    s7_ex *exd = NULL;
		    exd = c_function_ex_parser(f)(sc, code);
		    if (exd)
		      {
			s7_function endf;
			s7_pointer endp, slots, slot;
			int arg;
			s7_pointer p, slot1 = NULL, slot2 = NULL, slot3 = NULL, expr1 = NULL, expr2 = NULL, expr3 = NULL;
			dox_function d1 = NULL, d2 = NULL, d3 = NULL;
			bool mut; /* C++ claims "mutable" */

			mut = is_step_safe(f);

			for (arg = 0, p = environment_slots(sc->envir); is_slot(p); p = next_slot(p))
			  if (is_pair(slot_expression(p)))
			    {
			      arg++;
			      if (!slot1) 
				{
				  slot1 = p; 
				  expr1 = slot_expression(slot1);
				  if (mut)
				    d1 = dox_mutate(sc, p);
				  else d1 = (dox_function)fcdr(expr1);
				  expr1 = car(expr1);
				}
			      else 
				{
				  if (!slot2)
				    {
				      slot2 = p;
				      expr2 = slot_expression(slot2);
				      if (mut)
					d2 = dox_mutate(sc, p);
				      else d2 = (dox_function)fcdr(expr2);
				      expr2 = car(expr2);
				    }
				  else
				    {
				      if (!slot3)
					{
					  slot3 = p;
					  expr3 = slot_expression(slot3);
					  if (mut)
					    d3 = dox_mutate(sc, p);
					  else d3 = (dox_function)fcdr(expr3);
					  expr3 = car(expr3);
					}
				    }
				}
			    }

			endf = (s7_function)fcdr(cdr(sc->code));
			endp = fcdr(sc->code);
			slots = environment_slots(sc->envir);

			if (arg == 1)
			  {
			    while (true)
			      {
				exd->ex_vf(exd->ex_data);
				slot_set_value(slot1, d1(sc, expr1, slot1));
				if (is_true(sc, endf(sc, endp)))
				  {
				    exd->ex_free(exd->ex_data);
				    free(exd);
				    sc->code = cdadr(sc->code);
				    if (!is_null(sc->code))
				      {
					if (mut)
					  clear_mutable(slot_value(slot1));
					goto BEGIN;
				      }
				    sc->value = sc->NIL;
				    goto START;	
				  }
			      }
			  }

			if (arg < 4)
			  {
			    while (true)
			      {
				exd->ex_vf(exd->ex_data);
				slot_set_value(slot1, d1(sc, expr1, slot1));
				slot_set_value(slot2, d2(sc, expr2, slot2));
				if (slot3) slot_set_value(slot3, d3(sc, expr3, slot3));
				if (is_true(sc, endf(sc, endp)))
				  {
				    exd->ex_free(exd->ex_data);
				    free(exd);
				    sc->code = cdadr(sc->code);
				    if (!is_null(sc->code))
				      {
					if (mut)
					  {
					    clear_mutable(slot_value(slot1));
					    clear_mutable(slot_value(slot2));
					    if (slot3) clear_mutable(slot_value(slot3));
					  }
					goto BEGIN;
				      }
				    sc->value = sc->NIL;
				    goto START;	
				  }
			      }
			  }
			
			while (true)
			  {
			    exd->ex_vf(exd->ex_data);
		    
			    for (slot = slots; is_slot(slot); slot = next_slot(slot))
			      if (is_pair(slot_expression(slot)))
				slot_set_value(slot, ((dox_function)fcdr(slot_expression(slot)))(sc, car(slot_expression(slot)), slot));

			    if (is_true(sc, endf(sc, endp)))
			      {
				exd->ex_free(exd->ex_data);
				free(exd);
				sc->code = cdadr(sc->code);
				if (!is_null(sc->code))
				  {
				    if (mut)
				      {
					if (slot1) clear_mutable(slot_value(slot1));
					if (slot2) clear_mutable(slot_value(slot2));
				      }
				    goto BEGIN;
				  }
				sc->value = sc->NIL;
				goto START;	
			      }
			  }
		      }
		  }
	      }
	    }
	}
	push_stack_no_args(sc, OP_DOX_STEP, sc->code);
	sc->code = cddr(sc->code);
	goto BEGIN;
      }
	

      /* --------------- */
      case OP_DOX_STEP:
	{
	  s7_pointer slot;

	  for (slot = environment_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
	    if (is_pair(slot_expression(slot)))
	      slot_set_value(slot, ((dox_function)fcdr(slot_expression(slot)))(sc, car(slot_expression(slot)), slot));

	  if (is_true(sc, ((s7_function)fcdr(cdr(sc->code)))(sc, fcdr(sc->code))))
	    {
	      sc->code = cdadr(sc->code);
	      goto DO_BEGIN;
	    }
	  push_stack_no_args(sc, OP_DOX_STEP, sc->code);
	  sc->code = cddr(sc->code);
	  if (is_pair(cdr(sc->code)))
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	  sc->code = car(sc->code);
	  goto EVAL;
	}

      case OP_DOX_STEP_P:
	{
	  s7_pointer slot;
	  for (slot = environment_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
	    if (is_pair(slot_expression(slot)))
	      slot_set_value(slot, ((dox_function)fcdr(slot_expression(slot)))(sc, car(slot_expression(slot)), slot));

	  if (is_true(sc, ((s7_function)fcdr(cdr(sc->code)))(sc, fcdr(sc->code))))
	    {
	      sc->code = cdadr(sc->code);
	      goto DO_BEGIN;
	    }
	  push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);
	  sc->code = caddr(sc->code);
	  sc->op = (opcode_t)lifted_op(sc->code);
	  sc->code = cdr(sc->code);
	  goto START_WITHOUT_POP_STACK;
	}
      

	/* we could use slot_pending_value, slot_expression, not this extra list, but the list seems simpler.
	 */
    #define DO_VAR_SLOT(P) ecdr(P)
    #define DO_VAR_NEW_VALUE(P) cdr(P)
    #define DO_VAR_STEP_EXPR(P) car(P)


      /* --------------- */
    case OP_DO_STEP:
      /* 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:
       *   '(((+ i 1) . 0))
       */
      push_stack(sc, OP_DO_END, sc->args, sc->code);
      sc->args = car(sc->args);                /* the var data lists */
      sc->code = sc->args;                     /* save the top of the list */

    DO_STEP1:
      /* on each iteration, each arg incr expr is evaluated and the value placed in caddr while we cdr down args
       * finally args is nil...
       */

      if (is_null(sc->args))
	{
	  s7_pointer x;

	  for (x = sc->code; is_not_null(x); x = cdr(x))
	    slot_set_value(DO_VAR_SLOT(car(x)), DO_VAR_NEW_VALUE(car(x)));

	  /* some schemes rebind here, rather than reset, but that is expensive,
	   *    and only matters once in a blue moon (closure over enclosed lambda referring to a do var)
	   *    and the caller can easily mimic the correct behavior in that case by adding a let or using a named let,
	   *    making the rebinding explicit.
	   *
	   * Hmmm... I'll leave this alone, but there are other less cut-and-dried cases:
	   *
	   *   (let ((j (lambda () 0))
	   *         (k 0))
	   *     (do ((i (j) (j))
	   *          (j (lambda () 1) (lambda () (+ i 1)))) ; bind here hits different "i" than set!
	   *         ((= i 3) k)
	   *       (set! k (+ k i))))
	   *
	   *   is it 6 or 3?
	   *
	   * if we had a way to tell that there were no lambdas in the do expression, would that
	   *   guarantee that set was ok?  Here's a bad case:
	   *
	   *   (let ((f #f))
	   *     (do ((i 0 (+ i 1)))
	   *         ((= i 3))
	   *       (let () ; so that the define is ok
	   *         (define (x) i)
	   *         (if (= i 1) (set! f x))))
	   *    (f))
	   *
	   * s7 says 3, guile says 1.
	   *
	   * I wonder if what they're actually talking about is a kind of shared value problem.  If we
	   *   set the value directly (not the cdr(binding) but, for example, integer(cdr(binding))), then
	   *   every previous reference gets changed as a side-effect.  In the current code, we're "binding" 
	   *   the value in the sense that on each step, a new value is assigned to the step variable.
	   *   In the "direct" case, (let ((v #(0 0 0))) (do ((i 0 (+ i 1))) ((= i 3) v) (set! (v i) i)) 
	   *   would return #(3 3 3).
	   *
	   * if sc->capture_env_counter changes, would it be sufficient to simply make a new slot?
	   *   I think not; the closure retains the current env chain, not the slots, so we need a new env.
	   */
	  
	  sc->value = sc->NIL;
	  pop_stack_no_op(sc); 
	  goto DO_END;
	}
      push_stack(sc, OP_DO_STEP2, sc->args, sc->code);
      
      /* here sc->args is a list like (((i . 0) (+ i 1) 0) ...)
       *   so sc->code becomes (+ i 1) in this case 
       */
      sc->code = DO_VAR_STEP_EXPR(car(sc->args));
      goto EVAL;
      

      /* --------------- */
    case OP_DO_STEP2:
      DO_VAR_NEW_VALUE(car(sc->args)) = sc->value;            /* save current value */
      sc->args = cdr(sc->args);                               /* go to next step var */
      goto DO_STEP1;


      /* --------------- */
    case OP_DO: 
      /* setup is very similar to let */
      /* sc->code is the stuff after "do" */
      if (is_null(check_do(sc)))
	{
	  if (car(ecdr(sc->code)) == sc->SIMPLE_DO)
	    goto SIMPLE_DO;
	  if (car(ecdr(sc->code)) == sc->SIMPLE_DO_P)
	    goto SIMPLE_DO_P;
	  if (car(ecdr(sc->code)) == sc->SIMPLE_DO_A)
	    goto SIMPLE_DO_A;
	  if (car(ecdr(sc->code)) == sc->DOTIMES_P)
	    goto DOTIMES_P;
	  if (car(ecdr(sc->code)) == sc->SAFE_DOTIMES_C_A)
	    goto SAFE_DOTIMES_C_A;
	  if (car(ecdr(sc->code)) == sc->SAFE_DOTIMES_C_C)
	    goto SAFE_DOTIMES_C_C;
	  if (car(ecdr(sc->code)) == sc->SIMPLE_SAFE_DOTIMES)
	    goto SIMPLE_SAFE_DOTIMES;
	  if (car(ecdr(sc->code)) == sc->SAFE_DO)
	    goto SAFE_DO;
	  if (car(ecdr(sc->code)) == sc->DOX)
	    goto DOX;
	  if (car(ecdr(sc->code)) == sc->SIMPLE_DO_FOREVER)
	    goto SIMPLE_DO_FOREVER;
	  goto SAFE_DOTIMES;
	}


      /* --------------- */
    case OP_DO_UNCHECKED:
      if (is_null(car(sc->code)))                           /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
	{
	  sc->envir = new_frame_in_env(sc, sc->envir); 
	  sc->args = cons_unchecked(sc, sc->NIL, cadr(sc->code));
	  sc->code = cddr(sc->code);
	  goto DO_END;
	}
      
      /* eval each init value, then set up the new frame (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 */
      

      /* --------------- */
    DO_INIT:
    case OP_DO_INIT:
      sc->args = cons(sc, sc->value, sc->args);    /* code will be last element (first after reverse) */
      if (is_pair(sc->code))
	{
	  /* here sc->code is a list like: ((i 0 (+ i 1)) ...)
	   *   so cadar gets the init value.
	   *
	   * we accept:
	   *       (do ((i 1) (i 2)) (#t i)) -> 2
	   *       (do () (1) . "hi") -- this is like (do () (#t #t) (asdf))
	   */
	  s7_pointer init;
	  init = cadar(sc->code);
	  if (is_pair(init))
	    {
	      push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code));
	      sc->code = init;
	      goto EVAL; 
	    }
	  if (is_symbol(init))
	    sc->value = finder(sc, init);
	  else sc->value = init;
	  sc->code = cdr(sc->code);
	  goto DO_INIT;
	}

      /* all the initial values are now in the args list */
      {
	s7_pointer x, y, z;
	sc->args = safe_reverse_in_place(sc, sc->args);
	sc->code = car(sc->args);                       /* saved at the start */
	z = sc->args;
	sc->args = cdr(sc->args);                       /* init values */

	/* sc->envir = new_frame_in_env(sc, sc->envir); */
	/* sc->args was cons'd above, so it should be safe to reuse it as the new frame */
	sc->envir = old_frame_in_env(sc, z, sc->envir);
	
	/* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->envir,
	 *    also reuse the value cells as the new frame slots.
	 */
	sc->value = sc->NIL;
	y = sc->args;
	for (x = car(sc->code); is_not_null(y); x = cdr(x)) 
	  {
	    s7_pointer sym, args, val;
	    sym = caar(x);
	    val = car(y);
	    args = cdr(y);
	    
	    slot_symbol(y) = sym;

	    if (symbol_has_accessor(sym))
	      {
		s7_pointer old_value;
		old_value = sc->value;
		slot_set_value(y, call_symbol_bind(sc, sym, val)); /* this might change sc->value */
		sc->value = old_value;
	      }
	    else slot_set_value(y, val);

	    /* var access checks during the step section? 
	     *   we'd want a separate iteration in that case to avoid slowing down the normal case
	     *
	     * to embed here, we need x, y, (sc->args? sc->code?), sc->value
	     *
	     * label at start of loop plus jump back at end
	     * if accessor and binder is scheme func
	     *   push_stack DO_INIT_WITH_ACCESSOR, args=x y value args, code, jumping back after apply
	     *   args='(sym val), code=scheme func, goto APPLY
	     *   DO_INIT_WITH_ACCESSOR checks for 'error and jumps to
	     * DO_INIT_ACCESS:
	     *   reset x y code args from saved stuff
	     *   set cdr(y) from new value
	     *   restore old sc->value
	     * [before saving y, set its type?][will a gc clobber anything here?]
	     */

	    set_type(y, T_SLOT | T_IMMUTABLE);
	    next_slot(y) = environment_slots(sc->envir);
	    environment_slots(sc->envir) = y;
	    symbol_set_local(sym, environment_id(sc->envir), y);

	    if (is_not_null(cddar(x)))                /* else no incr expr, so ignore it henceforth */
	      {
		s7_pointer p;
		p = cons(sc, caddar(x), val);
		set_ecdr(p, y);
					              /* val is just a place-holder -- this is where we store the new value */
		sc->value = cons_unchecked(sc, p, sc->value);
	      }
	    y = args;
	  }
	sc->args = cons(sc, safe_reverse_in_place(sc, sc->value), cadr(sc->code));
	sc->code = cddr(sc->code);
	
	/* here args is a list of 2 or 3 lists, first is (list (list (var . binding) incr-expr init-value) ...), second is end-expr, third can be result expr
	 *   so for (do ((i 0 (+ i 1))) ((= i 3) (+ i 1)) ...) args is ((((i . 0) (+ i 1) 0 #f)) (= i 3) (+ i 1))
	 */
      }


      /* --------------- */
    DO_END:
    case OP_DO_END:
      /* here vars have been init'd or incr'd
       *    args = (list var-data end-expr return-expr-if-any)
       *      if (do ((i 0 (+ i 1))) ((= i 3) 10)),            args: (vars (= i 3) 10)
       *      if (do ((i 0 (+ i 1))) ((= i 3))),               args: (vars (= i 3)) and result expr is () == (begin)
       *      if (do ((i 0 (+ i 1))) (#t 10 12)),              args: (vars #t 10 12), result: ([begin] 10 12) -> 12 
       *      if (call-with-exit (lambda (r) (do () () (r)))), args: '(())
       *    code = body
       */

      if (is_not_null(cdr(sc->args)))
	{
	  push_stack(sc, OP_DO_END1, sc->args, sc->code);
	  sc->code = cadr(sc->args);               /* evaluate the end expr */
	  goto EVAL;
	}
      else 
	{
	  /* (do ((...)) () ...) -- no endtest */

	  if (is_null(car(sc->args)))
	    push_stack(sc, OP_DO_END, sc->args, sc->code);
	  else push_stack(sc, OP_DO_STEP, sc->args, sc->code);
	  goto BEGIN;
	}


      /* --------------- */
    case OP_DO_END1:
      /* sc->value is the result of end-test evaluation */
      if (is_true(sc, sc->value))
	{
	  /* 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)
	   */
	  sc->code = cddr(sc->args);                /* result expr (a list -- implicit begin) */
	  
	  typeflag(sc->args) = 0;
	  (*(sc->free_heap_top++)) = sc->args;
	  sc->args = sc->NIL;

	  if (is_null(sc->code))
	    {
	      sc->value = sc->NIL;
	      goto START;
	    }
	}
      else
	{
	  /* evaluate the body and step vars, etc */
	  if (is_null(car(sc->args)))
	    push_stack(sc, OP_DO_END, sc->args, sc->code);
	  else push_stack(sc, OP_DO_STEP, sc->args, sc->code);
	  /* sc->code is ready to go */
	}
      if (is_pair(cdr(sc->code)))
	push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;


    DO_BEGIN:
      {
	/* I don't think this matters at all -- use BEGIN! */
	if (is_null(sc->code)) 
	  {
	    sc->value = sc->NIL;
	    goto START;
	  }
	if (is_pair(cdr(sc->code)))
	  {
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	    sc->code = car(sc->code);
	    goto EVAL;
	  }
	sc->code = car(sc->code);
	if (is_pair(sc->code))
	  goto EVAL;
	if (is_symbol(sc->code))
	  sc->value = finder(sc, sc->code);
	else sc->value = sc->code;
	goto START;
      }


    POP_BEGIN:
      {
	s7_pointer code;
	sc->envir = main_stack_environment(sc);
	code = main_stack_code(sc); 
	sc->code =  car(code); 
	if (is_null(cdr(code))) 
	  pop_main_stack(sc);                 
	else main_stack_code(sc) = cdr(code); 
	goto EVAL;
      }


      /* -------------------------------- BEGIN -------------------------------- */
    BEGIN:
    case OP_BEGIN:
      /* sc->args is not used here */
      if ((sc->begin_hook) && (call_begin_hook(sc))) return(sc->F);

      /* in gcc we can use computed gotos, setting begin_label to this position if
       *   begin_hook is not in use, thereby avoiding that check above.  This saves
       *   about 4 in lg -- sort of a toss-up given the added complexity.
       */

      /* check end + bad for immediate dot case */
      if (!is_pair(sc->code))                   /* (begin) -> () */
	{
	  if (is_not_null(sc->code))            /* (begin . 1), (cond (#t . 1)) */
	    eval_error_with_name(sc, "~A: unexpected dot or '() at end of body? ~A", sc->code);
	  sc->value = sc->NIL;
	  goto START;
	}


      /* --------------- */
    case OP_BEGIN1:
      /* sc->code is a pair here! */
      {
	s7_pointer code;
	code = sc->code;
	
	/* weird -- apparently cdr is null about 1/2 the time? and checking that cdr(code) != sc-NIL
	 *   is faster than type(code) == T_PAIR.
	 */
	if (!is_null(cdr(code)))
	  {
	    if (is_pair(cdr(code)))
	      push_stack_no_args(sc, OP_BEGIN1, cdr(code)); 
	    /* we can't just skip over symbols here because they might normally trigger an error (unbound variable, etc) */
	    else eval_error_with_name(sc, "~A: unexpected dot or '() at end of body? ~A", code);
	  }

	sc->code = car(code);
	/* goto EVAL; */
      }

      

      /* --------------- */
    EVAL:
    case OP_EVAL: 
      /* main part of evaluation 
       *   at this point, it's sc->code we care about; sc->args is not relevant.
       */
      /* fprintf(stderr, "    eval: %s\n", DISPLAY_80(sc->code)); */

      if (typesflag(sc->code) == SYNTACTIC_PAIR)
	{
	  sc->cur_code = sc->code;               /* in case an error occurs, this helps tell us where we are */
	  /* sc->op = (opcode_t)syntax_opcode(car(sc->code)); */
	  sc->op = (opcode_t)lifted_op(sc->code);
	  sc->code = cdr(sc->code);
	  goto START_WITHOUT_POP_STACK;
	  /* it is only slightly faster to use labels as values (computed gotos) here
	   */
	}

    NS_EVAL:
      if (is_optimized(sc->code)) 
	{
	  s7_pointer code;
	  
	OPT_EVAL:
	  code = sc->code;
	  sc->cur_code = code;
	  /* fprintf(stderr, "opt eval: %s %s %s\n", opt_names[optimize_op(code)], DISPLAY_80(code), describe_type_bits(sc, car(code))); */

	  switch (optimize_op(code))
	    {
	    case OP_NOT_AN_OP:
	    case HOP_NOT_AN_OP:
	      break;
	      
	    case OP_THUNK:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 0))
		{
		  set_optimize_data(code, OP_UNKNOWN);
		  goto OPT_EVAL;
		}
	      
	    case HOP_THUNK:
	      NEW_FRAME(sc, closure_environment(ecdr(code)), sc->envir);
	      sc->code = closure_body(ecdr(code));
	      goto BEGIN;
	      
	      
	    case OP_SAFE_THUNK:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 0))
		{
		  set_optimize_data(code, OP_UNKNOWN);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_THUNK:
	      /* (let ((x 1)) (let () (define (f) x) (let ((x 0)) (define (g) (set! x 32) (f)) (g)))) */
	      /* NEW_FRAME(sc, closure_environment(ecdr(code)), sc->envir); */

	      sc->envir = closure_environment(ecdr(code));
	      sc->code = closure_body(ecdr(code));
	      if (is_pair(cdr(sc->code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	      sc->code = car(sc->code);
	      goto EVAL;


	    case OP_SAFE_CLOSURE_S:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_S:
	      /* since a tail call is safe, we can't change the current env's environment_id until
	       *   after we do the lookup -- it might be the current func's arg, and we're
	       *   about to call the same func.
	       */
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), finder(sc, fcdr(code)));
	      sc->code = closure_body(ecdr(code));
	      if (is_pair(cdr(sc->code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	      sc->code = car(sc->code);
	      goto EVAL;
	      

	    case OP_SAFE_CLOSURE_S_Z:
	      /* this is a one line safe closure taking one symbol arg 
	       *   of course, it's possible it isn't any such thing (sigh), but we'll be ok anyway
	       *   because the switch in opt_eval will default to falling into the backup evaluator.
	       */
	      if (!one_line_closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_S_Z:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), finder(sc, fcdr(code)));
	      sc->code = car(closure_body(ecdr(code)));
	      goto OPT_EVAL; 
	      

	    case OP_SAFE_CLOSURE_S_P:
	      if (!one_line_closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_S_P:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), finder(sc, fcdr(code)));
	      sc->code = car(closure_body(ecdr(code)));
	      goto EVAL; 
	      

	    case OP_SAFE_CLOSURE_C:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_C);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_C:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), cadr(code));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;

	      
	    case OP_SAFE_CLOSURE_Q:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_Q);
		  goto OPT_EVAL;
		}

	      
	    case HOP_SAFE_CLOSURE_Q:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), cadr(cadr(code)));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_opCq:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_opCq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_opCq:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), c_call(fcdr(code))(sc, cdr(fcdr(code))));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_opSq:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_opSq:
	      car(sc->T1_1) = finder(sc, fcdr(code));
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), c_call(cadr(code))(sc, sc->T1_1));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_SS:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_SS:
	      sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), finder(sc, fcdr(code)));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;


	    case OP_SAFE_CLOSURE_SC:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SC);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_SC:
	      sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), fcdr(code));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_CS:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_CS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_CS:
	      sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), cadr(code), finder(sc, fcdr(code)));
	      code = closure_body(ecdr(code));
	      if (is_pair(cdr(code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(code));
	      sc->code = car(code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_SA:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_ALL_X);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_SA:
	      {
		s7_pointer args;
		args = cddr(code);
		args = ((s7_function)fcdr(args))(sc, car(args));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), args);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }
	      
	      

	    case OP_SAFE_CLOSURE_opSq_opSq:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_opSq_opSq:
	      {
		s7_pointer args;
		args = cdr(code);
		
		car(sc->T1_1) = finder(sc, fcdr(args));
		sc->temp4 = c_call(car(args))(sc, sc->T1_1);
		car(sc->T1_1) = finder(sc, fcdr(code));

		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), sc->temp4, c_call(cadr(args))(sc, sc->T1_1));
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }


	    case OP_SAFE_CLOSURE_CAR_CAR:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_opSq);
		  goto OPT_EVAL;
		}

	    case HOP_SAFE_CLOSURE_CAR_CAR:
	      {
		s7_pointer p1, p2;
		p1 = finder(sc, fcdr(cdr(code)));
		if (is_pair(p1))
		  p1 = car(p1);
		else p1 = g_car(sc, cdr(cadr(code)));
		p2 = finder(sc, fcdr(code));
		if (is_pair(p2))
		  p2 = car(p2);
		else p2 = g_car(sc, list_1(sc, p2));
		
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), p1, p2);
		sc->code = car(closure_body(ecdr(code)));
		if (is_immediate(sc->code))
		  {
		    sc->value = c_call(sc->code)(sc, cdr(sc->code));
		    goto START;
		  }
		goto EVAL;
	      }

	      
	    case OP_SAFE_CLOSURE_CDR_CDR:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_opSq);
		  goto OPT_EVAL;
		}

	    case HOP_SAFE_CLOSURE_CDR_CDR:
	      {
		s7_pointer p1, p2;
		p1 = finder(sc, fcdr(cdr(code)));
		if (is_pair(p1))
		  p1 = cdr(p1);
		else p1 = g_cdr(sc, cdr(cadr(code)));
		p2 = finder(sc, fcdr(code));
		if (is_pair(p2))
		  p2 = cdr(p2);
		else p2 = g_cdr(sc, list_1(sc, p2));

		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), p1, p2);
		sc->code = car(closure_body(ecdr(code)));
		if (is_immediate(sc->code))
		  {
		    sc->value = c_call(sc->code)(sc, cdr(sc->code));
		    goto START;
		  }
		goto EVAL;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_opSq_S:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_S);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_opSq_S:
	      {
		s7_pointer val1;
		val1 = finder(sc, fcdr(code));
		car(sc->T1_1) = finder(sc, cadr(cadr(code)));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), c_call(cadr(code))(sc, sc->T1_1), val1);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_S_opSq:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_S_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_S_opSq:
	      {
		s7_pointer val;
		val = finder(sc, cadr(code)); /* the first S */
		car(sc->T1_1) = finder(sc, cadr(caddr(code)));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), val, c_call(caddr(code))(sc, sc->T1_1));
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }

	      
	    case OP_SAFE_CLOSURE_S_opSSq:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_S_opSSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_S_opSSq:
	      {
		s7_pointer val, args;
		val = finder(sc, cadr(code));
		args = caddr(code);
		car(sc->T2_1) = finder(sc, cadr(args));
		car(sc->T2_2) = finder(sc, caddr(args));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), val, c_call(args)(sc, sc->T2_1));
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }

	      
	    case OP_SAFE_CLOSURE_opSSq_S:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSSq_S);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_CLOSURE_opSSq_S:
	      {
		/* (let () (define (hi a b) (+ a b)) (define (ho a b c) (hi (log a b) c)) (ho 8 2 3)) -> 6 */
		s7_pointer val, args;

		val = finder(sc, caddr(code));
		args = cadr(code);
		car(sc->T2_1) = finder(sc, cadr(args));
		car(sc->T2_2) = finder(sc, caddr(args));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), c_call(args)(sc, sc->T2_1), val);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }


	    case OP_SAFE_CLOSURE_SAA:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 3))
		break;

	    case HOP_SAFE_CLOSURE_SAA:
	      {
		s7_pointer args, y, z;
		args = cddr(code);
		y = ((s7_function)fcdr(args))(sc, car(args));
		args = cdr(args);
		z = ((s7_function)fcdr(args))(sc, car(args));
		sc->envir = old_frame_with_three_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), y, z);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }


	    case OP_SAFE_CLOSURE_S_CDR_CDR:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 3))
		break;

	    case HOP_SAFE_CLOSURE_S_CDR_CDR:
	      {
		s7_pointer args, y, z;
		args = cddr(code);
		y = finder(sc, cadar(args));
		args = cdr(args);
		z = finder(sc, cadar(args));

		if (is_pair(y))
		  y = cdr(y);
		else y = g_cdr(sc, cdr(caddr(code)));
		if (is_pair(z))
		  z = cdr(z);
		else z = g_cdr(sc, cdr(cadddr(code)));

		sc->envir = old_frame_with_three_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), y, z);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }


	      /* this gets only a few calls */
	    case OP_SAFE_CLOSURE_SSS:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 3))
		{
		  set_optimize_data(code, OP_UNKNOWN_SSS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_SSS:
	      {
		s7_pointer y, z;
		z = finder(sc, fcdr(code)); 
		y = finder(sc, caddr(code));
		sc->envir = old_frame_with_three_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), y, z);
		code = closure_body(ecdr(code));
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_ALL_C:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, integer(arglist_length(code))))
		break;
	      
	    case HOP_SAFE_CLOSURE_ALL_C:
	      sc->args = cdr(code);
	      sc->code = ecdr(code);
	      goto SAFE_CLOSURE;
	      
	      
	    case OP_SAFE_CLOSURE_ALL_X:
	      if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, integer(arglist_length(code))))
		break;

	    case HOP_SAFE_CLOSURE_ALL_X:
	      {
		s7_pointer args, p;
		int num_args;
		num_args = integer(arglist_length(code));
		if ((num_args != 0) &&
		    (num_args < NUM_SAFE_LISTS) &&
		    (!list_is_in_use(sc->safe_lists[num_args])))
		  {
		    sc->args = sc->safe_lists[num_args];
		    set_list_in_use(sc->args);
		  }
		else sc->args = make_list(sc, num_args, sc->NIL); 

		for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
		  car(p) = ((s7_function)fcdr(args))(sc, car(args));
		clear_list_in_use(sc->args);
		sc->code = ecdr(code);
		/* goto SAFE_CLOSURE; */
	      }
	      
	    SAFE_CLOSURE:
	      {
		s7_pointer env, x, z;
		unsigned long long int id;
		
		id = ++environment_number;
		env = closure_environment(sc->code);
		environment_id(env) = id;
		
		for (x = environment_slots(env), z = sc->args; is_slot(x); x = next_slot(x), z = cdr(z))
		  {
		    slot_set_value(x, car(z));
		    symbol_set_local(slot_symbol(x), id, x);
		  }
		sc->envir = env;
		sc->code = closure_body(sc->code);
		
		if (is_pair(cdr(sc->code)))
		  {
		    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		    sc->code = car(sc->code);
		  }
		else
		  {
		    sc->code = car(sc->code);
		    if (is_optimized(sc->code))
		      goto OPT_EVAL;
		  }
		goto EVAL;
	      }
	      
	      
	      

	      
	      /* -------------------------------------------------------------------------------- */

	    case OP_SAFE_CLOSURE_STAR_SS:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_STAR_SS:
	      {
		s7_pointer x, val1, val2;
		/* the finders have to operate in the current environment, so we can't change sc->envir until later */
		val1 = finder(sc, cadr(code));
		val2 = finder(sc, fcdr(code)); /* caddr */
		sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), val1);

		x = next_slot(environment_slots(closure_environment(ecdr(code))));
		slot_set_value(x, val2); 
		symbol_set_local(slot_symbol(x), environment_id(sc->envir), x);

		car(sc->T2_1) = next_slot(x);
		car(sc->T2_2) = cddr(closure_args(ecdr(code)));
		goto FILL_SAFE_CLOSURE_STAR;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_STAR_SC:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 2)) /* ?? this omitted the _STAR */
		{
		  set_optimize_data(code, OP_UNKNOWN_SC);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_STAR_SC:
	      {
		s7_pointer x;
		sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)));

		x = next_slot(environment_slots(closure_environment(ecdr(code))));
		slot_set_value(x, caddr(code));
		symbol_set_local(slot_symbol(x), environment_id(sc->envir), x);

		car(sc->T2_1) = next_slot(x);
		car(sc->T2_2) = cddr(closure_args(ecdr(code)));
		goto FILL_SAFE_CLOSURE_STAR;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_STAR_SA:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 2)) /* ?? this omitted the _STAR */
		break;
	      
	    case HOP_SAFE_CLOSURE_STAR_SA:
	      {
		s7_pointer arg;
		/* the second arg needs to be evaluated before we set sc->envir.
		 *   we checked at optimize time that this closure takes only 2 args.
		 */
		arg = cddr(code);
		arg = ((s7_function)fcdr(arg))(sc, car(arg));
		sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), arg);
		
		sc->code = closure_body(ecdr(code));
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	      
	      
	    case OP_SAFE_CLOSURE_STAR_ALL_X:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, integer(arglist_length(code)))) /* ?? this omitted the _STAR */
		break;

	    case HOP_SAFE_CLOSURE_STAR_ALL_X:
	      {
		s7_pointer args, p, orig_args, e;
		/* (let () (define* (hi (a 1)) (+ a 1)) (define (ho) (hi (* 2 3))) (ho)) 
		 * (do ((i 0 (+ i 1))) ((= i 11)) (envelope-interp (/ i 21) '(0 0 100 1)))
		 */

		e = closure_environment(ecdr(code));
		for (args = cdr(code), p = environment_slots(e), orig_args = closure_args(ecdr(code)); 
		     is_pair(args); 
		     args = cdr(args), orig_args = cdr(orig_args), p = next_slot(p))
		  slot_pending_value(p) = ((s7_function)fcdr(args))(sc, car(args));
		
		/* we're out of caller's args, so fill rest of environment slots from the defaults */
		for (; is_slot(p); p = next_slot(p), orig_args = cdr(orig_args))
		  {
		    s7_pointer defval;
		    if (is_pair(car(orig_args)))
		      {
			defval = cadar(orig_args);
			if (is_pair(defval))
			  slot_pending_value(p) = cadr(defval);
			else slot_pending_value(p) = defval;
		      }
		    else slot_pending_value(p) = sc->F;
		  }

		/* we have to put off the actual environment update in case this is a tail recursive call */
		environment_id(e) = ++environment_number;
		for (p = environment_slots(e); is_slot(p); p = next_slot(p))
		  {
		    slot_set_value(p, slot_pending_value(p));
		    symbol_set_local(slot_symbol(p), environment_id(e), p);
		  }
		
		sc->envir = e;
		sc->code = closure_body(ecdr(code));
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }


	    case OP_SAFE_CLOSURE_STAR:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 0))
		{
		  set_optimize_data(code, OP_UNKNOWN);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_STAR:
	      /* (let () (define* (hi (a 100)) (random a)) (define (ho) (hi)) (ho)) */
	      sc->envir = closure_environment(ecdr(code));
	      environment_id(sc->envir) = ++environment_number;
	      car(sc->T2_1) = environment_slots(closure_environment(ecdr(code)));
	      car(sc->T2_2) = closure_args(ecdr(code));
	      goto FILL_SAFE_CLOSURE_STAR;


	    case OP_SAFE_CLOSURE_STAR_S0:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_STAR_S0:
	      sc->envir = old_frame_with_two_slots(sc, closure_environment(ecdr(code)), finder(sc, cadr(code)), real_zero);
	      sc->code = closure_body(ecdr(code));
	      if (is_pair(cdr(sc->code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	      sc->code = car(sc->code);
	      goto EVAL;
	      
	      
	    case OP_SAFE_CLOSURE_STAR_S:
	      if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_SAFE_CLOSURE_STAR_S:
	      sc->envir = old_frame_with_slot(sc, closure_environment(ecdr(code)), finder(sc, fcdr(code)));
	      /* that sets the first arg to the passed symbol value; now set default values, if any */
	      car(sc->T2_1) = next_slot(environment_slots(closure_environment(ecdr(code))));
	      car(sc->T2_2) = cdr(closure_args(ecdr(code)));
	      /* fall through */

	      FILL_SAFE_CLOSURE_STAR:
		{
		  s7_pointer p, x;
		  x = car(sc->T2_1);
		  p = car(sc->T2_2);
		  for (; is_pair(p); p = cdr(p), x = next_slot(x))
		    {
		      s7_pointer defval;
		      if (is_pair(car(p)))
			{
			  defval = cadar(p);
			  if (is_pair(defval))
			    slot_set_value(x, cadr(defval));
			  else slot_set_value(x, defval);
			}
		      else slot_set_value(x, sc->F);
		      symbol_set_local(slot_symbol(x), environment_id(sc->envir), x);
		    }
		  }
		sc->code = closure_body(ecdr(code));
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      
	      
	      /* -------------------------------------------------------------------------------- */

	    case OP_GOTO:
	      set_ecdr(code, finder(sc, car(code)));
	      if (!is_goto(ecdr(code)))
		{
		  set_optimize_data(code, OP_UNKNOWN);
		  goto OPT_EVAL;
		}

	    case HOP_GOTO:
	      sc->args = sc->NIL;
	      sc->code = ecdr(code);
	      call_with_exit(sc);
	      goto START;
	      

	    case OP_GOTO_C:
	      /* call-with-exit repeat use internally is very rare, so let's just look it up 
	       */
	      set_ecdr(code, finder(sc, car(code)));
	      if (!is_goto(ecdr(code)))
		{
		  set_optimize_data(code, OP_UNKNOWN_C);
		  goto OPT_EVAL;
		}

	    case HOP_GOTO_C:
	      /* (return #t) -- recognized via OP_UNKNOWN_C, ecdr(code) is the function [parallels OP_CLOSURE_C]
	       */
	      sc->args = cdr(code);
	      sc->code = ecdr(code);
	      call_with_exit(sc);
	      goto START;
	      

	    case OP_GOTO_S:
	      set_ecdr(code, finder(sc, car(code)));
	      if (!is_goto(ecdr(code)))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}

	    case HOP_GOTO_S:
	      sc->args = list_1(sc, finder(sc, cadr(code)));
	      /* I think this needs listification because call_with_exit might call dynamic unwinders etc. */
	      sc->code = ecdr(code);
	      call_with_exit(sc);
	      goto START;
	      

	    case OP_CLOSURE_C:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_C);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_C:
	      sc->value = cadr(code);
	      goto UNSAFE_CLOSURE_ONE;
	      
	      
	    case OP_CLOSURE_Q:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_Q);
		  goto OPT_EVAL;
		}

	      
	    case HOP_CLOSURE_Q:
	      sc->value = cadr(cadr(code));
	      goto UNSAFE_CLOSURE_ONE;
	      
	      
	    case OP_CLOSURE_opCq:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_opCq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_CLOSURE_opCq:
	      sc->value = c_call(fcdr(code))(sc, cdr(fcdr(code)));
	      goto UNSAFE_CLOSURE_ONE;
	      
	      
	    case OP_CLOSURE_opSq:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_CLOSURE_opSq:
	      car(sc->T1_1) = find_symbol_or_bust(sc, fcdr(code));
	      sc->value = c_call(cadr(code))(sc, sc->T1_1);
	      goto UNSAFE_CLOSURE_ONE;
	      
	      
	      
	    case OP_CLOSURE_CDR_S:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_CDR_S:
	      {
		s7_pointer p;
		p = find_symbol_or_bust(sc, cadr(cadr(code)));
		if (!is_pair(p))
		  sc->value = g_cdr(sc, list_1(sc, p));
		else sc->value = cdr(p);
		goto UNSAFE_CLOSURE_ONE;
	      }
	      
	      
	    case OP_CLOSURE_S:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_S:
	      sc->value = find_symbol_or_bust(sc, fcdr(code));
	      /* goto UNSAFE_CLOSURE_ONE; */
	      
	    UNSAFE_CLOSURE_ONE:
	      CHECK_STACK_SIZE(sc);
	      code = ecdr(sc->code);
	      NEW_FRAME_WITH_CHECKED_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), sc->value);
	      sc->code = closure_body(code);
	      if (is_pair(cdr(sc->code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	      sc->code = car(sc->code);
	      goto EVAL;
	      

	    case OP_CLOSURE_Sp:
	      if (!one_line_closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_Sp:
	      CHECK_STACK_SIZE(sc);
	      sc->value = find_symbol_or_bust(sc, cadr(code));
	      code = ecdr(code);
	      NEW_FRAME_WITH_SLOT(sc, closure_environment(code), sc->envir, car(closure_args(code)), sc->value); 
	      sc->code = car(closure_body(code));
	      goto EVAL;  


	    case OP_CLOSURE_SSp:
	      if (!one_line_closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_SSp:
	      {
		s7_pointer p;
		if (sc->stack_end >= sc->stack_resize_trigger)
		  increase_stack_size(sc);
		sc->value = find_symbol_or_bust(sc, cadr(code));
		sc->z = find_symbol_or_bust(sc, fcdr(code));
		code = ecdr(code);
		p = closure_args(code);
		NEW_FRAME_WITH_TWO_SLOTS(sc, closure_environment(code), sc->envir, car(p), sc->value, cadr(p), sc->z);
		sc->code = car(closure_body(code));
		goto EVAL;  
	      }

	    case OP_CLOSURE_SSb:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_SSb:
	      {
		s7_pointer p;
		CHECK_STACK_SIZE(sc);
		sc->value = find_symbol_or_bust(sc, cadr(code));
		sc->z = find_symbol_or_bust(sc, fcdr(code));
		code = ecdr(code);
		p = closure_args(code);
		NEW_FRAME_WITH_TWO_SLOTS(sc, closure_environment(code), sc->envir, car(p), sc->value, cadr(p), sc->z);
		code = closure_body(code);
		if (is_pair(cdr(code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(code));
		sc->code = car(code);
		goto EVAL;
	      }


	    case OP_CLOSURE_SS:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_SS:
	      /* only called if one of these symbols has an accessor */
	      car(sc->T2_1) = find_symbol_or_bust(sc, cadr(code));
	      car(sc->T2_2) = find_symbol_or_bust(sc, fcdr(code));
	      goto UNSAFE_CLOSURE_TWO;
	      
	      
	    case OP_CLOSURE_SC:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SC);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_SC:
	      car(sc->T2_1) = find_symbol_or_bust(sc, cadr(code));
	      car(sc->T2_2) = fcdr(code);
	      goto UNSAFE_CLOSURE_TWO;
	      
	      
	    case OP_CLOSURE_CS:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_CS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_CS:
	      car(sc->T2_1) = cadr(code);
	      car(sc->T2_2) = find_symbol_or_bust(sc, fcdr(code));
	      goto UNSAFE_CLOSURE_TWO;
	      
	      
	    case OP_CLOSURE_opSq_opSq:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_CLOSURE_opSq_opSq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T1_1) = find_symbol_or_bust(sc, fcdr(args));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T1_1);
		car(sc->T1_1) = find_symbol_or_bust(sc, fcdr(code));
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
		goto UNSAFE_CLOSURE_TWO;
	      }
	      

	    case OP_CLOSURE_SSS:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 3))
		{
		  set_optimize_data(code, OP_UNKNOWN_SSS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_SSS:
	      {
		s7_pointer v1, v2, v3, args;
		args = cdr(code);
		
		v1 = find_symbol_or_bust(sc, fcdr(code));
		v2 = find_symbol_or_bust(sc, cadr(args));
		v3 = find_symbol_or_bust(sc, car(args));
		sc->args = list_3(sc, v3, v2, v1);
		sc->code = ecdr(code);
		/* goto UNSAFE_CLOSURE; */
	      }
	      
	      
	    UNSAFE_CLOSURE:
	      CHECK_STACK_SIZE(sc);
	      
	      NEW_FRAME(sc, closure_environment(sc->code), sc->envir);
	      {
		s7_pointer x, z, e;
		unsigned long long int id;
		
		e = sc->envir;
		id = environment_id(e);
		
		for (x = closure_args(sc->code), z = sc->args; is_pair(x); x = cdr(x))
		  {
		    s7_pointer sym, args, val;
		    sym = car(x);
		    val = car(z);
		    args = cdr(z);
		    slot_symbol(z) = sym;
		    symbol_set_local(sym, id, z);
		    if (symbol_has_accessor(sym))
		      slot_set_value(z, call_symbol_bind(sc, sym, val));
		    else slot_set_value(z, val);
		    set_type(z, T_SLOT | T_IMMUTABLE);
		    next_slot(z) = environment_slots(e);
		    environment_slots(e) = z;
		    z = args;
		  }

		sc->code = closure_body(sc->code);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }

	      
	    case OP_CLOSURE_ALL_C:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, integer(arglist_length(code))))
		break;
	      
	    case HOP_CLOSURE_ALL_C:
	      sc->args = copy_list(sc, cdr(code));
	      sc->code = ecdr(code);
	      goto UNSAFE_CLOSURE;
	      
	      
	    case OP_CLOSURE_ALL_S:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, integer(arglist_length(code))))
		{
		  set_optimize_data(code, OP_UNKNOWN_ALL_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_ALL_S:
	      {
		s7_pointer args, p, func, e;
		/* 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.
		 */
		CHECK_STACK_SIZE(sc);

		func = ecdr(code);
		/* we need to get the slot names from the current function, but the values from the calling environment
		 */
		NEW_FRAME(sc, closure_environment(func), e);
		sc->z = e;
		for (p = closure_args(func), args = cdr(code); is_pair(p); p = cdr(p), args = cdr(args))
		  ADD_SLOT(e, car(p), find_symbol_or_bust(sc, car(args)));
		sc->envir = e;

		sc->code = closure_body(func);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }

	      
	    case OP_CLOSURE_ALL_X:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, integer(arglist_length(code))))
		break;

	    case HOP_CLOSURE_ALL_X:
	      {
		/* here also, all the args are simple, major case is 3 args but would closure_aaa be faster?
		 */
		s7_pointer args, p, func, e;
		CHECK_STACK_SIZE(sc);

		func = ecdr(code);
		NEW_FRAME(sc, closure_environment(func), e);
		sc->z = e;

		for (p = closure_args(func), args = cdr(code); is_pair(p); p = cdr(p), args = cdr(args))
		  {
		    s7_pointer val;
		    val = ((s7_function)fcdr(args))(sc, car(args));
		    ADD_SLOT(e, car(p), val);
		  }
		sc->envir = e;

		sc->code = closure_body(func);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	      
	      
	    case OP_CLOSURE_opSq_S:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSq_S);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_CLOSURE_opSq_S:
	      {
		s7_pointer args;
		car(sc->T2_2) = find_symbol_or_bust(sc, fcdr(code));
		args = cadr(code);
		car(sc->T1_1) = find_symbol_or_bust(sc, cadr(args));
		car(sc->T2_1) = c_call(args)(sc, sc->T1_1);
		goto UNSAFE_CLOSURE_TWO;
	      }
	      
	      
	    case OP_CLOSURE_S_opSq:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_S_opSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_CLOSURE_S_opSq:
	      {
		s7_pointer args;
		car(sc->T2_1) = find_symbol_or_bust(sc, cadr(code));
		args = caddr(code);
		car(sc->T1_1) = find_symbol_or_bust(sc, cadr(args));
		car(sc->T2_2) = c_call(args)(sc, sc->T1_1);
		/* goto UNSAFE_CLOSURE_TWO; */
	      }
	      

	    UNSAFE_CLOSURE_TWO:
	      {
		s7_pointer args;
		CHECK_STACK_SIZE(sc);
		code = ecdr(sc->code);
		args = closure_args(code);

		NEW_FRAME_WITH_CHECKED_SLOT(sc, closure_environment(code), sc->envir, car(args), car(sc->T2_1));
		ADD_CHECKED_SLOT(sc->envir, cadr(args), car(sc->T2_2));

		sc->code = closure_body(code);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	      
	      
	    case OP_CLOSURE_S_opSSq:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_S_opSSq);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_CLOSURE_S_opSSq:
	      {
		s7_pointer args;
		car(sc->T1_1) = find_symbol_or_bust(sc, cadr(code));
		args = caddr(code);
		car(sc->T2_1) = find_symbol_or_bust(sc, cadr(args));
		car(sc->T2_2) = find_symbol_or_bust(sc, caddr(args));
		car(sc->T2_2) = c_call(args)(sc, sc->T2_1);
		car(sc->T2_1) = car(sc->T1_1);
		goto UNSAFE_CLOSURE_TWO;
	      }
	      
	      
	    case OP_CLOSURE_opSSq_S:
	      if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_opSSq_S);
		  goto OPT_EVAL;
		}
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_CLOSURE_opSSq_S:
	      {
		/* (let () (define (hi a b) (set! a (+ a 1)) (+ a b)) (define (ho a b c) (hi (log a b) c)) (ho 8 2 3)) -> 7 */
		s7_pointer args;

		car(sc->T1_1) = find_symbol_or_bust(sc, caddr(code));
		args = cadr(code);
		car(sc->T2_1) = find_symbol_or_bust(sc, cadr(args));
		car(sc->T2_2) = find_symbol_or_bust(sc, caddr(args));
		car(sc->T2_1) = c_call(args)(sc, sc->T2_1);
		car(sc->T2_2) = car(sc->T1_1);
		goto UNSAFE_CLOSURE_TWO;
	      }
	      

	      /* -------------------------------------------------------------------------------- */

	    case OP_CLOSURE_STAR_ALL_X:
	      if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, integer(arglist_length(code))))
		break;

	    case HOP_CLOSURE_STAR_ALL_X:
	      {
		/* here also, all the args are simple */
		/* (let () (define* (hi (a 1)) (list a)) (define (ho) (hi (* 2 3))) (ho)) 
		 */
		s7_pointer args, p, func, new_args;

		func = ecdr(code);
		sc->args = make_list(sc, closure_star_arity_to_int(sc, func), sc->NIL);
		new_args = sc->args;

		for (p = closure_args(func), args = cdr(code); is_pair(args); p = cdr(p), args = cdr(args), new_args = cdr(new_args))
		  car(new_args) = ((s7_function)fcdr(args))(sc, car(args));

		for (; is_pair(p); p = cdr(p), new_args = cdr(new_args))
		  {
		    s7_pointer defval;
		    if (is_pair(car(p)))
		      {
			defval = cadar(p);
			if (is_pair(defval))
			  car(new_args) = cadr(defval);
			else car(new_args) = defval;
		      }
		    else car(new_args) = sc->F;
		  }
		sc->code = ecdr(code);
		goto UNSAFE_CLOSURE_STAR;
	      }


	    UNSAFE_CLOSURE_STAR_TWO:
	      {
		s7_pointer args;
		code = ecdr(sc->code);
		args = closure_args(code);

		NEW_FRAME_WITH_CHECKED_SLOT(sc, closure_environment(code), sc->envir, (is_pair(car(args))) ? caar(args) : car(args), car(sc->T2_1));
		ADD_CHECKED_SLOT(sc->envir, (is_pair(cadr(args))) ? caadr(args) : cadr(args), car(sc->T2_2));

		sc->code = closure_body(code);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	      

	    case OP_CLOSURE_STAR_SX:
	      if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 2))
		{
		  set_optimize_data(code, OP_UNKNOWN_SS);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_STAR_SX:
	      {
		s7_pointer val1, val2, args;
		args = cddr(closure_args(ecdr(code)));
		val1 = find_symbol_or_bust(sc, cadr(code));
		val2 = caddr(code);
		if (is_symbol(val2))
		  val2 = find_symbol_or_bust(sc, val2);
		if (is_null(args))
		  {
		    car(sc->T2_1) = val1;
		    car(sc->T2_2) = val2;
		    goto UNSAFE_CLOSURE_STAR_TWO;
		  }

		sc->args = list_2(sc, val2, val1);
		sc->value = args;
		goto FILL_CLOSURE_STAR;
	      }


	    case OP_CLOSURE_STAR:
	      if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 0))
		{
		  set_optimize_data(code, OP_UNKNOWN);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_STAR:
	      /* (let () (define* (hi (a 1)) (list a)) (define (ho) (hi)) (ho)) */
	      sc->value = closure_args(ecdr(code));
	      sc->args = sc->NIL;
	      goto FILL_CLOSURE_STAR;



	    case OP_CLOSURE_STAR_S:
	      if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 1))
		{
		  set_optimize_data(code, OP_UNKNOWN_S);
		  goto OPT_EVAL;
		}
	      
	    case HOP_CLOSURE_STAR_S:
	      sc->value = cdr(closure_args(ecdr(code)));
	      sc->args = list_1(sc, find_symbol_or_bust(sc, fcdr(code)));
	      /* fall through */


	    FILL_CLOSURE_STAR:
	      {
		s7_pointer p;
		p = sc->value;
		for (; is_pair(p); p = cdr(p))
		  {
		    s7_pointer defval;
		    if (is_pair(car(p)))
		      {
			defval = cadar(p);
			if (is_pair(defval))
			  sc->args = cons(sc, cadr(defval), sc->args);
			else sc->args = cons(sc, defval, sc->args);
		      }
		    else sc->args = cons(sc, sc->F, sc->args);
		  }
		sc->args = safe_reverse_in_place(sc, sc->args);
		sc->code = ecdr(code);
		/* fall through */
	      }

	    UNSAFE_CLOSURE_STAR:
	      
	      NEW_FRAME(sc, closure_environment(sc->code), sc->envir);
	      {
		s7_pointer x, z, e;
		unsigned long long int id;
		
		e = sc->envir;
		id = environment_id(e);
		
		for (x = closure_args(sc->code), z = sc->args; is_pair(x); x = cdr(x))
		  {
		    s7_pointer sym, args, val;
		    if (is_pair(car(x)))
		      sym = caar(x);
		    else sym = car(x);
		    val = car(z);
		    args = cdr(z);

		    slot_symbol(z) = sym;
		    symbol_set_local(sym, id, z);
		    if (symbol_has_accessor(sym))
		      slot_set_value(z, call_symbol_bind(sc, sym, val));
		    else slot_set_value(z, val);
		    set_type(z, T_SLOT | T_IMMUTABLE);
		    next_slot(z) = environment_slots(e);
		    environment_slots(e) = z;
		    z = args;
		  }
		
		sc->code = closure_body(sc->code);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }


	      
	      /* -------------------------------------------------------------------------------- */

	      /* all of this code could be boiled down to a few tables
	       */
	    case OP_UNKNOWN:
	    case HOP_UNKNOWN:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		switch (type(f))
		  {
		  case T_C_OBJECT:
		    if (s7_is_aritable(sc, f, 0))
		      set_opt_and_goto_opt_eval(code, f, OP_C_OBJECT);
		    break;

		  case T_GOTO:
		    set_opt_and_goto_opt_eval(code, f, OP_GOTO);

		  case T_CLOSURE:
		    if (has_methods(f)) break;
		    if (is_null(closure_args(f)))
		      set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_THUNK : OP_THUNK)));
		    break;
		    
		  case T_CLOSURE_STAR:
		    if (has_methods(f)) break;
		    if (has_simple_args(closure_body(f)))
		      {
			if (is_global(car(code)))
			  set_hopping(code);
			set_opt_and_goto_opt_eval(code, f, ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR : OP_CLOSURE_STAR));
		      }
		    break;
		    
		  default:
		    break;
		  }
		break;
	      }
		    
	      
	    case OP_UNKNOWN_Q:
	    case HOP_UNKNOWN_Q:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		switch (type(f))
		  {
		  case T_ENVIRONMENT:
		    set_opt_and_goto_opt_eval(code, f, OP_ENVIRONMENT_Q);

		  case T_CLOSURE:
		    if (has_methods(f)) break;
		    if (closure_arity_to_int(sc, f) == 1)
		      set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_Q : OP_CLOSURE_Q)));
		    break;
		    
		  default:
		    break;
		  }
		break;
	      }


	    case OP_UNKNOWN_S:
	    case HOP_UNKNOWN_S:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		switch (type(f))
		  {
		  case T_VECTOR:
		    set_opt_and_goto_opt_eval(code, f, OP_VECTOR_S);
		    
		  case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
		    if ((c_function_required_args(f) <= 1) &&
			(c_function_all_args(f) >= 1))
		      {
			set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_S : OP_C_S);
			set_c_function(code, f);
			goto OPT_EVAL;
		      }
		    break;
		    
		  case T_STRING:
		    set_opt_and_goto_opt_eval(code, f, OP_STRING_S);
		    
		  case T_PAIR:
		    set_opt_and_goto_opt_eval(code, f, OP_PAIR_S);
		    
		  case T_CLOSURE:
		    if (has_methods(f)) break;
		    if (closure_arity_to_int(sc, f) == 1)
		      {
			set_fcdr(code, cadr(code));
			if (is_safe_closure(f))
			  {
			    s7_pointer body;
			    body = closure_body(f);
			    if (is_null(cdr(body)))
			      {
				if (is_h_optimized(car(body)))
				  set_optimize_data(code, OP_SAFE_CLOSURE_S_Z);
				else set_optimize_data(code, OP_SAFE_CLOSURE_S_P);
			      }
			    else set_optimize_data(code, OP_SAFE_CLOSURE_S);
			  }
			else 
			  {
			    set_optimize_data(code, OP_CLOSURE_S);
			    if ((is_null(cdr(closure_body(f)))) &&
				(!symbol_has_accessor(car(closure_args(f)))))
			      set_optimize_data(code, OP_CLOSURE_Sp);
			  }
			if (is_global(car(code)))
			  set_hopping(code);
			set_ecdr(code, f);
			goto OPT_EVAL;
		      }
		    break;

		  case T_CLOSURE_STAR:
		    if (has_methods(f)) break;
		    if ((has_simple_args(closure_body(f))) &&
			(!is_null(closure_args(f))))
		      {
			set_fcdr(code, cadr(code));
			set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_S : OP_CLOSURE_STAR_S)));
		      }
		    break;
		    
		  case T_C_OBJECT:
		    if (s7_is_aritable(sc, f, 1))
		      set_opt_and_goto_opt_eval(code, f, OP_C_OBJECT_S);
		    break;
		    
		  case T_ENVIRONMENT:
		    set_opt_and_goto_opt_eval(code, f, OP_ENVIRONMENT_S);
		    
		  case T_HASH_TABLE:
		    set_opt_and_goto_opt_eval(code, f, OP_HASH_TABLE_S);
		    
		  case T_GOTO:
		    set_opt_and_goto_opt_eval(code, f, OP_GOTO_S);
		    
		  default:
		    /* fprintf(stderr, "un_s: found %s %s\n", type_name(sc, f, 0), DISPLAY(code));  */
		    break;
		  }
		break;
	      }
	      
	    case OP_UNKNOWN_C:
	    case HOP_UNKNOWN_C:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		if (s7_is_aritable(sc, f, 1)) 
		  {
		    switch (type(f))
		      {
		      case T_VECTOR:
			set_opt_and_goto_opt_eval(code, f, OP_VECTOR_C);
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			/* if we switch to op_c_all_x here, we need to set fcdr */
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_C);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			break;
			
			/* here cadr can only be a non-negative integer, and in the pair case, car is optimizable
			 *   (so precheck could save check in OP_STRING|PAIR|VECTOR|etc|_C)
			 */
		      case T_STRING:
			set_opt_and_goto_opt_eval(code, f, OP_STRING_C);
			
		      case T_PAIR:
			set_opt_and_goto_opt_eval(code, f, OP_PAIR_C);
			
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 1)
			  set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_C : OP_CLOSURE_C)));
			break;
			
		      case T_C_OBJECT:
			set_opt_and_goto_opt_eval(code, f, OP_C_OBJECT_C);
			
		      case T_HASH_TABLE:
			set_opt_and_goto_opt_eval(code, f, OP_HASH_TABLE_C);

		      case T_GOTO:
			set_opt_and_goto_opt_eval(code, f, OP_GOTO_C);
			
			/* no need for t_environment here because its argument can't be a constant ?? (e +) can happen though it's an error
			 */
		      default:
			/* fprintf(stderr, "un_c: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
		break;
	      }
	      
	      /* split current in 2: current is default, and runs until a problem is noticed, then throws us here
	       *   unknown gets the new value and goes to the old form, doing the lookup everytime. 
	       */
	      
	    case OP_UNKNOWN_SS:
	    case HOP_UNKNOWN_SS:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_SS);
			    else 
			      {
				set_optimize_data(code, OP_CLOSURE_SS);
				if (!arglist_has_accessed_symbol(closure_args(f)))
				  set_optimize_data(code, ((is_null(cdr(closure_body(f)))) ? OP_CLOSURE_SSp : OP_CLOSURE_SSb));
			      }
			    if (is_global(car(code)))
			      set_hopping(code);
			    set_ecdr(code, f);
			    set_fcdr(code, caddr(code));
			    goto OPT_EVAL;
			  }
			break;

		      case T_CLOSURE_STAR:
			if (has_methods(f)) break;
			/* the closure* opts assume args are not keywords, but we can check that! */
			if ((!is_keyword(cadr(code))) &&
			    (!is_keyword(caddr(code))) &&
			    (has_simple_args(closure_body(f))) &&
			    (closure_star_arity_to_int(sc, f) >= 2))
			  {
			    set_fcdr(code, caddr(code));
			    set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_SS : OP_CLOSURE_STAR_SX)));
			  }
			break;

		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  set_optimize_data(code, OP_SAFE_C_SS);
			else
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			  }
 			set_arglist_length(code, small_int(2));
  			set_c_function(code, f);
  			goto OPT_EVAL;

		      case T_C_OBJECT:
			set_opt_and_goto_opt_eval(code, f, OP_C_OBJECT_SS);

		      default:
			/* fprintf(stderr, "un_ss: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_SC:
	    case HOP_UNKNOWN_SC:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    set_fcdr(code, caddr(code));
			    set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)));
			  }
			break;
			
		      case T_CLOSURE_STAR:
			if (has_methods(f)) break;
			if ((!is_keyword(cadr(code))) &&
			    (has_simple_args(closure_body(f))) &&
			    (closure_star_arity_to_int(sc, f) >= 2))
			  set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_SC : OP_CLOSURE_STAR_SX)));
			break;

		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  set_optimize_data(code, OP_SAFE_C_SC);
			else
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			  }
 			set_arglist_length(code, small_int(2));
			set_c_function(code, f);
			goto OPT_EVAL;
			
		      default:
			/* fprintf(stderr, "un_sc: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_CS:
	    case HOP_UNKNOWN_CS:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    set_fcdr(code, caddr(code));
			    set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_CS : OP_CLOSURE_CS)));
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  set_optimize_data(code, OP_SAFE_C_CS);
 			else
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			  }
 			set_arglist_length(code, small_int(2));
			set_c_function(code, f);
			goto OPT_EVAL;
			
		      default:
			/* fprintf(stderr, "un_cs: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_CC:
	    case HOP_UNKNOWN_CC:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if ((is_c_function(f)) &&
		    (s7_is_aritable(sc, f, 2)) &&
		    (is_safe_procedure(f)))
		  {
		    set_optimize_data(code, OP_SAFE_C_C);
		    set_c_function(code, f);
		    goto OPT_EVAL;
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_SSS:
	    case HOP_UNKNOWN_SSS:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 3))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 3)
			  {
			    set_ecdr(code, f);
			    set_fcdr(code, cadddr(code));
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_SSS);
			    else 
			      {
				if ((is_null(cdr(closure_body(f)))) &&
				    (!arglist_has_accessed_symbol(closure_args(f))))
				  {
				    set_arglist_length(code, small_int(3));
				    set_optimize_data(code, OP_CLOSURE_ALL_S);
				  }
				else set_optimize_data(code, OP_CLOSURE_SSS);
			      }
			    if (is_global(car(code)))
			      set_hopping(code);
			    
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_SSS);
			    set_ecdr(cdr(code), caddr(code));
			    set_fcdr(cdr(code), cadddr(code));
			  }
			else
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(3));
			  }
			set_c_function(code, f);
			goto OPT_EVAL;
			
		      default:
			/* fprintf(stderr, "un_sss: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_ALL_S:
	    case HOP_UNKNOWN_ALL_S:
	      {
		s7_pointer f;
		int num_args;
		f = find_symbol_or_bust(sc, car(code));

		num_args = integer(arglist_length(code));
		if (s7_is_aritable(sc, f, num_args))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if ((closure_arity_to_int(sc, f) == num_args) &&
			    (!arglist_has_accessed_symbol(closure_args(f))))
			  {
			    annotate_args(sc, cdr(code));
			    set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_S)));
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  set_optimize_data(code, OP_SAFE_C_ALL_S);
			else
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			  }
			set_c_function(code, f);
			goto OPT_EVAL;
			
		      default:
			/* fprintf(stderr, "un_all_s: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_ALL_X:
	    case HOP_UNKNOWN_ALL_X:
	      {
		s7_pointer f;
		int num_args;
		f = find_symbol_or_bust(sc, car(code));

		num_args = integer(arglist_length(code));
		if (s7_is_aritable(sc, f, num_args))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if ((closure_arity_to_int(sc, f) == num_args) &&
			    (!arglist_has_accessed_symbol(closure_args(f))))
			  {
			    annotate_args(sc, cdr(code));
			    if (is_safe_closure(f))
			      {
				if ((is_symbol(cadr(code))) &&
				    (num_args == 3))
				  {
				    if ((is_safely_optimized(caddr(code))) &&
					(is_safely_optimized(cadddr(code))) &&
					(c_call(caddr(code)) == g_cdr) &&
					(c_call(cadddr(code)) == g_cdr) &&
					(symbol_id(sc->CDR) == 0))
				      set_optimize_data(code, ((is_global(car(code))) ? 1 : 0) + OP_SAFE_CLOSURE_S_CDR_CDR);
				    else set_optimize_data(code, ((is_global(car(code))) ? 1 : 0) + OP_SAFE_CLOSURE_SAA);
				  }
				else set_optimize_data(code, ((is_global(car(code))) ? 1 : 0) + OP_SAFE_CLOSURE_ALL_X);
			      }
			    else set_optimize_data(code, ((is_global(car(code))) ? 1 : 0) + OP_CLOSURE_ALL_X);
			    set_ecdr(code, f);
			    goto OPT_EVAL;
			  }
			break;

		      case T_CLOSURE_STAR:
			if (has_methods(f)) break;
			if ((has_simple_args(closure_body(f))) &&
			    (closure_star_arity_to_int(sc, f) >= num_args) && 
			    (!arglist_has_keyword(cdr(code))) &&
			    (!arglist_has_accessed_symbol(closure_args(f))))
			    /* fcdr is already set -- we use it to get num_args above! */
			  {
			    annotate_args(sc, cdr(code));
			    set_opt_and_goto_opt_eval(code, f, (((is_global(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X)));
			  }
			break;

		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if ((num_args == 2) &&
			    (is_symbol(cadr(code))) &&
			    (is_pair(caddr(code))) &&
			    (is_optimized(caddr(code))))
			  {
			    if (optimize_data_match(caddr(code), OP_SAFE_C_S))
			      {
				set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_S_opSq : OP_C_S_opSq);
				set_ecdr(cdr(code), cadr(caddr(code)));
			      }
			    else
			      {
				if (optimize_data_match(caddr(code), OP_SAFE_C_C))
				  {
				    set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_S_opCq : OP_C_S_opCq);
				    set_ecdr(cdr(code), cdr(caddr(code)));
				  }
				else 
				  {
				    set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_AA : OP_C_ALL_X);
				    annotate_args(sc, cdr(code));
				  }
			      }
			  }
			else 
			  {
			    set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_ALL_X : OP_C_ALL_X);
			    annotate_args(sc, cdr(code));
			  }
			/* fprintf(stderr, "use %s for %s\n", opt_names[optimize_data(code)], DISPLAY(code)); */
			set_c_function(code, f);
			goto OPT_EVAL;

		      default:
			/* fprintf(stderr, "un_all_x: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_opCq:
	    case HOP_UNKNOWN_opCq:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		if (s7_is_aritable(sc, f, 1))
		  {
		    switch (type(f))
		      {
		      case T_VECTOR:
			if (is_hopping(cadr(code)))
			  set_opt_and_goto_opt_eval(code, f, OP_VECTOR_opCq);
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_opCq);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			if (is_all_x_safe(sc, cadr(code))) /* hop_safe_c_c here */
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(1));
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_STRING:
			set_opt_and_goto_opt_eval(code, f, OP_STRING_opCq);
			
		      case T_PAIR:
			set_opt_and_goto_opt_eval(code, f, OP_PAIR_opCq);
			
		      case T_C_OBJECT:
			set_opt_and_goto_opt_eval(code, f, OP_C_OBJECT_opCq);
			
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 1)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_opCq);
			    else set_optimize_data(code, OP_CLOSURE_opCq);
			    if ((is_global(car(code))) &&
				(is_hopping(cadr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    set_fcdr(code, cadr(code));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_opcq: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
		break;
	      }
	      
	      
	    case OP_UNKNOWN_opSq:
	    case HOP_UNKNOWN_opSq:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 1))
		  {
		    switch (type(f))
		      {
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_opSq);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			if (is_all_x_safe(sc, cadr(code)))
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(1));
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 1)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_opSq);
			    else 
			      {
				if ((is_safely_optimized(cadr(code))) &&
				    (c_call(cadr(code)) == g_cdr) &&
				    (symbol_id(sc->CDR)) == 0)
				  set_optimize_data(code, OP_CLOSURE_CDR_S);
				else set_optimize_data(code, OP_CLOSURE_opSq);
			      }
			    if ((is_global(car(code))) &&
				(is_hopping(cadr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    set_fcdr(code, cadr(cadr(code)));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_opsq: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_opSq_S:
	    case HOP_UNKNOWN_opSq_S:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_opSq_S);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			if (is_all_x_safe(sc, cadr(code)))
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(2));
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_opSq_S);
			    else 
			      {
				set_optimize_data(code, OP_CLOSURE_opSq_S);
			      }
			    if ((is_global(car(code))) &&
				(is_hopping(cadr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    set_fcdr(code, caddr(code));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_opsq_s: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_S_opSq:
	    case HOP_UNKNOWN_S_opSq:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_S_opSq);
			    else set_optimize_data(code, OP_CLOSURE_S_opSq); 
			    if ((is_global(car(code))) &&
				(is_hopping(caddr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			set_optimize_data(code, (is_safe_procedure(f)) ? OP_SAFE_C_S_opSq : OP_C_S_opSq);
			set_ecdr(cdr(code), cadr(caddr(code)));
			set_c_function(code, f);
			goto OPT_EVAL;
			break;
			
		      default:
			/* fprintf(stderr, "un_s_opsq: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_S_opSSq:
	    case HOP_UNKNOWN_S_opSSq:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_S_opSSq);
			    else set_optimize_data(code, OP_CLOSURE_S_opSSq); 
			    if ((is_global(car(code))) &&
				(is_hopping(caddr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    /* code: (+ a (* b c)) */
			    set_optimize_data(code, OP_SAFE_C_S_opSSq);
			    set_c_function(code, f);
			    set_ecdr(cdr(code), cadr(caddr(code)));
			    set_fcdr(cdr(code), caddr(caddr(code)));
			    goto OPT_EVAL;
			  }
			if (is_all_x_safe(sc, caddr(code)))
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(2));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_s_opssq: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_opSSq_S:
	    case HOP_UNKNOWN_opSSq_S:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));
		
		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_opSSq_S);
			    else set_optimize_data(code, OP_CLOSURE_opSSq_S);
			    if ((is_global(car(code))) &&
				(is_hopping(cadr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_opSSq_S);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			if (is_all_x_safe(sc, cadr(code)))
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(2));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_opssq_s: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;
	      
	      
	    case OP_UNKNOWN_opSq_opSq:
	    case HOP_UNKNOWN_opSq_opSq:
	      {
		s7_pointer f;
		f = find_symbol_or_bust(sc, car(code));

		if (s7_is_aritable(sc, f, 2))
		  {
		    switch (type(f))
		      {
		      case T_CLOSURE:
			if (has_methods(f)) break;
			if (closure_arity_to_int(sc, f) == 2)
			  {
			    if (is_safe_closure(f))
			      set_optimize_data(code, OP_SAFE_CLOSURE_opSq_opSq);
			    else set_optimize_data(code, OP_CLOSURE_opSq_opSq);
			    if ((is_null(cdr(closure_body(f)))) &&
				(!arglist_has_accessed_symbol(closure_args(f))))
			      {
				if ((is_optimized(car(closure_body(f)))) &&
				    (optimize_data(car(closure_body(f))) == HOP_SAFE_C_C))
				  set_immediate(car(closure_body(f)));

				if (is_safe_closure(f))
				  {
				    if ((is_safely_optimized(cadr(code))) &&
					(is_safely_optimized(caddr(code))) &&
					(c_call(cadr(code)) == g_car) &&
					(c_call(caddr(code)) == g_car) &&
					(symbol_id(sc->CAR) == 0))
				      set_optimize_data(code, OP_SAFE_CLOSURE_CAR_CAR);
				    else
				      {
					if ((is_safely_optimized(cadr(code))) &&
					    (is_safely_optimized(caddr(code))) &&
					    (c_call(cadr(code)) == g_cdr) &&
					    (c_call(caddr(code)) == g_cdr) &&
					    (symbol_id(sc->CDR) == 0))
					  set_optimize_data(code, OP_SAFE_CLOSURE_CDR_CDR);
				      }
				  }
			      }
			    if ((is_global(car(code))) &&
				(is_hopping(cadr(code))) &&
				(is_hopping(caddr(code))))
			      set_hopping(code);
			    set_ecdr(code, f);
			    set_fcdr(code, cadr(caddr(code)));
			    set_fcdr(cdr(code), cadr(cadr(code)));
			    goto OPT_EVAL;
			  }
			break;
			
		      case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_LST_ARGS_FUNCTION:
			if (is_safe_procedure(f))
			  {
			    set_optimize_data(code, OP_SAFE_C_opSq_opSq);
			    set_c_function(code, f);
			    goto OPT_EVAL;
			  }
			if ((is_all_x_safe(sc, cadr(code))) &&
			    (is_all_x_safe(sc, caddr(code))))
			  {
			    set_optimize_data(code, OP_C_ALL_X);
			    set_c_function(code, f);
			    annotate_args(sc, cdr(code));
			    set_arglist_length(code, small_int(2));
			    goto OPT_EVAL;
			  }
			break;
			
		      default:
			/* fprintf(stderr, "un_opsq_opsq: found %s %s\n", type_name(sc, f, 0), DISPLAY(code)); */
			break;
		      }
		  }
	      }
	      break;


	      /* -------------------------------------------------------------------------------- */
	    case OP_VECTOR_C:
	    case HOP_VECTOR_C:
	      {
		/* this is the implicit indexing case (vector-ref is a normal safe op) 
		 *    (define (hi) (let ((v (vector 1 2 3))) (v 0)))
		 *    this starts as unknown_c [26608 in optimize_function] -> vector_c
		 *    but it still reports itself as unsafe, so there are higher levels possible
		 */
		s7_pointer v; 
		v = find_symbol_or_bust(sc, car(code));
		if (!s7_is_vector(v))
		  break;
		
		if (!vector_is_multidimensional(v))
		  {
		    s7_Int index;
		    index = s7_integer(cadr(code));
		    if ((index < vector_length(v)) &&
			(index >= 0))
		      {
			sc->value = vector_getter(v)(sc, v, index);
			goto START;
		      }
		  }
		sc->value = vector_ref_1(sc, v, cdr(code));
		goto START;
	      }
	      
	      
	    case OP_VECTOR_opCq:
	      /*
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	      */
	    case HOP_VECTOR_opCq:
	      {
		s7_pointer v, x; 
		v = find_symbol_or_bust(sc, car(code));
		if (!s7_is_vector(v))
		  break;
		
		x = c_call(cadr(code))(sc, cdadr(code));
		if (s7_is_integer(x))
		  {
		    if (!vector_is_multidimensional(v))
		      {
			s7_Int index;
			index = s7_integer(x);
			if ((index < vector_length(v)) &&
			    (index >= 0))
			  {
			    sc->value = vector_getter(v)(sc, v, index);
			    goto START;
			  }
			out_of_range(sc, sc->VECTOR_REF, small_int(1), cadr(code), "between 0 and vector length");
		      }
		    sc->value = vector_ref_1(sc, v, cons(sc, x, sc->NIL));
		    goto START;
		  }
		return(wrong_type_argument(sc, sc->VECTOR_REF, small_int(1), x, T_INTEGER));
	      }
	      break;
	      
	      
	    case OP_VECTOR_S:
	    case HOP_VECTOR_S:
	      {
		s7_pointer v, ind; 
		v = find_symbol_or_bust(sc, car(code));
		ind = find_symbol_or_bust(sc, cadr(code));
		if ((!s7_is_vector(v)) ||
		    (!s7_is_integer(ind)))
		  break;
		
		if (!vector_is_multidimensional(v))
		  {
		    s7_Int index;
		    index = s7_integer(ind);
		    if ((index < vector_length(v)) &&
			(index >= 0))
		      {
			sc->value = vector_getter(v)(sc, v, index);
			goto START;
		      }
		    out_of_range(sc, sc->VECTOR_REF, small_int(1), cadr(code), "between 0 and vector length");
		  }
		sc->value = vector_ref_1(sc, v, cons(sc, ind, sc->NIL));
		goto START;
	      }
	      
	    case OP_STRING_C:
	    case HOP_STRING_C:
	      {
		s7_Int index;
		s7_pointer s;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_string(s))
		  break;
		
		index = s7_integer(cadr(code));
		if ((index < string_length(s)) &&
		    (index >= 0))
		  {
		    if (is_bytevector(s))
		      sc->value = small_int((unsigned int)string_value(s)[index]);
		    else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
		    goto START;
		  }
		sc->value = string_ref_1(sc, s, cadr(code));
		goto START;
	      }
	      
	      
	    case OP_STRING_opCq:
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	    case HOP_STRING_opCq:
	      {
		s7_Int index;
		s7_pointer s, x;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_string(s))
		  break;
		
		x = c_call(cadr(code))(sc, cdadr(code));
		if (s7_is_integer(x))
		  {
		    index = s7_integer(x);
		    if ((index < string_length(s)) &&
			(index >= 0))
		      {
			if (is_bytevector(s))
			  sc->value = small_int((unsigned int)string_value(s)[index]);
			else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
			goto START;
		      }
		    out_of_range(sc, sc->STRING_REF, small_int(2), cadr(code), "between 0 and string length");
		  }
		wrong_type_argument(sc, sc->STRING_REF, small_int(2), x, T_INTEGER);
	      }
	      break;
	      
	      
	    case OP_STRING_S:
	    case HOP_STRING_S:
	      {
		s7_Int index;
		s7_pointer s, ind;
		s = find_symbol_or_bust(sc, car(code));
		ind = find_symbol_or_bust(sc, cadr(code));
		if ((!is_string(s)) ||
		    (!s7_is_integer(ind)))
		  break;
		
		index = s7_integer(ind);
		if ((index < string_length(s)) &&
		    (index >= 0))
		  {
		    if (is_bytevector(s))
		      sc->value = small_int((unsigned int)string_value(s)[index]);
		    else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
		    goto START;
		  }
		sc->value = string_ref_1(sc, s, ind);
		goto START;
	      }
	      
	      
	    case OP_HASH_TABLE_C:
	    case HOP_HASH_TABLE_C:
	      {
		s7_pointer s;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_hash_table(s))
		  break;
		
		sc->value = s7_hash_table_ref(sc, s, cadr(code));
		goto START;
	      }
	      
	      
	    case OP_HASH_TABLE_S:
	    case HOP_HASH_TABLE_S:
	      {
		s7_pointer s;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_hash_table(s))
		  break;
		
		sc->value = s7_hash_table_ref(sc, s, find_symbol_or_bust(sc, cadr(code)));
		goto START;
	      }
	      
	      
	    case OP_ENVIRONMENT_S:
	    case HOP_ENVIRONMENT_S:
	      {
		s7_pointer s, sym;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_environment(s))
		  break;
		
		sym = find_symbol_or_bust(sc, cadr(code));
		if (is_symbol(sym))                             /* (env pi) */
		  sc->value = s7_environment_ref(sc, s, sym);
		else return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_REF, sym, A_SYMBOL));
		goto START;
	      }
	      
	      
	    case OP_ENVIRONMENT_Q:
	    case HOP_ENVIRONMENT_Q:
	      {
		s7_pointer s, sym;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_environment(s))
		  break;
		
		sym = cadr(cadr(code));
		if (is_symbol(sym))
		  sc->value = s7_environment_ref(sc, s, sym);
		else return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_REF, sym, A_SYMBOL));
		goto START;
	      }
	      
	      
	    case OP_PAIR_C:
	    case HOP_PAIR_C:
	      {
		s7_pointer s;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_pair(s))
		  break;
		
		sc->value = list_ref_1(sc, s, cadr(code));
		goto START;
	      }
	      
	      
	    case OP_PAIR_opCq:
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	    case HOP_PAIR_opCq:
	      {
		s7_pointer s, x;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_pair(s))
		  break;
		x = c_call(cadr(code))(sc, cdadr(code));
		sc->value = list_ref_1(sc, s, x);
		goto START;
	      }
	      
	      
	    case OP_PAIR_S:
	    case HOP_PAIR_S:
	      {
		s7_pointer s, ind;
		s = find_symbol_or_bust(sc, car(code));
		if (!is_pair(s))
		  break;
		ind = find_symbol_or_bust(sc, cadr(code));
		sc->value = list_ref_1(sc, s, ind);
		goto START;
	      }
	      
	      
	    case OP_C_OBJECT:
	    case HOP_C_OBJECT:
	      {
		s7_pointer c;
		c = find_symbol_or_bust(sc, car(code));
		if (!is_c_object(c))
		  break;
		sc->value = (*(c_object_ref(c)))(sc, c, sc->NIL);
		goto START;
	      }


	    case OP_C_OBJECT_C:
	    case HOP_C_OBJECT_C:
	      {
		s7_pointer c, ind;
		c = find_symbol_or_bust(sc, car(code));
		if (!is_c_object(c))
		  break;

		ind = cadr(code);
		if (is_integer(ind))
		  {
		    if ((c_object_has_array(c)) &&
			(integer(ind) >= 0) &&
			(integer(ind) < c_object_array_length(c)))
		      {
			sc->value = make_real(sc, c_object_array(c)[integer(ind)]);
			goto START;
		      }
		  }

		if (c_object_ref_2(c))
		  sc->value = (*(c_object_ref_2(c)))(sc, c_object_value(c), ind);
		else sc->value = (*(c_object_ref(c)))(sc, c, cdr(code));
		goto START;
	      }
	      
	    case OP_C_OBJECT_opCq:
	      if (!indirect_c_function_is_ok(sc, cadr(code)))
		break;
	    case HOP_C_OBJECT_opCq:
	      {
		s7_pointer c, ind;
		c = find_symbol_or_bust(sc, car(code));
		if (!is_c_object(c))
		  break;

		ind = c_call(cadr(code))(sc, cdadr(code));
		if (is_integer(ind))
		  {
		    if ((c_object_has_array(c)) &&
			(integer(ind) >= 0) &&
			(integer(ind) < c_object_array_length(c)))
		      {
			sc->value = make_real(sc, c_object_array(c)[integer(ind)]);
			goto START;
		      }
		  }

		if (c_object_ref_2(c))
		  sc->value = (*(c_object_ref_2(c)))(sc, c_object_value(c), ind);
		else
		  {
		    car(sc->T1_1) = ind;
		    sc->value = (*(c_object_ref(c)))(sc, c, sc->T1_1);
		  }
		goto START;
	      }
	      
	    case OP_C_OBJECT_S:
	    case HOP_C_OBJECT_S:
	      {
		s7_pointer c, ind;
		/*
		  t502:
		  441000: (dline1 k)
		  423376: (radii k)
		  220500: (dline2 j)
		  etc
		 */

		c = find_symbol_or_bust(sc, car(code));
		if (!is_c_object(c))
		  break;
		ind = find_symbol_or_bust(sc, cadr(code));

		if (is_integer(ind))
		  {
		    if ((c_object_has_array(c)) &&
			(integer(ind) >= 0) &&
			(integer(ind) < c_object_array_length(c)))
		      {
			sc->value = make_real(sc, c_object_array(c)[integer(ind)]);
			goto START;
		      }
		  }
		if (c_object_ref_2(c))
		  sc->value = (*(c_object_ref_2(c)))(sc, c_object_value(c), ind);
		else
		  {
		    car(sc->T1_1) = ind;
		    sc->value = (*(c_object_ref(c)))(sc, c, sc->T1_1);
		  }
		goto START;
	      }
	      
	      
	    case OP_C_OBJECT_SS:
	    case HOP_C_OBJECT_SS:
	      {
		/* perhaps also c_object_ref_2 and direct case? */
		s7_pointer c, ind;
		c = find_symbol_or_bust(sc, car(code));
		if (!is_c_object(c))
		  break;

		ind = find_symbol_or_bust(sc, cadr(code));
		car(sc->T2_2) = find_symbol_or_bust(sc, caddr(code));
		car(sc->T2_1) = ind;
		sc->value = (*(c_object_ref(c)))(sc, c, sc->T2_1);
		goto START;
	      }
	      
	      
	      /* -------------------------------------------------------------------------------- */
	    case OP_SAFE_C_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_C:
	      /*
		t502:
		165375: (outa i couplingFilter-input)
		108271: (outa i sample-0)
		81365: (outa i (* pulse-amp (env pulse-ampf) (+ (* (env low-ampf) (polywave gp frq2)) (polywave gen1 (env frqf))))) animals
		50880: (outa k (oscil-bank obank))
		44999: (env pulsef)
		etc
	      */
	      sc->value = c_call(code)(sc, cdr(code)); /* this includes all safe calls where all args are constants */
	      goto START;

	      
	    case OP_SAFE_C_Q:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_Q:
	      car(sc->T1_1) = cadr(cadr(code));
	      sc->value = c_call(code)(sc, sc->T1_1);
	      goto START;
	      
	      
	    case OP_SAFE_C_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_S:
	      car(sc->T1_1) = finder(sc, cadr(code));
	      sc->value = c_call(code)(sc, sc->T1_1);
	      goto START;
	      
	      
	    case OP_SAFE_C_SS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SS:
	      {
		s7_pointer val, args;
		args = cdr(code);
		val = finder(sc, car(args));
		car(sc->T2_2) = finder(sc, cadr(args));
		car(sc->T2_1) = val;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START; 
	      }
	      

	    case OP_SAFE_CONS_SS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_CONS_SS:
	      {
		s7_pointer x, args;
		args = cdr(code);
		NEW_CELL(sc, x);
		car(x) = finder(sc, car(args));
		cdr(x) = finder(sc, cadr(args));
		set_type(x, T_PAIR | T_SAFE_PROCEDURE);
		sc->value = x;
		goto START; 
	      }
	      
	      
	    case OP_SAFE_C_ALL_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_ALL_S:
	      {
		int num_args;
		s7_pointer args, p;

		num_args = integer(arglist_length(code));
		if ((num_args != 0) &&
		    (num_args < NUM_SAFE_LISTS) &&
		    (!list_is_in_use(sc->safe_lists[num_args])))
		  {
		    sc->args = sc->safe_lists[num_args];
		    set_list_in_use(sc->args);
		  }
		else sc->args = make_list(sc, num_args, sc->NIL);
		
		for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
		  car(p) = finder(sc, car(args));
		clear_list_in_use(sc->args);
		sc->value = c_call(code)(sc, sc->args);
		goto START;
	      }

	      
	    case OP_SAFE_C_SC:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SC:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = finder(sc, car(args));
		car(sc->T2_2) = cadr(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_CS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_CS:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_2) = finder(sc, cadr(args));
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_SQ:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SQ:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = finder(sc, car(args));
		car(sc->T2_2) = cadr(cadr(args));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_QS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_QS:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_2) = finder(sc, cadr(args));
		car(sc->T2_1) = cadr(car(args));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_QQ:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_QQ:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = cadr(car(args));
		car(sc->T2_2) = cadr(cadr(args));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_Z:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_Z:
	      push_stack(sc, OP_SAFE_C_P_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_CZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_CZ:
	      push_stack(sc, OP_SAFE_C_SZ_1, cadr(code), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZC:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_ZC:
	      push_stack(sc, OP_SAFE_C_ZS_1, caddr(code), code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_QZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_QZ:
	      push_stack(sc, OP_SAFE_C_SZ_1, cadr(cadr(code)), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZQ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_ZQ:
	      push_stack(sc, OP_SAFE_C_ZS_1, cadr(caddr(code)), code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_SZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_SZ:
	      push_stack(sc, OP_SAFE_C_SZ_1, finder(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      /* splitting out the all_x cases here and elsewhere saves nothing */
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_S_opAAq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opAAq:
	      {
		s7_pointer arg;
		arg = caddr(code);
		car(sc->A2_1) = ((s7_function)fcdr(cdr(arg)))(sc, cadr(arg));
		car(sc->A2_2) = ((s7_function)fcdr(cddr(arg)))(sc, caddr(arg));
		car(sc->T2_2) = c_call(arg)(sc, sc->A2_1);
		car(sc->T2_1) = finder(sc, cadr(code));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      

	    case OP_SAFE_C_S_opAAAq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opAAAq:
	      {
		s7_pointer arg, p;
		p = caddr(code);
		arg = cdr(p);
		car(sc->A3_1) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_2) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_3) = ((s7_function)fcdr(arg))(sc, car(arg));
		car(sc->T2_2) = c_call(p)(sc, sc->A3_1);
		car(sc->T2_1) = finder(sc, cadr(code));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      

	    case OP_SAFE_C_S_opSZq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opSZq:
	      push_stack(sc, OP_SAFE_C_SZ_SZ, finder(sc, cadr(caddr(code))), code);
	      sc->code = caddr(caddr(code));
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZS:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_ZS:
	      push_stack(sc, OP_SAFE_C_ZS_1, finder(sc, caddr(code)), code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;

	      
	    case OP_SAFE_C_AZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_AZ:
	      push_stack(sc, OP_SAFE_C_SZ_1, ((s7_function)fcdr(cdr(code)))(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZA:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_ZA:
	      /* here we can't use ZS order because we sometimes assume left->right arg evaluation (binary-io.scm for example) */
	      push_stack(sc, OP_SAFE_C_ZA_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      

	    case OP_SAFE_C_ZZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_ZZ:
	      push_stack(sc, OP_SAFE_C_ZZ_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	      
	    case OP_SAFE_C_opCq_Z:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq_Z:
	      push_stack(sc, OP_SAFE_C_ZZ_2, c_call(cadr(code))(sc, cdr(cadr(code))), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;

	      
	    case OP_SAFE_C_ZAA:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_ZAA:
	      push_stack(sc, OP_SAFE_C_ZAA_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_AZA:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_AZA:
	      push_stack(sc, OP_SAFE_C_AZA_1, ((s7_function)fcdr(cdr(code)))(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_SSZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      
	    case HOP_SAFE_C_SSZ:
	      push_stack(sc, OP_SAFE_C_SSZ_1, finder(sc, cadr(code)), code);
	      sc->code = cadddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_AAZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      
	    case HOP_SAFE_C_AAZ:
	      push_op_stack(sc, ((s7_function)fcdr(cdr(code)))(sc, cadr(code)));
	      push_stack(sc, OP_SAFE_C_AAZ_1, ((s7_function)fcdr(cddr(code)))(sc, caddr(code)), code);
	      sc->code = cadddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZZA:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_ZZA:
	      push_stack(sc, OP_SAFE_C_ZZA_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZAZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      
	    case HOP_SAFE_C_ZAZ:
	      push_stack(sc, OP_SAFE_C_ZAZ_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_AZZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      
	    case HOP_SAFE_C_AZZ:
	      push_stack(sc, OP_SAFE_C_AZZ_1, ((s7_function)fcdr(cdr(code)))(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      goto OPT_EVAL;
	      
	      
	    case OP_SAFE_C_ZZZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      
	    case HOP_SAFE_C_ZZZ:
	      push_stack(sc, OP_SAFE_C_ZZZ_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;


	    case OP_SAFE_C_ZZZZ:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      if (!c_function_is_ok(sc, cadddr(code)))
		break;
	      if (!c_function_is_ok(sc, caddddr(code)))
		break;
	      
	    case HOP_SAFE_C_ZZZZ:
	      push_stack(sc, OP_SAFE_C_ZZZZ_1, sc->NIL, code);
	      sc->code = cadr(code);
	      goto OPT_EVAL;

	      
	      
	    case OP_SAFE_C_A:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_A:
	      /* biggies here are all_x_c_opsq_s (90722x)
	       *                  all_x_c_opcq_s (139739x)
	       */
	      car(sc->A1_1) = ((s7_function)fcdr(cdr(code)))(sc, cadr(code));
	      sc->value = c_call(code)(sc, sc->A1_1);
	      goto START;


	    case OP_SAFE_C_AA:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_AA:
	      car(sc->A2_1) = ((s7_function)fcdr(cdr(code)))(sc, cadr(code));
	      car(sc->A2_2) = ((s7_function)fcdr(cddr(code)))(sc, caddr(code));
	      sc->value = c_call(code)(sc, sc->A2_1);
	      goto START;


	    case OP_SAFE_C_AAA:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_AAA:
	      {
		s7_pointer arg;
		arg = cdr(code);
		car(sc->A3_1) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_2) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_3) = ((s7_function)fcdr(arg))(sc, car(arg));
		sc->value = c_call(code)(sc, sc->A3_1);
		goto START;
	      }


	    case OP_SAFE_C_SSA:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SSA:
	      {
		s7_pointer arg;
		arg = cdr(code);
		car(sc->A3_1) = finder(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_2) = finder(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_3) = ((s7_function)fcdr(arg))(sc, car(arg));
		sc->value = c_call(code)(sc, sc->A3_1);
		goto START;
	      }


	    case OP_SAFE_C_CSA:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_CSA:
	      {
		s7_pointer arg;
		arg = cdr(code);
		car(sc->A3_1) = car(arg);
		arg = cdr(arg);
		car(sc->A3_2) = finder(sc, car(arg));
		arg = cdr(arg);
		car(sc->A3_3) = ((s7_function)fcdr(arg))(sc, car(arg));
		sc->value = c_call(code)(sc, sc->A3_1);
		goto START;
	      }


	    case OP_SAFE_C_AAAA:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_AAAA:
	      {
		s7_pointer arg;
		arg = cdr(code);
		car(sc->A4_1) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A4_2) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A4_3) = ((s7_function)fcdr(arg))(sc, car(arg));
		arg = cdr(arg);
		car(sc->A4_4) = ((s7_function)fcdr(arg))(sc, car(arg));
		sc->value = c_call(code)(sc, sc->A4_1);
		goto START;
	      }


	    case OP_SAFE_C_ALL_X:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_ALL_X:
	      {
		int num_args;
		s7_pointer args, p;
		
		num_args = integer(arglist_length(code));
		if ((num_args != 0) &&
		    (num_args < NUM_SAFE_LISTS) &&
		    (!list_is_in_use(sc->safe_lists[num_args])))
		  {
		    sc->args = sc->safe_lists[num_args];
		    set_list_in_use(sc->args);
		  }
		else sc->args = make_list(sc, num_args, sc->NIL);

		for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
		  car(p) = ((s7_function)fcdr(args))(sc, car(args));
		clear_list_in_use(sc->args);
		
		sc->value = c_call(code)(sc, sc->args);
		/* we can't release a temp here:
		 *   (define (hi) (vector 14800 14020 (oscil os) (* 1/3 14800) 14800 (* 1/2 14800))) (hi) where os returns non-zero:
		 *   #(14800 14020 <output-string-port> 14800/3 14800 7400)
		 */
		goto START;
	      }

	      
	    case OP_SAFE_C_SQS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SQS:
	      {
		/* (environment-set! gen 'fm fm) */
		s7_pointer val1, args;
		args = cdr(code);
		
		val1 = find_symbol_or_bust(sc, car(args));
		car(sc->T3_3) = find_symbol_or_bust(sc, fcdr(args));
		car(sc->T3_2) = ecdr(args);
		car(sc->T3_1) = val1;
		sc->value = c_call(code)(sc, sc->T3_1);
		IF_BEGIN_POP_STACK(sc);
	      }
	      

	    case OP_SAFE_C_SCS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SCS:
	      {
		/* (define (hi) (let ((x 32) (lst '(0 1))) (list-set! lst 0 x) x)) */
		s7_pointer val1, args;
		args = cdr(code);
		
		val1 = find_symbol_or_bust(sc, car(args));
		car(sc->T3_3) = find_symbol_or_bust(sc, fcdr(args));
		car(sc->T3_2) = ecdr(args);
		car(sc->T3_1) = val1;
		sc->value = c_call(code)(sc, sc->T3_1);
		goto START;
	      }
	      

	    case OP_SAFE_C_SSC:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SSC:
	      {
		/* (define (hi) (let ((v #(0 1 2)) (i 0)) (vector-set! v i 1) v)) */
		s7_pointer val1, args;
		args = cdr(code);
		
		val1 = find_symbol_or_bust(sc, car(args));
		car(sc->T3_2) = find_symbol_or_bust(sc, ecdr(args));
		car(sc->T3_3) = fcdr(args);
		car(sc->T3_1) = val1;
		sc->value = c_call(code)(sc, sc->T3_1);
		IF_BEGIN_POP_STACK(sc);
	      }
	      

	    case OP_SAFE_C_CSS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_CSS:
	      {
		s7_pointer val1, args;
		args = cdr(code);
		
		val1 = find_symbol_or_bust(sc, fcdr(args));
		car(sc->T3_2) = find_symbol_or_bust(sc, ecdr(args));
		car(sc->T3_3) = val1;
		car(sc->T3_1) = car(args);
		sc->value = c_call(code)(sc, sc->T3_1);
		goto START;
	      }
	      

	    case OP_SAFE_C_SSS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SSS:
	      {
		s7_pointer val1, val2, args;
		args = cdr(code);
		
		val1 = find_symbol_or_bust(sc, car(args));
		val2 = find_symbol_or_bust(sc, ecdr(args));
		car(sc->T3_3) = find_symbol_or_bust(sc, fcdr(args));
		car(sc->T3_1) = val1;
		car(sc->T3_2) = val2;
		sc->value = c_call(code)(sc, sc->T3_1);
		goto START;
	      }
	      
	      /* now ops that need extra op name checks */
	      
	    case OP_SAFE_C_opCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq:
	      car(sc->T1_1) = c_call(car(cdr(code)))(sc, cdar(cdr(code))); /* OP_SAFE_C_C can involve any number of ops */
	      sc->value = c_call(code)(sc, sc->T1_1);
	      goto START;
	      
	      
	    case OP_SAFE_C_opQq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opQq:
	      car(sc->T1_1) = cadr(cadr(car(cdr(code))));
	      car(sc->T1_1) = c_call(car(cdr(code)))(sc, sc->T1_1);
	      sc->value = c_call(code)(sc, sc->T1_1);
	      goto START;
	      
	      
	    case OP_SAFE_C_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq:
	      {
		s7_pointer args;
		args = cadr(code);
		car(sc->T1_1) = finder(sc, cadr(args));
		car(sc->T1_1) = c_call(args)(sc, sc->T1_1);
		sc->value = c_call(code)(sc, sc->T1_1);
		goto START;
	      }
	      
	    case OP_SAFE_C_P:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_P:
	      push_stack(sc, OP_EVAL_ARGS_P_1, sc->NIL, code); /* catch values etc */
	      sc->code = cadr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL;  
	      
	      
	    case OP_SAFE_C_PS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_PS:
	      push_stack(sc, OP_EVAL_ARGS_P_3, sc->NIL, code); /* gotta wait in this case */
	      sc->code = cadr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL;  
	      
	      
	    case OP_SAFE_C_PC:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_PC:
	      push_stack(sc, OP_EVAL_ARGS_P_4, caddr(code), code);
	      sc->code = cadr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL;  
	      
	      
	    case OP_SAFE_C_PQ:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_PQ:
	      push_stack(sc, OP_EVAL_ARGS_P_4, cadr(caddr(code)), code); /* was P_5, but that's the same as P_4 */
	      sc->code = cadr(code);
	      goto EVAL;  
	      
	      
	    case OP_SAFE_C_SP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SP:
	      push_stack(sc, OP_EVAL_ARGS_P_2, finder(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL;  
	      
	      
	    case OP_SAFE_C_CP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_CP:
	      push_stack(sc, OP_EVAL_ARGS_P_2, cadr(code), code);
	      sc->code = caddr(code);
	      goto EVAL; 
	      
	      
	    case OP_SAFE_C_QP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_QP:
	      push_stack(sc, OP_EVAL_ARGS_P_2, cadr(cadr(code)), code);
	      sc->code = caddr(code);
	      goto EVAL; 
	      
	      
	    case OP_SAFE_C_PP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_PP:
	      /* t502:
		 449803: (+ (* (radii j) (radii-poles j)) (* (target-radii j) (radii-pole-gains j)))
		 449803: (* (radii j) (radii-poles j))
		 449803: (* (target-radii j) (radii-pole-gains j))
		 220500: (+ (dline1 k) (- (dline2 j) x))
		 220500: (* (coeffs j) (- (dline1 k) x))
		 211688: (* (radii k) (radii k))

		 snd-test:
		 224893: (+ (* (radii j) (radii-poles j)) (* (target-radii j) (radii-pole-gains j)))
		 224893: (* (radii j) (radii-poles j))
		 224893: (* (target-radii j) (radii-pole-gains j))
		 193165: (- (wk1 j) (* (wkm k) (wk2 j)))
		 193165: (- (wk2 (+ j 1)) (* (wkm k) (wk1 (+ j 1))))
		 193165: (* (wkm k) (wk2 j))
		 193165: (* (wkm k) (wk1 (+ j 1)))
		 176400: (* (env ampf) (r2k!cos gen))
		 160256: (* (fft-window i) (data i))
		 154343: (* (amps i) (oscil (oscs i)))
		 132300: (* (amps k) (+ (* even-amp (oscil (vector-ref evens k) (+ even-freq car-mult))) (* odd-amp (oscil (vector-ref odds k) (+ odd-freq car-mult)))))
		 132300: (* (fm-indices k) (oscil (modulators k)))
		 132300: (* (amps k) (+ (* even-amp (oscil (vector-ref evens k) (+ even-freq val))) (* odd-amp (oscil (vector-ref odds k) (+ odd-freq val)))))
		 131068: (make-rectangular (rl i) (im i))
		 130812: (* (r1) (r2))
		 110250: (+ (dline1 k) (- (dline2 j) x))
		 110250: (* (coeffs j) (- (dline1 k) x))
		 110200: (* (samps k) (sin ka))
		 110200: (* (camps k) (cos ka))
		 105848: (* (radii k) (radii k))
		 101888: (- (freqs k) (lastphases k))
		 101656: (+ (* (- 1.0 pan) (data1 i)) (* pan (data2 i)))
		 101656: (* (- 1.0 pan) (data1 i))
	      */
	      push_stack(sc, OP_SAFE_C_PP_1, sc->NIL, code);
	      sc->code = cadr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL; 
	      
	      
	    case OP_SAFE_C_SSP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_SAFE_C_SSP:
	      push_stack(sc, OP_EVAL_ARGS_SSP_1, sc->NIL, code);
	      sc->code = cadddr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL;  
	      

	    case OP_SAFE_C_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq:
	      {
		s7_pointer args, val1;
		args = cadr(code);
		val1 = finder(sc, cadr(args));
		car(sc->T2_2) = finder(sc, caddr(args));
		car(sc->T2_1) = val1;
		car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
		sc->value = c_call(code)(sc, sc->T1_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSCq:
	      {
		s7_pointer args;
		args = cadr(code);
		car(sc->T2_1) = finder(sc, cadr(args));
		car(sc->T2_2) = caddr(args);
		car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
		sc->value = c_call(code)(sc, sc->T1_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCSq:
	      {
		s7_pointer args;
		args = cadr(code);
		car(sc->T2_2) = finder(sc, caddr(args));
		car(sc->T2_1) = cadr(args);
		car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
		sc->value = c_call(code)(sc, sc->T1_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSQq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSQq:
	      {
		s7_pointer args;
		args = cadr(code);
		car(sc->T2_1) = finder(sc, cadr(args));
		car(sc->T2_2) = cadr(caddr(args)); 
		car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
		sc->value = c_call(code)(sc, sc->T1_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_S_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opSq:
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = finder(sc, car(args));
		car(sc->T1_1) = finder(sc, ecdr(args));
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
		car(sc->T2_1) = val;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	    case OP_SAFE_C_S_opCq: 
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opCq: 
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = finder(sc, car(args));
		car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args)); /* any number of constants here */
		car(sc->T2_1) = val;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_C_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_C_opSq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T1_1) = finder(sc, ecdr(args));
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_C_opCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_C_opCq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args)); /* any # of args */
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_C_opCSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_C_opCSq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_2) = finder(sc, fcdr(args));
		car(sc->T2_1) = ecdr(args);
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_C_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_C_opSSq:
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = finder(sc, ecdr(args));
		car(sc->T2_2) = finder(sc, fcdr(args));
		car(sc->T2_1) = val;
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCSq_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCSq_C:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_2) = finder(sc, caddr(car(args)));
		car(sc->T2_1) = cadr(car(args));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = cadr(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSSq_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq_C:
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = finder(sc, cadr(car(args)));
		car(sc->T2_2) = finder(sc, caddr(car(args)));
		car(sc->T2_1) = val;
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = cadr(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      

	    case OP_SAFE_C_opSSq_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq_S:
	      {
		s7_pointer args, val, val1;
		args = cdr(code);
		val = finder(sc, cadr(car(args)));
		val1 = finder(sc, cadr(args));
		car(sc->T2_2) = finder(sc, caddr(car(args)));
		car(sc->T2_1) = val;
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }


	    case OP_SAFE_C_op_opSSq_q_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;

	    case HOP_SAFE_C_op_opSSq_q_C:
	      {
		/* code: (> (magnitude (- old new)) 0.001
		 */
		s7_pointer arg;
		arg = cadr(cadr(code));
		car(sc->T2_1) = finder(sc, cadr(arg));
		car(sc->T2_2) = finder(sc, caddr(arg));
		car(sc->T1_1) = c_call(arg)(sc, sc->T2_1);
		car(sc->T2_1) = c_call(cadr(code))(sc, sc->T1_1);
		car(sc->T2_2) = caddr(code);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_S_op_opSSq_Sq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_op_opSSq_Sq:
	      {
		/* (let () (define (hi a b c d) (+ a (* (- b c) d))) (define (ho) (hi 1 2 3 4)) (ho)) 
		 *   or actually... (oscil fmosc1 (+ (* fm1-rat vib) fuzz))
		 *      and that is then packaged as opCq...: (* (env indf1) (oscil fmosc1 (+ (* fm1-rat vib) fuzz)))
		 *      and that is then (+ ...)	
		 *   but now this is handled in clm2xen.c
		 */
		s7_pointer args, val, val1;
		args = caddr(code);                            /* (* (- b c) d) */
		val1 = cadr(args);
		val = finder(sc, cadr(val1));                  /* b */
		car(sc->T2_2) = finder(sc, caddr(val1));       /* c */
		car(sc->T2_1) = val;
		val = finder(sc, caddr(args));                 /* d */
		car(sc->T2_1) = c_call(val1)(sc, sc->T2_1);    /* (- b c) */
		car(sc->T2_2) = val;
		car(sc->T2_2) = c_call(args)(sc, sc->T2_1);    /* (* ...) */
		car(sc->T2_1) = finder(sc, cadr(code));        /* a */
		sc->value = c_call(code)(sc, sc->T2_1);        /* (+ ...) */
		goto START;
	      }

	      
	    case OP_SAFE_C_S_op_S_opSSqq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_op_S_opSSqq:
	      {
		/* (let () (define (hi a b c d) (+ a (* d (- b c)))) (define (ho) (hi 1 2 3 4)) (ho)) */
		s7_pointer args, val, val1;
		args = caddr(code);                            /* (* d (- b c)) */
		val1 = caddr(args);
		val = finder(sc, cadr(val1));                  /* b */
		car(sc->T2_2) = finder(sc, caddr(val1));       /* c */
		car(sc->T2_1) = val;
		val = finder(sc, cadr(args));                  /* d */
		car(sc->T2_2) = c_call(val1)(sc, sc->T2_1);    /* (- b c) */
		car(sc->T2_1) = val;
		car(sc->T2_2) = c_call(args)(sc, sc->T2_1);    /* (* ...) */
		car(sc->T2_1) = finder(sc, cadr(code));        /* a */
		sc->value = c_call(code)(sc, sc->T2_1);        /* (+ ...) */
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSCq_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSCq_S:
	      {
		s7_pointer args, val1;
		args = cdr(code);
		val1 = finder(sc, cadr(args));
		car(sc->T2_1) = finder(sc, cadr(car(args)));
		car(sc->T2_2) = caddr(car(args));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSCq_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSCq_C:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = finder(sc, cadr(car(args)));
		car(sc->T2_2) = caddr(car(args));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = cadr(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCSq_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCSq_S:
	      {
		s7_pointer args, val1;
		args = cdr(code);
		val1 = finder(sc, cadr(args));
		car(sc->T2_2) = finder(sc, caddr(car(args)));
		car(sc->T2_1) = cadr(car(args));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_2) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_S_opSCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opSCq:
	      {
		s7_pointer val1, args;
		args = cdr(code);
		val1 = finder(sc, car(args));
		car(sc->T2_1) = finder(sc, ecdr(args));
		car(sc->T2_2) = fcdr(args);
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_C_opSCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_C_opSCq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = finder(sc, ecdr(args));
		car(sc->T2_2) = fcdr(args);
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = car(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_S_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opSSq:
	      {
		/* (* a (- b c)) */
		s7_pointer val1, val2, args;
		args = cdr(code);
		val1 = finder(sc, car(args));
		val2 = finder(sc, ecdr(args));
		car(sc->T2_2) = finder(sc, fcdr(args));
		car(sc->T2_1) = val2;
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_S_opCSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_S_opCSq:
	      {
		/* (* a (- 1 b)) or (logand a (ash 1 b)) */
		s7_pointer val1, args;
		args = cdr(code);
		val1 = finder(sc, car(args));                     /* a */
		car(sc->T2_2) = finder(sc, fcdr(args));           /* b */
		car(sc->T2_1) = ecdr(args);                       /* 1 */
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1); /* (- 1 b) */
		car(sc->T2_1) = val1;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSq_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq_S:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T1_1) = finder(sc, cadr(car(args)));
		sc->temp4 = c_call(car(args))(sc, sc->T1_1);
		car(sc->T2_2) = finder(sc, cadr(args));
		car(sc->T2_1) = sc->temp4;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSq_P:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq_P:
	      {
		s7_pointer args;
		args = cadr(code);
		car(sc->T1_1) = finder(sc, cadr(args));
		push_stack(sc, OP_SAFE_C_opSq_P_1, c_call(args)(sc, sc->T1_1), sc->code);
		sc->code = caddr(code);
		goto EVAL; 
	      }

	      
	    case OP_SAFE_C_opCq_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq_S:
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = finder(sc, cadr(args));
		car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
		car(sc->T2_2) = val;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCq_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq_C:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
		car(sc->T2_2) = cadr(args); /* the second C stands for 1 arg? */
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSq_C:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq_C:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T1_1) = finder(sc, cadr(car(args)));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T1_1);
		car(sc->T2_2) = cadr(args);
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSq_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq_opSq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T1_1) = finder(sc, cadr(car(args)));
		sc->temp4 = c_call(car(args))(sc, sc->T1_1);
		args = cadr(args);
		car(sc->T1_1) = finder(sc, cadr(args));
		car(sc->T2_2) = c_call(args)(sc, sc->T1_1);
		car(sc->T2_1) = sc->temp4;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCq_opCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq_opCq:
	      {
		s7_pointer args;
		args = cdr(code);
		car(sc->T2_1) = c_call(car(args))(sc, cdr(car(args)));
		car(sc->T2_2) = c_call(cadr(args))(sc, cdr(cadr(args)));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opCq_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opCq_opSSq:
	      {
		s7_pointer args, val;
		/* code: (/ (+ bn 1) (+ bn an)) */
		args = cdr(code);
		val = c_call(car(args))(sc, cdr(car(args)));
		args = cdr(args);
		car(sc->T2_1) = finder(sc, cadar(args));
		car(sc->T2_2) = finder(sc, caddar(args));
		car(sc->T2_2) = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_1) = val;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSCq_opSCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSCq_opSCq:
	      {
		s7_pointer args, val2;
		args = cdr(code);
		val2 = finder(sc, cadr(cadr(args)));
		car(sc->T2_1) = finder(sc, cadr(car(args)));
		car(sc->T2_2) = caddr(car(args));
		sc->temp4 = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_1) = val2;
		car(sc->T2_2) = caddr(cadr(args));
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = sc->temp4;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSSq_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq_opSSq:
	      {
		s7_pointer args, val3, val4;
		args = cdr(code);
		val3 = finder(sc, caddr(car(args)));
		val4 = finder(sc, caddr(cadr(args)));
		
		car(sc->T2_1) = finder(sc, cadr(car(args)));
		car(sc->T2_2) = val3;
		sc->temp4 = c_call(car(args))(sc, sc->T2_1);
		car(sc->T2_1) = finder(sc, cadr(cadr(args)));
		car(sc->T2_2) = val4;
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T2_1) = sc->temp4;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSSq_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq_opSq:
	      {
		s7_pointer args, val3;
		args = cdr(code);
		val3 = finder(sc, caddr(car(args)));
		car(sc->T2_1) = finder(sc, cadr(car(args)));
		car(sc->T2_2) = val3;
		val3 = c_call(car(args))(sc, sc->T2_1);
		car(sc->T1_1) = finder(sc, cadr(cadr(args)));
		car(sc->T2_2) = c_call(cadr(args))(sc, sc->T1_1);
		car(sc->T2_1) = val3;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSq_opSSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSq_opSSq:
	      {
		s7_pointer args, val3;
		args = cdr(code);
		val3 = finder(sc, cadr(cadr(args)));
		car(sc->T2_2) = finder(sc, caddr(cadr(args)));
		car(sc->T2_1) = val3;
		val3 = c_call(cadr(args))(sc, sc->T2_1);
		car(sc->T1_1) = finder(sc, cadr(car(args)));
		car(sc->T2_1) = c_call(car(args))(sc, sc->T1_1);
		car(sc->T2_2) = val3;
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	    case OP_SAFE_C_opSSq_opCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!c_function_is_ok(sc, cadr(code)))
		break;
	      if (!c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_SAFE_C_opSSq_opCq:
	      {
		s7_pointer arg1, arg2, val3;
		arg1 = cadr(code);
		arg2 = caddr(code);
		val3 = finder(sc, caddr(arg1));
		car(sc->T2_1) = finder(sc, cadr(arg1));
		car(sc->T2_2) = val3;
		car(sc->T2_1) = c_call(arg1)(sc, sc->T2_1);
		car(sc->T2_2) = c_call(arg2)(sc, cdr(arg2));
		sc->value = c_call(code)(sc, sc->T2_1);
		goto START;
	      }
	      
	      
	      /* -------------------------------------------------------------------------------- */
	    case OP_C_S_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_C_S_opSq:
	      {
		s7_pointer args, val;
		args = cdr(code);
		val = find_symbol_or_bust(sc, car(args));
		car(sc->T1_1) = find_symbol_or_bust(sc, ecdr(args));
		sc->args = list_2(sc, val, c_call(cadr(args))(sc, sc->T1_1));
		sc->value = c_call(code)(sc, sc->args);
		goto START;
	      }

	      
	    case OP_C_QQ_1:
	    case HOP_C_QQ_1:
	      {
		s7_pointer val;
		val = finder(sc, cadr(caddr(code)));
		if (!is_proper_list(sc, val))
		  s7_error(sc, sc->WRONG_TYPE_ARG, 
			   list_2(sc, 
				  make_protected_string(sc, "apply's last argument should be a proper list: ~S"),
				  val));
		sc->value = cons(sc, cadr(cadr(code)), val);
		/* fprintf(stderr, "value: %s\n", DISPLAY(sc->value)); */
		goto START;
	      }
	      
	      
	    case OP_C_S_opCq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      
	    case HOP_C_S_opCq:
	      {
		s7_pointer args, val;
		args = cdr(code);
		sc->temp4 = find_symbol_or_bust(sc, car(args));
		val = c_call(cadr(args))(sc, ecdr(args));
		sc->args = list_2(sc, sc->temp4, val);
		sc->value = c_call(code)(sc, sc->args);
		goto START;
	      }
	      
	      
	    case OP_C_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_S:
	      sc->args = list_1(sc, find_symbol_or_bust(sc, cadr(code)));
	      sc->value = c_call(code)(sc, sc->args);
	      goto START;
	      
	      
	    case OP_READ_S:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_READ_S:
	      {
		s7_pointer port;
		port = find_symbol_or_bust(sc, cadr(code));
		
		if (!is_input_port(port)) /* was also not stdin */
		  {
		    sc->value = g_read(sc, list_1(sc, port));
		    goto START;
		  }
		/* I guess this port_is_closed check is needed because we're going down a level below */
		if (port_is_closed(port))
		  simple_wrong_type_argument_with_type(sc, sc->READ, port, AN_OPEN_PORT);
		
		if (is_function_port(port))
		  sc->value = (*(port_input_function(port)))(sc, S7_READ, port);
		else
		  {
		    if ((is_string_port(port)) &&
			(port_string_length(port) <= port_string_point(port)))
		      sc->value = sc->EOF_OBJECT;
		    else
		      {
			push_input_port(sc, port);
			push_stack(sc, OP_READ_DONE, sc->NIL, sc->NIL); /* this stops the internal read process so we only get one form */
			sc->tok = token(sc);
			switch (sc->tok)
			  {
			  case TOKEN_EOF:
			    goto START;
			    
			  case TOKEN_RIGHT_PAREN:
			    read_error(sc, "unexpected close paren");
			    
			  case TOKEN_COMMA:
			    read_error(sc, "unexpected comma");
			    
			  default:
			    sc->value = read_expression(sc);
			    sc->current_line = port_line_number(sc->input_port);  /* this info is used to track down missing close parens */
			    sc->current_file = port_filename(sc->input_port);
			  }
		      }
		  }
		goto START;
	      }
	      
	      
	    case OP_C_A:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_A:
	      sc->args = list_1(sc, ((s7_function)fcdr(cdr(code)))(sc, cadr(code)));
	      sc->value = c_call(code)(sc, sc->args);
	      goto START;
	      
	      
	    case OP_C_P:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_P:
	      push_stack(sc, OP_C_P_1, sc->NIL, code);
	      sc->code = cadr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL; 
	      
	      
	    case OP_C_SP:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_SP:
	      push_stack(sc, OP_C_SP_1, finder(sc, cadr(code)), code);
	      sc->code = caddr(code);
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL; 
	      
	      
	    case OP_APPLY_SS:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_APPLY_SS:
	      sc->code = finder(sc, cadr(code)); /* global search here was slower */
	      sc->args = finder(sc, fcdr(code));
	      if (!is_proper_list(sc, sc->args))        /* (apply + #f) etc */
		return(s7_error(sc, sc->WRONG_TYPE_ARG, 
				list_2(sc, 
				       make_protected_string(sc, "apply's last argument should be a proper list: ~S"),
				       sc->args)));
	      if (needs_copied_args(sc->code))
		{
		  if (!is_null(sc->args))
		    sc->args = copy_list(sc, sc->args);
		  if (is_any_macro(sc->code))                   /* (apply mac '(3)) -> (apply mac '((mac 3))) */
		    {                                           /* these always copy args (except c_macros, sigh) */
		      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
		      sc->args = list_1(sc, cons(sc, sc->code, sc->args));
		    }
		}
	      goto APPLY;


	    case OP_C_ALL_X:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_ALL_X:
	      {
		s7_pointer args, p;
		sc->args = make_list(sc, integer(arglist_length(code)), sc->NIL);
		for (args = cdr(code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
		  car(p) = ((s7_function)fcdr(args))(sc, car(args));
		sc->value = c_call(code)(sc, sc->args);
		goto START;
	      }
	      
	      
	    case OP_CALL_WITH_EXIT:
	      if (!c_function_is_ok(sc, code))
		break;
	      check_lambda_args(sc, cadr(cadr(code)), NULL); 
	      
	    case HOP_CALL_WITH_EXIT:
	      {
		s7_pointer go, args;
		go = make_goto(sc);
		args = fcdr(code);
		push_stack(sc, OP_DEACTIVATE_GOTO, go, code); /* code arg is ignored, but perhaps this is safer in GC? */
		NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, caar(args), go);
		sc->code = cdr(args);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      } 
	      
	      
	    case OP_C_FOR_EACH_LS:
	      if (!c_function_is_ok(sc, code))
		break;
	      check_lambda_args(sc, cadr(cadr(code)), NULL);
	      
	    case HOP_C_FOR_EACH_LS:
	      {
		/* for_each_1: (let () (define (f b) b) (define (hi) (let ((lst '(1 2 3))) (for-each (lambda (a) 123 (f a)) lst))) (hi)) 
		 */
		s7_pointer x, y, z;
		
		y = cdadr(code);
		MAKE_CLOSURE_NO_CAPTURE(sc, x, car(y), cdr(y), sc->envir);
		
		z = find_symbol_or_bust(sc, caddr(code));
		if ((!is_pair(z)) ||
		    (s7_list_length(sc, z) == 0))
		  {
		    sc->value = g_for_each(sc, list_2(sc, x, z));
		    goto START;
		  }
		sc->code = x;
		sc->args = make_simple_counter(sc, z);
		
		goto FOR_EACH_SIMPLE;
	      }
	      
	      
	    case OP_C_FOR_EACH_LS_2:
	      if (!c_function_is_ok(sc, code))
		break;
	      check_lambda_args(sc, cadr(cadr(code)), NULL);
	      
	    case HOP_C_FOR_EACH_LS_2:
	      {
		/* for_each_2: (let () (define (f b) b) (define (hi) (let ((lst '(1 2 3))) (for-each (lambda (a) (f a)) lst))) (hi))
		 */
		s7_pointer x, y, z;
		
		z = find_symbol_or_bust(sc, caddr(code));
		if (is_null(z))
		  {
		    sc->value = sc->UNSPECIFIED;
		    goto START;
		  }

		y = cdadr(code);
		MAKE_CLOSURE_NO_CAPTURE(sc, x, car(y), cdr(y), sc->envir); /* car=args, cdr=code */

		if ((!is_pair(z)) ||
		    (s7_list_length(sc, z) == 0))
		  {
		    sc->value = g_for_each(sc, list_2(sc, x, z));
		    goto START;
		  }
		sc->code = x;
		sc->args = make_simple_counter(sc, z);
		if ((is_optimized(car(closure_body(x)))) &&
		    (optimize_data(car(closure_body(x))) == HOP_C_CATCH_ALL))
		  goto FOR_EACH_SIMPLEST;
		goto FOR_EACH_SIMPLER;
	      }
	      
	      
	    case OP_C_FOR_EACH_L_opSq:
	      if (!c_function_is_ok(sc, code))
		break;
	      if (!indirect_c_function_is_ok(sc, caddr(code)))
		break;
	      check_lambda_args(sc, cadr(cadr(code)), NULL);
	      
	    case HOP_C_FOR_EACH_L_opSq:
	      {
		s7_pointer x, y, z;
		
		y = cdadr(code);
		MAKE_CLOSURE_NO_CAPTURE(sc, x, car(y), cdr(y), sc->envir);
		
		y = caddr(code);
		car(sc->T1_1) = find_symbol_or_bust(sc, cadr(y));
		z = c_call(y)(sc, sc->T1_1);
		
		if ((!is_pair(z)) ||
		    (s7_list_length(sc, z) == 0))
		  {
		    sc->value = g_for_each(sc, list_2(sc, x, z));
		    goto START;
		  }
		sc->code = x;
		sc->args = make_simple_counter(sc, z);
		if ((is_optimized(car(closure_body(x)))) &&
		    (optimize_data(car(closure_body(x))) == HOP_C_CATCH_ALL))
		  goto FOR_EACH_SIMPLEST;
		goto FOR_EACH_SIMPLER;
	      }
	      
	      
	    case OP_C_CATCH:
	      if (!c_function_is_ok(sc, code))
		break;
	      check_lambda_args(sc, cadr(cadddr(code)), NULL);
	      
	    case HOP_C_CATCH:
	      {
		/* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args)) 
		 *    code is (catch #t (lambda () ....) (lambda args ....))
		 */
		s7_pointer p, e, f, body, args;
		
		args = cddr(code);
		body = car(args);
		if (is_symbol(body))
		  {
		    body = find_symbol_or_bust(sc, body);
		    /* now if body is not a lambda form, we have to cancel the optimization */
		    if (!is_closure(body))
		      break;
		    if (!is_null(closure_args(body)))
		      return(wrong_type_argument_with_type(sc, sc->CATCH, small_int(2), body, A_THUNK));
		    e = closure_environment(body);
		    body = closure_body(body);
		  }
		else
		  {
		    if (!is_null(cadr(body)))
		      return(wrong_type_argument_with_type(sc, sc->CATCH, small_int(2), body, A_THUNK));
		    body = cddr(body);
		    e = sc->envir;
		  }
		
		/* defer making the error lambda */
		/* z = cdadr(args); MAKE_CLOSURE(sc, y, car(z), cdr(z), sc->envir); */ 
		
		NEW_CELL(sc, p);                     /* the catch object sitting on the stack */
		
		/* check target */
		f = cadr(code);
		if (!is_pair(f))                     /* (catch #t ...) or (catch sym ...) */
		  {
		    if (is_symbol(f))
		      catch_tag(p) = find_symbol_or_bust(sc, f);
		    else catch_tag(p) = f;
		  }
		else catch_tag(p) = cadr(f);         /* (catch 'sym ...) */
		
		catch_goto_loc(p) = s7_stack_top(sc);
		catch_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
		catch_handler(p) = cdadr(args);      /* not yet a closure... */
		set_type(p, T_CATCH);
		
		push_stack(sc, OP_CATCH_1, code, p); /* code ignored here, except by GC */
		NEW_FRAME(sc, e, sc->envir); 
		sc->code = body;
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }


	    case OP_C_CATCH_ALL:
	      if (!c_function_is_ok(sc, code))
		break;
	      
	    case HOP_C_CATCH_ALL:
	      {
		/* (catch #t (lambda () ...) (lambda args #f)
		 */
		s7_pointer p;
		NEW_FRAME(sc, sc->envir, sc->envir); 
		/* catch_all needs 3 pieces of info: the goto/op locs and the result
		 *   the locs are unsigned ints, so this fits in the new frame's dox1/2 fields.
		 */
		p = sc->envir;
		catch_all_goto_loc(p) = s7_stack_top(sc);
		catch_all_op_loc(p) = (int)(sc->op_stack_now - sc->op_stack);
		catch_all_result(p) = fcdr(code);
		push_stack_no_args(sc, OP_CATCH_ALL, code);
		sc->code = ecdr(cdr(code));                   /* the body of the first lambda */
		goto BEGIN;                                   /* removed one_liner check here -- rare */
	      }
	      
	      
	    default:
	      fprintf(stderr, "bad op in opt_eval: op %d, is_opt: %d %s, %s\n",
		      optimize_data(code), 
		      is_optimized(code), 
		      ((is_optimized(code)) && (optimize_data(code) < OPT_MAX_DEFINED)) ? opt_names[optimize_data(code)] : "",
		      DISPLAY_80(code));
	      break;
	    }
	  
	  /* else cancel all the optimization info -- someone stepped on our symbol */
	  
	  /* there is a problem with this -- if the caller still insists on goto OPT_EVAL, for example,
	   *   we get here over and over.  (let ((x (list (car y))))...) where list is redefined away.
	   */

	  /* see sss_apply_s7 for code to catch (f x y) here and set up optimizer code for it --
	   *   this cuts the trailer traffic in half in snd-test, but the savings is minimal (40).
	   */
	  clear_optimized(code);
	  clear_optimize_data(code);
	  set_ecdr(code, sc->NIL);
	  set_fcdr(code, sc->NIL);
	  /* and fall into the normal evaluator */
	}
      
      /* main cases here seem to be symbols from set!? 
       */
      if (is_pair(sc->code))
	{
	  if (typeflag(car(sc->code)) == SYNTACTIC_TYPE) /* this is much faster than checking is_syntactic */
	    {
	      /* if we hit this branch a lot, there's a bug somewhere!  Probably a check for is_syntactic at
	       *   optimization time that missed something that had not been lifted.
	       */
	      sc->cur_code = sc->code;               /* in case an error occurs, this helps tell us where we are */
	      set_type(sc->code, SYNTACTIC_PAIR);
	      sc->op = (opcode_t)syntax_opcode(car(sc->code));
	      /* fprintf(stderr, "set %s to %lld %s\n", DISPLAY(sc->code), sc->op, real_op_names[sc->op]); */
	      lifted_op(sc->code) = sc->op;
	      sc->code = cdr(sc->code);
	      goto START_WITHOUT_POP_STACK;
	    }
	  
	  /* -------------------------------------------------------------------------------- */
	  /* trailers */
	  sc->cur_code = sc->code;

	  /* t502:
	     44999: (* pulse-amp (env pulsef) (rk!cos gen1 (env pulse-frqf)))
	     10580: (make-polywave (* fm1-rat frequency) (list (floor fm1-rat) ...))
	     and macro expansion
	  */
	  {
	    s7_pointer carc;
	    carc = car(sc->code);
	    if (is_symbol(carc))
	      {
		/* car is a symbol, sc->code a list */
		sc->value = SYMBOL_TO_VALUE(sc, carc); /* not finder here -- nearly 2/3's of these are globals */
		sc->code = cdr(sc->code);
		sc->args = sc->NIL;
		/* drop into eval args
		 */
	      }
	    else
	      {
		/* very uncommon case: car is either itself a pair or some non-symbol */
		if (is_pair(carc))
		  {
		    /* evaluate the inner list */
		    push_stack(sc, OP_EVAL_ARGS, sc->NIL, cdr(sc->code));
		    if (typeflag(car(carc)) == SYNTACTIC_TYPE) 
		      /* was checking for is_syntactic here but that can be confused by successive optimizer passes:
		       *  (define (hi) (((lambda () list)) 1 2 3)) etc
		       */
		      {
			if ((car(carc) == sc->QUOTE) &&        /* ('and #f) */
			    ((!is_pair(cdr(carc))) ||          /* ((quote . #\h) (2 . #\i)) ! */
			     (is_syntactic(cadr(carc)))))
			  return(apply_error(sc, carc, cdr(sc->code)));
			sc->op = (opcode_t)syntax_opcode(car(carc));
			sc->code = cdr(carc);
			goto START_WITHOUT_POP_STACK;
		      }
		    
		    push_stack(sc, OP_EVAL_ARGS, sc->NIL, cdr(carc));
		    sc->code = car(carc);
		    goto EVAL;
		  }
		else
		  {
		    /* car must be the function to be applied */
		    sc->value = carc;
		    sc->code = cdr(sc->code);
		    sc->args = sc->NIL;
		    /* drop into OP_EVAL_ARGS */
		  }
	      }
	  }
	}
      else
	{
	  /* here sc->code is not a pair, the matching "if" is around line 38473!
	   */
	  if (is_symbol(sc->code))
	    {
	      sc->value = finder(sc, sc->code);
	      pop_stack(sc);
	      if (sc->op != OP_EVAL_ARGS)
		goto START_WITHOUT_POP_STACK;
	      /* drop into EVAL_ARGS */
	    }
	  else
	    {
	      /* sc->code is not a pair or a symbol */
	      sc->value = sc->code;
	      goto START;
	    }
	}
      /* sc->value is car=something applicable
       * sc->code = rest of expression
       * sc->args is nil (set by the drop-through cases above -- perhaps clearer to bring that down?)
       */
      
      
      /* --------------- */
    case OP_EVAL_ARGS:
      if (dont_eval_args(sc->value))
	{
	  if (is_any_macro(sc->value))
	    {    
	      /* macro expansion */
	      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->code); /* sc->code is here for (vital) GC protection */
	      /* 
	       * pass a list (mac . args) to the macro expander
	       */
	      sc->args = list_1(sc, cons(sc, sc->value, sc->code));
	      sc->code = sc->value;
	      goto APPLY;                      /* not UNSAFE_CLOSURE because it might be a bacro */
	    }
	  
	  /* (define progn begin)
	   * (progn (display "hi") (+ 1 23))
	   */
	  sc->op = (opcode_t)syntax_opcode(sc->value);
	  goto START_WITHOUT_POP_STACK;
	}
      
      /* sc->value is the func
       *   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.
       */
      /* if (is_null(sc->code)) {sc->code = sc->value; goto APPLY;}
       *   this is hit very rarely so it costs more than it saves
       */
      
      push_op_stack(sc, sc->value);
      if (sc->op_stack_now >= sc->op_stack_end)
	resize_op_stack(sc);
      
      goto EVAL_ARGS;
      /* moving eval_args up here (to avoid this goto) was slightly slower, probably by chance.
       */
      
      /* --------------- */
    case OP_EVAL_ARGS5:
      /* sc->value is the last arg, sc->code is the previous
       */
      {
	s7_pointer x, y;
	
	sc->z = pop_op_stack(sc);
	if (is_safe_procedure(sc->z))
	  {
	    x = sc->temp_cell_3;
	    y = sc->temp_cell_2;
	  }
	else
	  {
	    NEW_CELL(sc, x); 
	    set_type(x, T_PAIR);
	    NEW_CELL_NO_CHECK(sc, y); 
	    set_type(y, T_PAIR);
	  }
	
	car(x) = sc->code;
	cdr(x) = sc->args;
	car(y) = sc->value;
	cdr(y) = x;
	sc->args = safe_reverse_in_place(sc, y); 
	sc->code = sc->z;
	goto APPLY;
      }
      
      
      /* --------------- */
    case OP_EVAL_ARGS2:
      /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2]
       */
      {
	s7_pointer x;
	
	sc->code = pop_op_stack(sc);
	if (is_safe_procedure(sc->code))
	  x = sc->temp_cell_2;
	else
	  {
	    NEW_CELL(sc, x);
	    set_type(x, T_PAIR);
	  }
	car(x) = sc->value;
	cdr(x) = sc->args;
	if (type(sc->args) != T_NIL)
	  sc->args = safe_reverse_in_place(sc, x);
	else sc->args = x;
	goto APPLY;
      }
      

      /* --------------- */
      /* tricky cases here all involve values (i.e. multiple-values) */
      
    case OP_EVAL_ARGS_P_1:
      /* only from HOP_SAFE_C_P
       * if multiple values from func, splice_in_values revectors us to OP_EVAL_ARGS_P_1_MV.
       */
      car(sc->T1_1) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T1_1);
      goto START;
      

    case OP_EVAL_ARGS_P_1_MV:
      /* we can't just call the c function directly here because the values call that
       *   passed us these new arguments might have too many values, so it's simpler
       *   to let OP_APPLY sort that out.
       */
      sc->args = sc->value;
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY;


      
      /* --------------- */
    case OP_EVAL_ARGS_P_2:
      /* from HOP_SAFE_C_SP||CP|QP, handled like P_1 case above
       */
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;


    case OP_EVAL_ARGS_P_2_MV:
      sc->args = cons(sc, sc->args, sc->value);
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY;
      
      
      /* --------------- */
    case OP_EVAL_ARGS_SSP_1:
      /* from HOP_SAFE_C_SSP */
      car(sc->T3_3) = sc->value;
      car(sc->T3_1) = finder(sc, cadr(sc->code));
      car(sc->T3_2) = finder(sc, caddr(sc->code));
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;


    case OP_EVAL_ARGS_SSP_MV:
      sc->args = cons(sc, finder(sc, cadr(sc->code)), cons(sc, finder(sc, caddr(sc->code)), sc->value));
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY;
      
      
      /* --------------- */
    case OP_EVAL_ARGS_P_3:
      car(sc->T2_2) = finder(sc, caddr(sc->code)); 
      /* we have to wait because we say the evaluation order is always left to right
       *   and the first arg's evaluation might change the value of the second arg.
       */
      car(sc->T2_1) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;

    case OP_EVAL_ARGS_P_3_MV:
      /* (define (hi a) (+ (values 1 2) a)) 
       * (define (hi a) (log (values 1 2) a))
       */
      sc->w = sc->value;
      sc->args = cons(sc, finder(sc, caddr(sc->code)), sc->w);
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY;
      
      
      /* --------------- */
    case OP_EVAL_ARGS_P_4:
      car(sc->T2_1) = sc->value;
      car(sc->T2_2) = sc->args;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;

    case OP_EVAL_ARGS_P_4_MV: /* same as P_2_MV) */
      sc->args = cons(sc, sc->args, sc->value);
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY; /* (define (hi) (log (values 1 2) 3)) ? */
      

      /* --------------- */
    case OP_SAFE_C_ZS_1:
      car(sc->T2_1) = sc->value;
      car(sc->T2_2) = sc->args;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_SZ_1:
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_SZ_SZ:
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      car(sc->T2_2) = c_call(caddr(sc->code))(sc, sc->T2_1);
      car(sc->T2_1) = finder(sc, cadr(sc->code));
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZA_1:
      car(sc->T2_2) = ((s7_function)fcdr(cddr(sc->code)))(sc, caddr(sc->code));
      car(sc->T2_1) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZZ_1:
      push_stack(sc, OP_SAFE_C_ZZ_2, sc->value, sc->code);
      sc->code = caddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZ_2:
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZAA_1:
      car(sc->A3_1) = sc->value;
      car(sc->A3_2) = ((s7_function)fcdr(cddr(sc->code)))(sc, caddr(sc->code));
      car(sc->A3_3) = ((s7_function)fcdr(cdddr(sc->code)))(sc, cadddr(sc->code));
      sc->value = c_call(sc->code)(sc, sc->A3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_AZA_1:
      car(sc->T3_3) = ((s7_function)fcdr(cdddr(sc->code)))(sc, cadddr(sc->code));
      car(sc->T3_2) = sc->value;
      car(sc->T3_1) = sc->args;
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_SSZ_1:
      car(sc->T3_1) = sc->args;
      car(sc->T3_3) = sc->value;
      car(sc->T3_2) = finder(sc, caddr(sc->code));
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_AAZ_1:
      car(sc->T3_1) = pop_op_stack(sc);
      car(sc->T3_2) = sc->args;
      car(sc->T3_3) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZZA_1:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_ZZA_2, sc->args, sc->code);
      sc->code = caddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZA_2:
      car(sc->A3_1) = pop_op_stack(sc);
      car(sc->A3_2) = sc->value;
      car(sc->A3_3) = ((s7_function)fcdr(cdddr(sc->code)))(sc, cadddr(sc->code));
      sc->value = c_call(sc->code)(sc, sc->A3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZAZ_1:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_ZAZ_2, ((s7_function)fcdr(cddr(sc->code)))(sc, caddr(sc->code)),  sc->code);
      sc->code = cadddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZAZ_2:
      car(sc->T3_1) = pop_op_stack(sc);
      car(sc->T3_2) = sc->args;
      car(sc->T3_3) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_AZZ_1:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_AZZ_2, sc->args, sc->code);
      sc->code = cadddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_AZZ_2:
      car(sc->T3_1) = sc->args;
      car(sc->T3_2) = pop_op_stack(sc);
      car(sc->T3_3) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;
      

      /* --------------- */
    case OP_SAFE_C_ZZZ_1:
      push_stack(sc, OP_SAFE_C_ZZZ_2, sc->value, sc->code);
      sc->code = caddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZZ_2:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_ZZZ_3, sc->args, sc->code);
      sc->code = cadddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZZ_3:
      car(sc->T3_1) = sc->args;
      car(sc->T3_2) = pop_op_stack(sc);
      car(sc->T3_3) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T3_1);
      goto START;



      /* --------------- */
    case OP_SAFE_C_ZZZZ_1:
      push_stack(sc, OP_SAFE_C_ZZZZ_2, sc->value, sc->code);
      sc->code = caddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZZZ_2:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_ZZZZ_3, sc->args, sc->code);
      sc->code = cadddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZZZ_3:
      push_op_stack(sc, sc->value);
      push_stack(sc, OP_SAFE_C_ZZZZ_4, sc->args, sc->code);
      sc->code = caddddr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_C_ZZZZ_4:
      sc->z = sc->args;
      if (!list_is_in_use(sc->safe_lists[4]))
	sc->args = sc->safe_lists[4];
      else sc->args = make_list(sc, 4, sc->NIL);

      car(sc->args) = sc->z;
      cadddr(sc->args) = sc->value;
      caddr(sc->args) = pop_op_stack(sc);
      cadr(sc->args) = pop_op_stack(sc);
      sc->value = c_call(sc->code)(sc, sc->args);
      goto START;


      /* --------------- */
    case OP_SAFE_C_opSq_P_1:
      /* this is the no-multiple-values case */
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;

    case OP_SAFE_C_opSq_P_MV:
      /* here we need an argnum check since values could have appended any number of args
       */
      sc->args = cons(sc, sc->args, sc->value);
      
      /* can values return an improper or circular list?  I don't think so:
       *   (values 1 . 2) -> improper arg list error (same with apply values)
       *
       * currently (values) does not simply erase itself:
       *
       *   :(let () (define (arg2 a) (let ((b 1)) (set! b (+ a b)) (values))) (define (hi c) (expt (abs c) (arg2 2))) (hi 2))
       *   ;expt power, argument 2, #<unspecified>, is an untyped but should be a number
       *  
       *   :(s7-version (values))
       *   ;s7-version: too many arguments: (#<unspecified>)
       *
       *   :(exp (values) 0.0)
       *   ;exp: too many arguments: (#<unspecified> 0.0)
       *
       * map is explicitly a special case, and surely it is more confusing to have (values) scattered at random.
       * also this is consistent with the unoptimized version
       */
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY; /* (define (hi a) (+ (abs a) (values 1 2 3))) */
      

      /* --------------- */
    case OP_EVAL_ARGS3:
      /* sc->value is the next-to-last arg, and we know the last arg is not a list (so values can't mess us up!)
       */
      {
	s7_pointer x, y, val;
	
	val = sc->code;
	if (is_symbol(val))
	  val = finder(sc, val);
	
	sc->x = pop_op_stack(sc);
	if (is_safe_procedure(sc->x))
	  {
	    x = sc->temp_cell_3;
	    y = sc->temp_cell_2;
	  }
	else
	  {
	    NEW_CELL(sc, x); 
	    set_type(x, T_PAIR);
	    NEW_CELL_NO_CHECK(sc, y);
	    set_type(y, T_PAIR);
	  }
	car(x) = sc->value;
	cdr(x) = sc->args;
	car(y) = val;
	cdr(y) = x;
	sc->args = safe_reverse_in_place(sc, y); 
	sc->code = sc->x;
	goto APPLY;
      }
      
      
      /* --------------- */
    case OP_EVAL_ARGS4:
      /* sc->code is a pair, and either cdr(sc->code) is not null or car(sc->code) is a pair 
       */
      /* fprintf(stderr, "code: %s, value: %s, args: %s\n", DISPLAY_80(sc->code), DISPLAY_80(sc->value), DISPLAY_80(sc->args)); 
       *   (#f #f) (env #f) etc.  args is very often nil here, so we're looking at 3 simple args
       *   or even just 2 in some cases: (+ req opt) with value 2 and args ()
       */
      {
        s7_pointer x;
	NEW_CELL(sc, x);
	car(x) = sc->value;
	cdr(x) = sc->args;
	set_type(x, T_PAIR);
	sc->args = x; /* all the others reverse -- why not this case? --reverse is at end? (below) */
	goto EVAL_ARGS_PAIR;
      }
      
      
      /* --------------- */
    case OP_EVAL_ARGS1:
      {
        s7_pointer x;
	NEW_CELL(sc, x);
	car(x) = sc->value;
	cdr(x) = sc->args;
	set_type(x, T_PAIR);
	sc->args = x;
      }
      
      
    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) */
	{ 
	  int typ;
	  s7_pointer car_code;
	  
	EVAL_ARGS_PAIR:
	  car_code = car(sc->code);
	  typ = type(car_code);
	  
	  /* switch statement here is much slower for some reason */
	  if (typ == T_PAIR)
	    {
	      if (is_null(cdr(sc->code)))
		push_stack(sc, OP_EVAL_ARGS2, sc->args, sc->NIL);
	      else 
		{
		  if (!is_pair(cdr(sc->code)))            /* (= 0 '(1 . 2) . 3) */
		    improper_arglist_error(sc);
		  
		  if ((is_null(cddr(sc->code))) &&
		      (!is_pair(cadr(sc->code))))
		    push_stack(sc, OP_EVAL_ARGS3, sc->args, cadr(sc->code)); 
		  else push_stack(sc, OP_EVAL_ARGS4, sc->args, cdr(sc->code));
		}
	      sc->code = car_code;
	      if (is_optimized(sc->code))
		goto OPT_EVAL;
	      goto EVAL; 
	    }
	  
	  /* car(sc->code) is not a pair */
	  if (is_pair(cdr(sc->code)))
	    {
	      sc->code = cdr(sc->code);
	      if (typ == T_SYMBOL)
		sc->value = finder(sc, car_code);
	      else sc->value = car_code;
	      /* sc->value is the current arg's value, sc->code is pointing to the next */
	      
	      /* cdr(sc->code) may not be a pair or nil here! 
	       *   (eq? #f . 1) -> sc->code is 1
	       */
	      if (is_null(cdr(sc->code)))
		{
		  s7_pointer x, y, val;
		  /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */
		  car_code = car(sc->code);
		  typ = type(car_code);
		  
		  if (typ == T_PAIR)
		    {
		      push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value);
		      sc->code = car_code;
		      goto EVAL; 
		    }
		  
		  /* get the last arg */
		  if (typ == T_SYMBOL)
		    val = finder(sc, car_code);
		  else val = car_code;
		  
		  /* get the current arg, which is not a list */
		  sc->code = pop_op_stack(sc);
		  if (is_safe_procedure(sc->code)) /* this check does not currently pay for itself, I think */
		    {
		      x = sc->temp_cell_3; /* these are already pairs */
		      y = sc->temp_cell_2;
		    }
		  else
		    {
		      NEW_CELL(sc, x); 
		      set_type(x, T_PAIR);
		      NEW_CELL_NO_CHECK(sc, y); 
		      set_type(y, T_PAIR);
		    }
		  car(x) = sc->value;
		  cdr(x) = sc->args;
		  car(y) = val;
		  cdr(y) = x;
		  sc->args = safe_reverse_in_place(sc, y); 
		  /* 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
		   */
		  s7_pointer x;
		  NEW_CELL(sc, x); 
		  car(x) = sc->value;
		  cdr(x) = sc->args;
		  set_type(x, T_PAIR);
		  sc->args = x;
		  goto EVAL_ARGS_PAIR;
		}
	    }
	  else
	    {
	      /* here we've reached the last arg (sc->code == nil) 
	       *   it is not a pair (typ == T_PAIR was caught earlier)
	       *   if this is a safe function, we're going straight to
	       *   apply with no complications, so we can use temp_cell_2.
	       */
	      s7_pointer x;
	      
	      if (type(cdr(sc->code)) != T_NIL)
		improper_arglist_error(sc);
	      
	      sc->code = pop_op_stack(sc);
	      if (is_safe_procedure(sc->code))
		{
		  x = sc->temp_cell_2;
		  if (typ == T_SYMBOL)
		    car(x) = finder(sc, car_code);
		  else car(x) = car_code;
		  cdr(x) = sc->args;
		}
	      else
		{
		  s7_pointer val;
		  if (typ == T_SYMBOL)
		    val = finder(sc, car_code); /* this has to precede the set_type below */
		  else val = car_code;
		  NEW_CELL(sc, x); 
		  car(x) = val;
		  cdr(x) = sc->args;
		  set_type(x, T_PAIR);
		}
	      
	      if (type(sc->args) != T_NIL)
		sc->args = safe_reverse_in_place(sc, x);
	      else sc->args = x;
	      /* drop into APPLY */
	    }
	}
      else                       /* got all args -- go to apply */
	{
	  if (is_not_null(sc->code))
	    improper_arglist_error(sc);
	  else
	    {
	      sc->code = pop_op_stack(sc);
	      sc->args = safe_reverse_in_place(sc, sc->args); 
	      /* fall through  */
	    }
	}
      
      /* we could omit the arg reversal in many cases, but lots of code assumes the args are in order;
       *   adding a bit for this in the type field saves some time in s7test (many + and * tests), but costs
       *   about the same time in other cases, so it's not a clear win.
       */
      
      /*
       * if (sc->stack_end >= sc->stack_resize_trigger)
       *   increase_stack_size(sc);
       *
       * the two places where the stack reaches it maximum size are in read_expression where TOKEN_LEFT_PAREN
       *   pushes OP_READ_LIST, and (the actual max) in OP_EVAL at the push of OP_EVAL_ARGS.  I've moved
       *   the stack size check from here (where it reflects the eval stack size) to read_expression (where
       *   it reflects nested list depth), and added it to the T_CLOSURE(*) parts of apply since (for example) 
       *   extremely deep recursion involving map or for-each can increase the stack size indefinitely:
       *
       * (define (tfe a b)
       *   (format #t "~A ~A -> ~A~%" a b (-s7-stack-size))
       *   (for-each
       *     (lambda (c)
       *       (if (< c b)
       *           (tfe (+ c 1) b)))
       *     (list a)))
       *
       * now (tfe 0 1000) triggers the stack increase.
       */
      
    APPLY:
      /* fprintf(stderr, "apply %s to %s\n", DISPLAY(sc->code), DISPLAY(sc->args));  */
      switch (type(sc->code))
	{
	case T_C_FUNCTION: 	                    /* -------- C-based function -------- */
	  {
	    unsigned int len;
	    len = safe_list_length(sc, sc->args);
	    
	    if (len < c_function_required_args(sc->code))
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args)));
	    
	    if (c_function_all_args(sc->code) < len)
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args)));
	  }
	  /* drop into ... */
	  
	case T_C_ANY_ARGS_FUNCTION:                 /* -------- C-based function that can take any number of arguments -------- */
	  sc->value = c_function_call(sc->code)(sc, sc->args);
	  goto START;
	  
	  
	case T_C_OPT_ARGS_FUNCTION:                 /* -------- C-based function that has n optional arguments -------- */
	  {
	    unsigned int len;
	    len = safe_list_length(sc, sc->args);
	    if (c_function_all_args(sc->code) < len)
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args)));
	    sc->value = c_function_call(sc->code)(sc, sc->args);
	    goto START;
	  }
	  
	case T_C_RST_ARGS_FUNCTION:                 /* -------- C-based function that has n required args, then any others -------- */
	  {
	    unsigned int len;
	    len = safe_list_length(sc, sc->args);
	    if (len < c_function_required_args(sc->code))
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args)));
	    sc->value = c_function_call(sc->code)(sc, sc->args);
	    /* sc->code here need not match sc->code before the function call (map for example) */
	    goto START;
	  }
	  
	case T_C_LST_ARGS_FUNCTION:                 /* -------- {list} -------- */
	  if (sc->no_values == 0)
	    sc->value = sc->args;
	  else sc->value = g_qq_list(sc, sc->args);
	  goto START;
	  
	case T_C_MACRO: 	                    /* -------- C-based macro -------- */
	  {
	    int len;
	    
	    if (is_pair(car(sc->args)))            /* normally args is ((mac-name ...)) */
	      {                                    /*   but in a case like (call-with-exit quasiquote), args is (#<goto>) */
		if (!s7_is_list(sc, cdar(sc->args)))  /* (quasiquote . 1) */
		  eval_error(sc, "improper list of arguments: ~A", car(sc->args));
		sc->args = cdar(sc->args);         
	      }
	    else 
	      {
		/* I think this can only be triggered by map/for-each with a (c_)macro [in fact, quasiquote] argument,
		 *    so perhaps we can fix it here?
		 */
		eval_error(sc, "~A called as a function, but it's a macro!", sc->code);
	      }
	    
	    len = s7_list_length(sc, sc->args);
	    if (len <= 0)                          /* (quasiquote 0 . 1) */
	      return(s7_error(sc, sc->SYNTAX_ERROR, 
			      list_3(sc, make_protected_string(sc, "~A: improper list of arguments: ~S"), sc->code, sc->args)));
	    
	    if (len < (int)c_macro_required_args(sc->code))
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->NOT_ENOUGH_ARGUMENTS, sc->code, sc->args)));
	    
	    if ((int)c_macro_all_args(sc->code) < len)
	      return(s7_error(sc, 
			      sc->WRONG_NUMBER_OF_ARGS, 
			      list_3(sc, sc->TOO_MANY_ARGUMENTS, sc->code, sc->args)));
	    
	    sc->value = c_macro_call(sc->code)(sc, sc->args);
	    goto START;
	  }
	  
	case T_BACRO:                                /* -------- bacro -------- */
	  NEW_FRAME(sc, sc->envir, sc->envir);       /* like let* -- we'll be adding macro args, so might as well sequester things here */
	  goto BACRO;
	  /* another choice is to do expansion and evaluation in the definition env,
	   *   so only the args come (unevaluated) from the current env.
	   *   I can't immediately see any need for this.
	   *
	   * but probably useful would be bacro without the following evaluation, sort of like a function with unevaluated args
	   *  (but expanded in the call-time env): "lacro"?
	   */
	  
	case T_CLOSURE:                              /* -------- normal function (lambda), or macro -------- */
	  /* not often safe closure here, and very confusing if so to get identity macro args handled correctly */
	  CHECK_STACK_SIZE(sc);
	  
	case T_MACRO:
	  NEW_FRAME(sc, closure_environment(sc->code), sc->envir);
	  
	BACRO:
	  /* load up the current args into the ((args) (lambda)) layout [via the current environment] */
	  
	  /* (defmacro hi (a b) `(+ ,a ,b)) */
	  /*   -> code: #<macro>, args: ((hi 2 3)), closure args: (defmac-9) */
	  /*   then back again: code: #<closure>, args: (2 3), closure args: (a b) */
	  
	  /* (define (hi a b) (+ a b))
	   * (hi 1 2)
	   * sc->args: (1 2)
	   */
	  
	  /* it is possible to apply a macro:
	   *
	   * (define-macro (hi a) `(+ ,a 1))
	   * (apply hi '(4))
	   * 5
	   *
	   * (let ((x 32)) (define-macro* (mac (a (let () (display x) 3))) `(+ 1 ,a)) (let ((x 4)) (mac x)))
	   * displays 32, returns 5, so the evaluation of the default value happens in the definition environment
	   * (let ((x 32)) (define* (mac (a (let () (display x) 3))) (+ 1 a)) (let ((x 4)) (mac x)))
	   * is the same
	   * (let ((x 32)) (define-bacro* (mac (a (let () (display x) 3))) `(+ 1 ,a)) (let ((x 4)) (mac x)))
	   * displays 4 and returns 5
	   *
	   * so... we need a way to get the call environment from within either a macro or a function
	   */
	  
	  /* (let* ((mac (let () (define-macro (mac1 a) `(+ ,a 1)) mac1)) (lst (list 1))) (set-cdr! lst lst) (apply mac lst ()))
	   * hangs -- this is equivalent to (eval <circular-list>) which also hangs.
	   */
	  
	  {
	    s7_pointer x, z, e;
	    unsigned long long int id;
	    e = sc->envir;
	    id = environment_id(e);
	    
	    for (x = closure_args(sc->code), z = sc->args; is_pair(x); x = cdr(x))
	      {
		s7_pointer sym, args, val;
		/* reuse the value cells as the new frame slots */
		
		if (is_null(z))
		  return(s7_error(sc, 
				  sc->WRONG_NUMBER_OF_ARGS, 
				  list_3(sc, sc->NOT_ENOUGH_ARGUMENTS, closure_name(sc, sc->code), sc->cur_code)));
		/* now that args are being reused as slots, the error message can't use sc->args, 
		 *  so fallback on sc->cur_code in this section.
		 */

		sym = car(x);
		val = car(z);
		args = cdr(z);
		
		slot_symbol(z) = sym;
		symbol_set_local(sym, id, z);
		if (symbol_has_accessor(sym))
		  slot_set_value(z, call_symbol_bind(sc, sym, val));
		else slot_set_value(z, val);
		set_type(z, T_SLOT | T_IMMUTABLE);
		next_slot(z) = environment_slots(e);
		environment_slots(e) = z;
		z = args;
	      }
	    if (is_null(x)) 
	      {
		if (is_not_null(z))
		  return(s7_error(sc, 
				  sc->WRONG_NUMBER_OF_ARGS, 
				  list_3(sc, sc->TOO_MANY_ARGUMENTS, closure_name(sc, sc->code), sc->cur_code)));
	      } 
	    else add_slot(sc, x, z); /* the rest arg */
	  }
	  
	  sc->code = closure_body(sc->code);
	  if (is_pair(cdr(sc->code)))
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	  else
	    {
	      if (!is_null(cdr(sc->code)))
		return(eval_error(sc, "closure body: stray dot? ~A", sc->code));		
	    }
	  sc->code = car(sc->code);
	  goto EVAL;
	  
	  
	case T_CLOSURE_STAR:	                  /* -------- define* (lambda*) -------- */
	  { 
	    s7_pointer z;
	    CHECK_STACK_SIZE(sc);
	    sc->envir = new_frame_in_env(sc, closure_environment(sc->code)); 
	    /* get default values, which may involve evaluation 
	     */
	    push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code); /* op is just a placeholder (don't use OP_BARRIER here) */
	    sc->args = closure_args(sc->code);
	    
	  LAMBDA_STAR_DEFAULT:
	    z = sc->args;
	    if (is_pair(z))
	      {
		/* bind all the args to something (default value or #f or maybe #undefined) */
		if (car(z) != sc->KEY_ALLOW_OTHER_KEYS)
		  {
		    if (car(z) == sc->KEY_REST)
		      {
			add_slot(sc, cadr(z), sc->NIL);       /* set :rest arg to sc->NIL, not sc->F */
			sc->args = cdr(sc->args);
		      }
		    else
		      {
			if (is_pair(car(z)))                 /* (define* (hi (a mus-next)) a) */
			  {                                  /* or (define* (hi (a 'hi)) (list a (eq? a 'hi))) */
			    /* if default val is an expression, it needs to be evaluated in the definition environment
			     *   (let ((c 1)) (define* (a (b (+ c 1))) b) (set! c 2) (a)) -> 3
			     */
			    s7_pointer val;
			    val = cadar(z);
			    if (is_symbol(val))
			      add_slot(sc, caar(z), finder(sc, val));
			    else
			      {
				if (is_pair(val))
				  {
				    if (car(val) == sc->QUOTE)
				      add_slot(sc, caar(z), cadr(val));
				    else
				      {
					push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
					sc->code = cadar(z);
					goto EVAL; 
				      }
				  }
				else add_slot(sc, caar(z), val);
			      }
			  }
			else add_slot(sc, car(z), sc->F);
		      }
		  }
		sc->args = cdr(sc->args);
		goto LAMBDA_STAR_DEFAULT;
	      }
	    else
	      {
		if (is_symbol(z))                      /* dotted (last) arg? -- make sure its name exists in the current environment */
		  add_slot(sc, z, sc->NIL); 
	      }
	    /* end of default arg evaluations */
	    
	    pop_stack_no_op(sc);                          /* get original args and code back */
	    lambda_star_set_args(sc);                     /* load up current arg vals */
	    sc->code = closure_body(sc->code);            /* evaluate the function body */
	    if (is_pair(cdr(sc->code)))
	      push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	    sc->code = car(sc->code);
	    goto EVAL;
	  }
	  
	case T_CONTINUATION:	                  /* -------- continuation ("call/cc") -------- */
	  if (!call_with_current_continuation(sc))
	    return(s7_error(sc, make_symbol(sc, "baffled!"),
			    list_1(sc, make_protected_string(sc, "continuation can't jump into with-baffle"))));
	  goto START;
	  
	case T_GOTO:	                          /* -------- goto ("call-with-exit") -------- */
	  call_with_exit(sc);
	  goto START;
	  
	case T_C_OBJECT:                          /* -------- applicable (new-type) object -------- */
	  {
	    s7_pointer args, obj;
	    obj = sc->code;
	    args = sc->args;
	    if ((!is_null(args)) &&
		(is_null(cdr(args))))
	      {
		s7_pointer (*ref_2)(s7_scheme *sc, void *val, s7_pointer index);
		s7_pointer index;
		index = car(args);

		if (is_integer(index))
		  {
		    if ((c_object_has_array(obj)) &&
			(integer(index) >= 0) &&
			(integer(index) < c_object_array_length(obj)))
		      {
			sc->value = make_real(sc, c_object_array(obj)[integer(index)]);
			goto START;
		      }
		  }
		ref_2 = c_object_ref_2(obj);
		if (ref_2)
		  {
		    sc->value = (*(ref_2))(sc, c_object_value(obj), index);
		    goto START;
		  }
	      }
	  sc->value = (*(c_object_ref(obj)))(sc, obj, args);
	  goto START;
	  }
	  

	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:                            /* -------- 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))) */
	    return(s7_wrong_number_of_args_error(sc, "not enough args for vector-ref: ~A", sc->args));

	  if ((is_null(cdr(sc->args))) &&       
	      (s7_is_integer(car(sc->args))) &&
	      (!vector_is_multidimensional(sc->code)))
	    {
	      s7_Int index;
	      index = s7_integer(car(sc->args));
	      if ((index >= 0) &&
		  (index < vector_length(sc->code)))
		{
		  sc->value = vector_getter(sc->code)(sc, sc->code, index);
		  goto START;
		}
	      else out_of_range(sc, sc->VECTOR_REF, small_int(2), car(sc->args), "should be between 0 and the vector length");
	    }
	  sc->value = vector_ref_1(sc, sc->code, sc->args);
	  goto START;
	  
	  
	case T_STRING:                            /* -------- string as applicable object -------- */
	  if (is_null(cdr(sc->args)))
	    {
	      if (s7_is_integer(car(sc->args)))
		{
		  s7_Int index;                  /* not int: ("abs" most-negative-fixnum) */
		  index = s7_integer(car(sc->args));
		  if ((index >= 0) &&
		      (index < string_length(sc->code)))
		    {
		      if (is_bytevector(sc->code))
			sc->value = small_int((unsigned int)(string_value(sc->code))[index]);
		      else sc->value = s7_make_character(sc, ((unsigned char *)string_value(sc->code))[index]);
		      goto START;
		    }
		}
	      sc->value = string_ref_1(sc, sc->code, car(sc->args));
	      goto START;
	    }
	  return(s7_error(sc, 
			  sc->WRONG_NUMBER_OF_ARGS, 
			  list_3(sc, (is_null(sc->args)) ? sc->NOT_ENOUGH_ARGUMENTS : sc->TOO_MANY_ARGUMENTS, sc->code, sc->args)));
	  
	  
	case T_PAIR:                              /* -------- list as applicable object -------- */
	  if (is_multiple_value(sc->code))                                  /* ((values 1 2 3) 0) */
	    {
	      /* car of values can be anything, so conjure up a new expression, and apply again */
	      sc->x = multiple_value(sc->code);                             /* ((values + 1 2) 3) */
	      sc->code = car(sc->x);
	      sc->args = s7_append(sc, cdr(sc->x), sc->args);
	      sc->x = sc->NIL;
	      goto APPLY;
	    }
	  if (is_null(sc->args))
	    return(s7_wrong_number_of_args_error(sc, "not enough args for list-ref (via list as applicable object): ~A", sc->args));
	  sc->value = list_ref_1(sc, sc->code, car(sc->args));            /* (L 1) */
	  if (!is_null(cdr(sc->args)))
	    sc->value = implicit_index(sc, sc->value, cdr(sc->args));     /* (L 1 2) */
	  goto START;
	  
	  
	case T_HASH_TABLE:                        /* -------- hash-table as applicable object -------- */
	  if (is_null(sc->args))
	    return(s7_wrong_number_of_args_error(sc, "not enough args for hash-table-ref (via hash table as applicable object): ~A", sc->args));
	  sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args));
	  if (!is_null(cdr(sc->args)))
	    sc->value = implicit_index(sc, sc->value, cdr(sc->args));
	  goto START;
	  
	  
	case T_ENVIRONMENT:                       /* -------- environment as applicable object -------- */
	  if (is_null(sc->args))
	    return(s7_wrong_number_of_args_error(sc, "environment as applicable object takes one argument: ~A", sc->args));

	  if (is_symbol(car(sc->args)))
	    sc->value = s7_environment_ref(sc, sc->code, car(sc->args));
	  else return(simple_wrong_type_argument_with_type(sc, sc->ENVIRONMENT_REF, car(sc->args), A_SYMBOL));

	  if (is_pair(cdr(sc->args)))
	    sc->value = implicit_index(sc, sc->value, cdr(sc->args));
	  /*    (let ((v #(1 2 3))) (let ((e (current-environment))) ((e 'v) 1))) -> 2
	   * so (let ((v #(1 2 3))) (let ((e (current-environment))) (e 'v 1))) -> 2
	   */ 
	  goto START;
	  
	  
	case T_SYNTAX:                            /* -------- syntactic keyword as applicable object -------- */
	  sc->op = (opcode_t)syntax_opcode(sc->code);                       /* (apply begin '((define x 3) (+ x 2))) */
	  sc->code = sc->args;
	  goto START_WITHOUT_POP_STACK;
	  
	  
	default:
	  return(apply_error(sc, sc->code, sc->args));
	}
      /* ---------------- end APPLY/EVAL ---------------- */
      
      
      /* --------------- */
    case OP_LAMBDA_STAR_DEFAULT:
      /* sc->args is the current closure arg list position, sc->value is the default expression's value
       */
      add_slot(sc, caar(sc->args), sc->value);
      sc->args = cdr(sc->args);
      goto LAMBDA_STAR_DEFAULT;
      
      
      /* --------------- */
    case OP_QUOTE:
      check_quote(sc);
      
      /* --------------- */
    case OP_QUOTE_UNCHECKED:
      sc->value = car(sc->code);
      goto START;
      
      
      /* --------------- */
    case OP_DEFINE_STAR:
      check_define(sc);
      
      /* --------------- */
    case OP_DEFINE_STAR_UNCHECKED:
      {
	s7_pointer x;
	/* make_closure* */
	NEW_CELL(sc, x);
	closure_args(x) = cdar(sc->code);
	closure_body(x) = cdr(sc->code);
	closure_environment(x) = sc->envir;
	if (is_integer(fcdr(sc->code)))
	  closure_arity(x) = integer(fcdr(sc->code));
	else closure_arity(x) = CLOSURE_ARITY_NOT_SET;
	closure_setter(x) = sc->F;
	if (is_safe_closure(cdr(sc->code)))
	  set_type(x, T_CLOSURE_STAR | T_PROCEDURE | T_SAFE_CLOSURE);
	else set_type(x, T_CLOSURE_STAR | T_PROCEDURE);
	if (is_null(cdr(closure_body(x)))) set_one_liner(x);
	sc->capture_env_counter++;
	sc->value = x;
	sc->code = caar(sc->code);
	goto DEFINE1;
      }


      /* --------------- */
    case OP_DEFINE_FUNCHECKED:
      {
	/* we can't optimize away cases like (define (make-func) (define (a-func a) (+ a 1))) because we'll
	 *   also collapse ((symbol->value (define...)) args)
	 */
	s7_pointer new_func, new_env;

	sc->value = caar(sc->code);

	/* make_closure... */
	NEW_CELL(sc, new_func);
	closure_args(new_func) = cdar(sc->code);
	closure_body(new_func) = cdr(sc->code);
	closure_setter(new_func) = sc->F; 
	closure_arity(new_func) = integer(fcdr(sc->code));
	set_type(new_func, T_CLOSURE | T_PROCEDURE | T_COPY_ARGS); 
	if (is_null(cdr(closure_body(new_func)))) set_one_liner(new_func);
	sc->capture_env_counter++; 
	
	if (is_safe_closure(cdr(sc->code)))
	  {
	    s7_pointer arg;
	    set_safe_closure(new_func);
	    
	    NEW_CELL_NO_CHECK(sc, new_env);
	    environment_id(new_env) = ++environment_number;
	    environment_slots(new_env) = sc->NIL;
	    next_environment(new_env) = sc->envir;
	    set_type(new_env, T_ENVIRONMENT | T_IMMUTABLE | T_FUNCTION_ENV);
	    closure_environment(new_func) = new_env;
	    environment_function(new_env) = sc->value;
	    
	    for (arg = closure_args(new_func); is_pair(arg); arg = cdr(arg))
	      s7_make_slot(sc, new_env, car(arg), sc->NIL);
	    environment_slots(new_env) = reverse_slots(sc, environment_slots(new_env));
	  }
	else closure_environment(new_func) = sc->envir;
	/* unsafe closures created by other functions do not support __func__ */
	
	ADD_SLOT(sc->envir, sc->value, new_func);
	set_local(sc->value);
	
	goto START;
      }

      
      /* --------------- */
    case OP_DEFINE_CONSTANT1:
      /* define-constant -> OP_DEFINE_CONSTANT -> OP_DEFINE..1, then back to here */
      /*   at this point, sc->value is the symbol that we want to be immutable, sc->code is the original pair */
      
      sc->x = find_symbol(sc, sc->value);
      if (is_slot(sc->x))
	set_immutable(slot_symbol(sc->x));
      
      /* if we have define-constant of a symbol that is purely local, then reload the file containing that code,
       *   the symbol itself is immutable, but the original local slot has vanished, so we can't compare (below)
       *   against the old value.  Should define-constant always be global?  Otherwise we need to keep track of
       *   exactly where it was defined!
       *
       * but the following code is confusing because the definition leaks out -- not sure what to do here.
       *   perhaps a separate global table of these?  Also, redefinition of a constant local closure won't
       *   work unless we check equality of the functions!
       *
       * another question: (define-constant c (list 1 2 3)) but the list contents are settable
       */
      goto START;
      
      
      /* --------------- */
    case OP_DEFINE_CONSTANT:
      push_stack(sc, OP_DEFINE_CONSTANT1, sc->NIL, sc->code);
      
      
      /* --------------- */
    case OP_DEFINE:
      check_define(sc);
      
      /* --------------- */
    case OP_DEFINE_UNCHECKED:
      if (!is_pair(car(sc->code)))
	{
	  s7_pointer x;
	  x = car(sc->code);
	  sc->code = cadr(sc->code);
	  if (is_pair(sc->code))
	    {
	      push_stack(sc, OP_DEFINE1, sc->NIL, x);
	      goto EVAL; 
	    }
	  
	  if (is_symbol(sc->code))
	    sc->value = SYMBOL_TO_VALUE(sc, sc->code);
	  else sc->value = sc->code;
	  sc->code = x;
	  /* fall through */
	}
      else
	{
	  s7_pointer x;
	  /* 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 fcdr somewhere, and pick it up the next time around (since call/cc might take
	   *   us back to the previous case).
	   */

	  MAKE_CLOSURE(sc, x, cdar(sc->code), cdr(sc->code), sc->envir);
	  if (is_integer(fcdr(sc->code)))
	    closure_arity(x) = integer(fcdr(sc->code));
	  sc->value = x;
	  sc->code = caar(sc->code);
	  /* fall through */
	}
      

      /* --------------- */
    DEFINE1:
    case OP_DEFINE1:
      /* 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...)
       *   so the doc string if any is (cadr (car value))
       *   and the arg list gives the number of optional args up to the dot
       */
      
      /* 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 has a define-constant call.
       */
      if (is_immutable(sc->code))                                        /* (define pi 3) or (define (pi a) a) */
	{
	  s7_pointer x;
	  if (!is_symbol(sc->code))                                      /* (define "pi" 3) ? */
	    eval_error_with_name(sc, "~A: ~S is immutable", sc->code);
	  
	  x = find_symbol(sc, sc->code);
	  if ((!is_slot(x)) ||
	      (!s7_is_equal(sc, sc->value, slot_value(x))))              /* if value is unchanged, just ignore this definition */
	    eval_error_with_name(sc, "~A: ~S is immutable", sc->code);
	}
      if (symbol_has_accessor(sc->code))
	{
	  sc->value = bind_accessed_symbol(sc, OP_DEFINE_WITH_ACCESSOR, sc->code, sc->value);
	  if (sc->value == sc->NO_VALUE)
	    goto APPLY;
	  /* if all goes well, OP_DEFINE_WITH_ACCESSOR will jump to DEFINE2 */
	}
      
    DEFINE2:
      if ((is_closure(sc->value)) || 
	  (is_closure_star(sc->value)))
	{
	  s7_pointer new_func, new_env;
	  new_func = sc->value;

	  /* we can get here from let: (define (outer a) (let () (define (inner b) (+ a b)) (inner a)))
	   *   but the port info is not relevant here, so restrict the __func__ list making to top-level
	   *   cases (via sc->envir == sc->NIL).
	   */

	  NEW_CELL_NO_CHECK(sc, new_env);                   
	  environment_id(new_env) = ++environment_number; 
	  next_environment(new_env) = closure_environment(new_func);
	  closure_environment(new_func) = new_env;		   
	  environment_slots(new_env) = sc->NIL;
	  environment_function(new_env) = sc->code;

	  if ((!is_environment(sc->envir)) &&
	      (port_filename(sc->input_port)) &&
	      (port_file(sc->input_port) != stdin))
	    {
	      /* unbound_variable will be called if __func__ is encountered, and will return this info as if __func__ had some meaning */
	      set_type(new_env, T_ENVIRONMENT | T_IMMUTABLE | T_FUNCTION_ENV | T_LINE_NUMBER); 
	      environment_file(new_env) = port_file_number(sc->input_port);
	      environment_line(new_env) = port_line_number(sc->input_port);
	    }
	  else set_type(new_env, T_ENVIRONMENT | T_IMMUTABLE | T_FUNCTION_ENV); 

	  /* 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.
	   */
	  if (is_safe_closure(new_func))
	    {
	      int i;
	      s7_pointer arg;
	      for (i = 0, arg = closure_args(new_func); is_pair(arg); i++, arg = cdr(arg))
		{
		  if (is_pair(car(arg)))
		    s7_make_slot(sc, new_env, caar(arg), sc->NIL);
		  else s7_make_slot(sc, new_env, car(arg), sc->NIL);
		}
	      environment_slots(new_env) = reverse_slots(sc, environment_slots(new_env));
	      optimize_safe_closure_arg_refs(sc, new_func, i);
	    }
	  /* add the newly defined thing to the current environment */
	  if (is_environment(sc->envir))
	    {
	      ADD_SLOT(sc->envir, sc->code, new_func);
	      set_local(sc->code);
	      /* so funchecked is always local already -- perhaps reset below? */
	    }
	  else s7_make_slot(sc, sc->envir, sc->code, new_func);
	}
      else
	{
	  /* add the newly defined thing to the current environment */
	  sc->x = find_local_symbol(sc, sc->envir, sc->code);
	  if (is_slot(sc->x))
	    slot_set_value(sc->x, sc->value); 
	  else s7_make_slot(sc, sc->envir, sc->code, sc->value);
	}
      sc->value = sc->code;
      IF_BEGIN_POP_STACK(sc);
      
      
      /* --------------- */
    case OP_DEFINE_WITH_ACCESSOR:
      if (sc->value == sc->ERROR) /* backwards compatibility... */
	return(s7_error(sc, sc->ERROR,
			list_3(sc, make_protected_string(sc, "can't define ~S to ~S"), car(sc->args), cadr(sc->args))));
      goto DEFINE2;
      
      
      
      /* -------------------------------- SET! -------------------------------- */
      
    case OP_SET_PAIR_P:
      /* ([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_PAIR_P_1 and complain.
       * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23"
       * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (hi) (hi)) is an error from the first call (caught elsewhere)
       * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (catch #t hi (lambda a a)) (hi)) is an error from the second call
       */
      push_stack_no_args(sc, OP_SET_PAIR_P_1, sc->code);
      sc->code = cadr(sc->code);
      goto EVAL;


    case OP_SET_PAIR_Z:
      push_stack_no_args(sc, OP_SET_PAIR_P_1, sc->code);
      sc->code = cadr(sc->code);
      goto OPT_EVAL;


    case OP_SET_PAIR_A:
      {
	s7_pointer obj, val;
	obj = finder(sc, caar(sc->code));
	val = ((s7_function)fcdr(cdr(sc->code)))(sc, cadr(sc->code)); /* this call can step on sc->Tx_x */
	car(sc->T2_1) = cadar(sc->code);  /* might be a constant: (set! (mus-sound-srate "oboe.snd") 12345) */
	if (is_symbol(car(sc->T2_1)))
	  car(sc->T2_1) = finder(sc, cadar(sc->code));
	car(sc->T2_2) = val;
	sc->value = c_function_call(c_function_setter(obj))(sc, sc->T2_1);
	IF_BEGIN_POP_STACK(sc);
      }


      /* --------------- */
    case OP_SET_PAIR_C_P:
      /* ([set!] (name (+ i 1)) (if (eq? (car a) 'car) #\a #\d)) */
      push_stack_no_args(sc, OP_SET_PAIR_C_P_1, sc->code);
      sc->code = cadr(sc->code);
      goto EVAL;

      {
	s7_pointer obj, arg, value;

	/* --------------- */
      case OP_SET_PAIR_C_P_1:
	/* code: ((name (+ i 1)) ...) for example, so cadar is the c_c expr 
	 *   and its args are cdr(cadar)
	 */
	value = sc->value;
	arg = c_call(cadar(sc->code))(sc, cdadar(sc->code));
	obj = find_symbol(sc, caar(sc->code));
	if (is_slot(obj))
	  obj = slot_value(obj);
	else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	goto SET_PAIR_P_3;
	
	
	/* --------------- */
      case OP_SET_PAIR_C:
	/* ([set!] (name (+ len 1)) #\r) */
	value = cadr(sc->code);
	if (is_symbol(value))
	  value = finder(sc, value);
	arg = c_call(cadar(sc->code))(sc, cdadar(sc->code));
	obj = find_symbol(sc, caar(sc->code));
	if (is_slot(obj))
	  obj = slot_value(obj);
	else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	goto SET_PAIR_P_3;
	
	
	/* ---------------- */
      case OP_SET_ENV_S:
	value = finder(sc, cadr(sc->code));
	obj = find_symbol(sc, caar(sc->code));
	if (is_slot(obj))
	  obj = slot_value(obj);
	else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	arg = cadr(cadar(sc->code));
	if (is_environment(obj))
	  {
	    sc->value = s7_environment_set(sc, obj, arg, value);
	    IF_BEGIN_POP_STACK(sc); 
	  }
	goto SET_PAIR_P_3;


	/* ---------------- */
      case OP_SET_ENV_ALL_X:
	value = ((s7_function)fcdr(cdr(sc->code)))(sc, cadr(sc->code));
	obj = find_symbol(sc, caar(sc->code));
	if (is_slot(obj))
	  obj = slot_value(obj);
	else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	arg = cadr(cadar(sc->code));
	if (is_environment(obj))
	  {
	    sc->value = s7_environment_set(sc, obj, arg, value);
	    IF_BEGIN_POP_STACK(sc); 
	  }
	goto SET_PAIR_P_3;


	/* --------------- */
      case OP_SET_PAIR_P_1:
	/* car(sc->code) is a pair, caar(code) is the object with a setter, it has one (safe) argument, and one safe value to set
	 *   (set! (str i) #\a) in a function (both inner things need to be symbols (or the 2nd can be a quoted symbol) to get here)
	 *   the inner list is a proper list, with no embedded list at car.
	 */
	value = sc->value;
	
	arg = cadar(sc->code);
	if (is_symbol(arg))
	  arg = finder(sc, arg);
	else
	  {
	    if (is_pair(arg))
	      arg = cadr(arg); /* can only be (quote ...) in this case */
	  }
	obj = find_symbol(sc, caar(sc->code));
	if (is_slot(obj))
	  obj = slot_value(obj);
	else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	goto SET_PAIR_P_3;
	
	

	/* --------------- */
      case OP_SET_PAIR:
	/* ([set!] (procedure-setter g) s) or ([set!] (str 0) #\a) */
	value = cadr(sc->code);
	if (is_symbol(value))
	  value = finder(sc, value);
	
	arg = cadar(sc->code);
	if (is_symbol(arg)) 
	  arg = finder(sc, arg);
	else
	  {
	    if (is_pair(arg))
	      arg = cadr(arg); /* can only be (quote ...) in this case */
	  }

	obj = caar(sc->code);
	if (is_symbol(obj))
	  {
	    obj = find_symbol(sc, obj);
	    if (is_slot(obj))
	      obj = slot_value(obj);
	    else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	  }
	
	
      SET_PAIR_P_3:
	switch (type(obj))
	  {
	  case T_C_OBJECT:
	    {
	      s7_pointer (*set_3)(s7_scheme *sc, void *val, s7_pointer index, s7_pointer value);

	      if ((c_object_has_array(obj)) &&
		  (is_integer(arg)) &&
		  (integer(arg) >= 0) &&
		  (type(value) == T_REAL) &&
		  (integer(arg) < c_object_array_length(obj)))
		{
		  c_object_array(obj)[integer(arg)] = real(value);
		  sc->value = value;
		}
	      else
		{
		  set_3 = c_object_set_3(obj);
		  if (set_3)
		    sc->value = (*(set_3))(sc, c_object_value(obj), arg, value);
		  else
		    {
		      car(sc->T2_1) = arg;
		      car(sc->T2_2) = value;
		      sc->value = (*(c_object_set(obj)))(sc, obj, sc->T2_1);
		    }
		}
	    }
	    break;
	    
	    /* some of these are wasteful -- we know the object type! (list hash-table)
	     */
	  case T_INT_VECTOR:
	  case T_FLOAT_VECTOR:
	  case T_VECTOR:
#if WITH_GMP
	    car(sc->T3_1) = obj;
	    car(sc->T3_2) = arg;
	    car(sc->T3_3) = value;
	    sc->value = g_vector_set(sc, sc->T3_1);
#else
	    if (vector_is_multidimensional(obj))
	      {
		car(sc->T3_1) = obj;
		car(sc->T3_2) = arg;
		car(sc->T3_3) = value;
		sc->value = g_vector_set(sc, sc->T3_1);
	      }
	    else
	      {
		s7_Int index;
		if (!is_integer(arg))
		  eval_error(sc, "vector-set!: index must be an integer: ~S", sc->code);
		index = integer(arg);
		if (index < 0)
		  eval_error(sc, "vector-set!: index must not be negative: ~S", sc->code);
		if (index >= vector_length(obj))
		  eval_error(sc, "vector-set!: index must not be less than vector length: ~S", sc->code);
		vector_setter(obj)(sc, obj, index, value);
		sc->value = value;
	      }
#endif
	    break;
	    
	  case T_STRING:
#if WITH_GMP
	    car(sc->T3_1) = obj;
	    car(sc->T3_2) = arg;
	    car(sc->T3_3) = value;
	    sc->value = g_string_set(sc, sc->T3_1);
#else
	    {
	      s7_Int index;
	      if (!is_integer(arg))
		eval_error(sc, "string-set!: index must be an integer: ~S", sc->code);
	      index = integer(arg);
	      if (index < 0)
		eval_error(sc, "string-set!: index must not be negative: ~S", sc->code);
	      if (index >= string_length(obj))
		eval_error(sc, "string-set!: index must not be less than string length: ~S", sc->code);
	      if (s7_is_character(value))
		{
		  string_value(obj)[index] = (char)s7_character(value);
		  sc->value = value;
		}
	      else
		{
		  if ((is_bytevector(obj)) &&
		      (s7_is_integer(value)))
		    {
		      int ic;
		      ic = s7_integer(value);
		      if ((ic < 0) || (ic > 255))
			eval_error(sc, "string-set!: value must be a character: ~S", sc->code);
		      string_value(obj)[index] = (char)ic;
		      sc->value = value;
		    }
		  else eval_error(sc, "string-set!: value must be a character: ~S", sc->code);
		}
	    }
#endif
	    break;
	    
	  case T_PAIR:
	    car(sc->T3_1) = obj;
	    car(sc->T3_2) = arg;
	    car(sc->T3_3) = value;
	    sc->value = g_list_set(sc, sc->T3_1);
	    break;
	    
	  case T_HASH_TABLE:
	    car(sc->T3_1) = obj;
	    car(sc->T3_2) = arg;
	    car(sc->T3_3) = value;
	    sc->value = g_hash_table_set(sc, sc->T3_1);
	    break;
	    
	  case T_ENVIRONMENT:
	    /* (set! (env sym) val) */
	    sc->value = s7_environment_set(sc, obj, arg, value);
	    break;
	    
	  case T_C_OPT_ARGS_FUNCTION:
	  case T_C_RST_ARGS_FUNCTION:
	  case T_C_ANY_ARGS_FUNCTION:                       /* (let ((lst (list 1 2))) (set! (list-ref lst 1) 2) lst) */
	  case T_C_FUNCTION:
	    /* obj here is a c_function, but its setter could be a closure and vice versa below
	     */
	    if (is_procedure(c_function_setter(obj)))
	      {
		if (is_c_function(c_function_setter(obj)))
		  {
		    car(sc->T2_1) = arg;
		    car(sc->T2_2) = value;
		    sc->value = c_function_call(c_function_setter(obj))(sc, sc->T2_1);
		  }
		else
		  {
		    sc->code = c_function_setter(obj);
		    sc->args = list_2(sc, arg, value);
		    goto APPLY;
		  }
	      }
	    else
	      {
		if (is_any_macro(c_function_setter(obj)))
		  {
		    push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
		    if (is_null(cdar(sc->code)))
		      sc->args = list_1(sc, cons(sc, c_function_setter(obj), cdr(sc->code)));
		    else sc->args = list_1(sc, cons(sc, c_function_setter(obj), s7_append(sc, cdar(sc->code), cdr(sc->code))));
		    sc->code = c_function_setter(obj);
		    goto APPLY;
		  }
		else eval_error(sc, "no generalized set for ~A", obj); 
	      }
	    break;
	    
	  case T_MACRO:
	  case T_BACRO:
	  case T_CLOSURE:
	  case T_CLOSURE_STAR:
	    if (is_procedure(closure_setter(obj)))
	      {
		if (is_c_function(closure_setter(obj)))
		  {
		    car(sc->T2_1) = arg;
		    car(sc->T2_2) = value;
		    sc->value = c_function_call(closure_setter(obj))(sc, sc->T2_1);
		  }
		else
		  {
		    sc->code = closure_setter(obj);
		    sc->args = list_2(sc, arg, value);
		    goto APPLY;
		  }
	      }
	    else
	      {
		if (is_any_macro(closure_setter(obj)))
		  {
		    push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
		    if (is_null(cdar(sc->code)))
		      sc->args = list_1(sc, cons(sc, closure_setter(obj), cdr(sc->code)));
		    else sc->args = list_1(sc, cons(sc, closure_setter(obj), s7_append(sc, cdar(sc->code), cdr(sc->code))));
		    sc->code = closure_setter(obj);
		    goto APPLY;
		  }
		else eval_error(sc, "no generalized set for ~A", obj); 
	      }
	    break;
	    
	  default:                                         /* (set! (1 2) 3) */
	    eval_error(sc, "no generalized set for ~A", obj);
	  }
	IF_BEGIN_POP_STACK(sc); 
      }
      

      /* --------------- */
      /* this is (set! (getter) val) where getter is a global c_function (a built-in pws) and val is not a pair
       */
    case OP_SET_PWS:
      {
	/* ([set!] (save-dir) "/home/bil/zap/snd") */
	s7_pointer obj;
	
	obj = caar(sc->code);
	if (is_symbol(obj))
	  {
	    obj = find_symbol(sc, obj);
	    if (is_slot(obj))
	      obj = slot_value(obj);
	    else eval_error(sc, "no generalized set for ~A", caar(sc->code));
	  }
	
	if ((is_c_function(obj)) &&
	    (is_procedure(c_function_setter(obj))))
	  {
	    s7_pointer value;
	    value = cadr(sc->code);
	    if (is_symbol(value))
	      value = finder(sc, value);
	    
	    car(sc->T1_1) = value;
	    sc->value = c_function_call(c_function_setter(obj))(sc, sc->T1_1);
	  }
	else eval_error(sc, "no generalized set for ~A", obj); 
	IF_BEGIN_POP_STACK(sc);
      }
      
      
      /* --------------- */
    case OP_INCREMENT_1:
      {
	/* ([set!] ctr (+ ctr 1)) */
	s7_pointer y;
	y = find_symbol(sc, car(sc->code));
	if (is_slot(y))
	  {
	    s7_pointer val;	    
	    val = slot_value(y);
	    switch (type(val))
	      {
	      case T_INTEGER:
		slot_set_value(y, make_integer(sc, integer(val) + 1));
		/* this can't be optimized to treat y's value as a mutable integer 
		 * also, we have to set sc->value, since s7.html says set! returns the value.
		 */
		IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, y);
		
	      case T_REAL:
		sc->value = make_real(sc, real(val) + 1.0);
		slot_set_value(y, sc->value);
		goto START;
		
	      default:
		break;
	      }
	  }
	/* else use standard set */
	push_stack_no_args(sc, OP_SET_SAFE, car(sc->code));
	sc->code = cadr(sc->code);
	goto EVAL; 
      }

      
      /* --------------- */
    case OP_DECREMENT_1:
      {
	/* ([set!] ctr (- ctr 1)) */
	s7_pointer y;
	y = find_symbol(sc, car(sc->code));
	if (is_slot(y))
	  {
	    s7_pointer val;	    
	    val = slot_value(y);
	    switch (type(val))
	      {
	      case T_INTEGER:
		sc->value = make_integer(sc, integer(val) - 1);
		slot_set_value(y, sc->value);
		goto START;
		
	      case T_REAL:
		sc->value = make_real(sc, real(val) - 1.0);
		slot_set_value(y, sc->value);
		goto START;
		
	      default:
		break;
	      }
	  }
	push_stack_no_args(sc, OP_SET_SAFE, car(sc->code)); 
	sc->code = cadr(sc->code);
	goto EVAL; 
      }

      
      /* --------------- */
    case OP_SET_CDR:
      {
	/* ([set!] nvals (cdr nvals)) */
	s7_pointer y;
	y = find_symbol(sc, car(sc->code));
	if (is_slot(y))
	  {
	    s7_pointer val;	    
	    val = slot_value(y);
	    if (!is_pair(val))
	      sc->value = g_cdr(sc, list_1(sc, val));   /* possible method? */
	    else sc->value = cdr(val);                  /* set! returns the value */
	    slot_set_value(y, sc->value);
	    IF_BEGIN_POP_STACK(sc);
	  }
	push_stack_no_args(sc, OP_SET_SAFE, car(sc->code)); 
	sc->code = cadr(sc->code);
	goto EVAL; 
      }

      
      /* --------------- */
    case OP_SET_CONS:
      /* it's safe if hop_safe_c_ss, so if op_safe_c_ss we check? */
      /* ([set!] bindings (cons v bindings)) */
      {
	s7_pointer y;
	y = find_symbol(sc, car(sc->code)); 
	if (is_slot(y))
	  {
	    sc->value = cons(sc, finder(sc, fcdr(sc->code)), slot_value(y));
	    slot_set_value(y, sc->value);
	    goto START;
	  }
	push_stack_no_args(sc, OP_SET2, car(sc->code)); 
	sc->code = cadr(sc->code);
	goto EVAL; 
      }


      /* --------------- */
    case OP_SET_SYMBOL_SAFE_C:
      /* ([set!] ctr (- ctr 11)) */
      sc->y = find_symbol(sc, car(sc->code));
      if (is_slot(sc->y)) 
	{
	  slot_set_value(sc->y, c_call(cadr(sc->code))(sc, fcdr(sc->code)));
	  IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sc->y); 
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);


    case OP_INCREMENT_C_TEMP:
      {
	s7_pointer sym, arg1, arg2, code;
	code = sc->code;
	sym = find_symbol(sc, car(code));
	if (is_slot(sym)) 
	  {
	    arg2 = c_call(fcdr(code))(sc, cdr(fcdr(code)));
	    arg1 = slot_value(sym);
	    if (is_simple_real(arg1))
	      sc->value = s7_remake_real(sc, arg2, real(arg1) + real(arg2));
	    else sc->value = g_a_s_t(sc, arg1, arg2, fcdr(code));
	    slot_set_value(sym, sc->value);
	    goto START; /* almost never op_begin1 here */
	  }
      }
      eval_error(sc, "set! ~A: unbound variable", sc->code);
      


      /* --------------- */
    case OP_SET_SYMBOL_SAFE_opSSq_S:
      {
	s7_pointer val, arg, inner, sym;
	sym = car(sc->code);
	arg = cadr(sc->code);
	inner = cadr(arg);
	val = finder(sc, cadr(inner));
	car(sc->T2_2) = finder(sc, caddr(inner));
	car(sc->T2_1) = val;
	val = c_call(inner)(sc, sc->T2_1);
	car(sc->T2_2) = finder(sc, caddr(arg));
	car(sc->T2_1) = val;
	sc->value = c_call(arg)(sc, sc->T2_1);
	sc->code = sym;
	goto SET_SAFE;
      }


      /* --------------- */
    case OP_SET_SYMBOL_SAFE_SS:
      {
	s7_pointer sym, code;
	code = sc->code;
	sym = find_symbol(sc, car(code));
	if (is_slot(sym))
	  {
	    car(sc->T2_1) = finder(sc, car(fcdr(code)));
	    car(sc->T2_2) = finder(sc, cadr(fcdr(code)));
	    slot_set_value(sym, c_call(cadr(code))(sc, sc->T2_1));
	    IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sym); 
	  }
      }
      eval_error(sc, "set! ~A: unbound variable", sc->code);


    case OP_INCREMENT_SS:
      /* ([set!] x (+ x i)) */
      sc->y = find_symbol(sc, car(sc->code));
      if (is_slot(sc->y)) 
	{
	  car(sc->T2_1) = slot_value(sc->y);
	  car(sc->T2_2) = finder(sc, cadr(fcdr(sc->code)));
	  slot_set_value(sc->y, c_call(cadr(sc->code))(sc, sc->T2_1));
	  IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sc->y);
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);


    case OP_INCREMENT_SSS:
      /* ([set!] x (+ x y z)) -- nearly always involves reals */
      sc->y = find_symbol(sc, car(sc->code));
      if (is_slot(sc->y))
	{
	  s7_pointer x1, x2, x3;
	  x1 = slot_value(sc->y);
	  x2 = finder(sc, ecdr(fcdr(sc->code)));
	  x3 = finder(sc, fcdr(fcdr(sc->code)));
	  if ((type(x1) == T_REAL) &&
	      (type(x2) == T_REAL) &&
	      (type(x3) == T_REAL))
	    slot_set_value(sc->y, make_real(sc, real(x1) + real(x2) + real(x3)));
	  else
	    {
	      car(sc->T3_1) = x1;
	      car(sc->T3_2) = x2;
	      car(sc->T3_3) = x3;
	      slot_set_value(sc->y, g_add(sc, sc->T3_1));
	    }
	  IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sc->y);
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);


      /* --------------- */
    case OP_SET_SYMBOL_SAFE_SSS:
      {
	s7_pointer sym, code;
	code = sc->code;
	sym = find_symbol(sc, car(code));
	if (is_slot(sym))
	  {
	    car(sc->T3_1) = finder(sc, car(fcdr(code))); /* checking car=car(fcdr) here is slightly slower */
	    car(sc->T3_2) = finder(sc, ecdr(fcdr(code))); 
	    car(sc->T3_3) = finder(sc, fcdr(fcdr(code)));
	    slot_set_value(sym, c_call(cadr(code))(sc, sc->T3_1));
	    IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sym); 
	  }
	eval_error(sc, "set! ~A: unbound variable", sc->code);
      }


      /* --------------- */
    case OP_SET_SYMBOL_SAFE_S:
      {
	s7_pointer sym;
	sym = car(sc->code);
	car(sc->T1_1) = finder(sc, fcdr(sc->code));
	sc->value = c_call(cadr(sc->code))(sc, sc->T1_1);
	/*
	 * I think this is supposed to be a safe c function (is_h_safe_c_s above), but
	 *   it's possible for the call to change sc->code?  
	 *   in snd-test: 
	 *           (set! snd-output (open-sound output-1)) 
	 *   becomes (set! (hook-functions *error-hook*) '())
	 *   because open-sound is calling itself safe, but it can call all kinds of hooks and whatnot,
	 *   and these can hit errors, setting *error-hook*, fallling into s7_call and so on.
	 */
	sc->code = sym;
	/* goto SET_SAFE; */
      }


      /* --------------- */
    SET_SAFE:
    case OP_SET_SAFE:  
      sc->y = find_symbol(sc, sc->code);
      if (is_slot(sc->y)) 
	{
	  slot_set_value(sc->y, sc->value); 
	  IF_BEGIN_POP_STACK(sc); 
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);

      
      /* --------------- */
    case OP_SET_SYMBOL_C:
      /* ([set!] x 3) */
      sc->value = cadr(sc->code);
      sc->code = car(sc->code);
      goto SET_SAFE;
      

      /* --------------- */
    case OP_SET_SYMBOL_Q:
      /* ([set!] incr '+) */
      sc->value = cadr(cadr(sc->code));
      sc->code = car(sc->code);
      goto SET_SAFE;
      

      /* --------------- */
    case OP_SET_SYMBOL_P:
      /* ([set!] f (lambda () 1)) */
      push_stack_no_args(sc, OP_SET_SAFE, car(sc->code)); 
      sc->code = cadr(sc->code);
      goto EVAL; 
      /* possible optimization: if types match, and "P" part is direct, we could
       *   just set the current slot, and free the direct value.
       */
      

      /* --------------- */
    case OP_SET_SYMBOL_Z:
      /* ([set!] sum (+ sum n)) */
      push_stack_no_args(sc, OP_SET_SAFE, car(sc->code)); 
      sc->code = cadr(sc->code);
      goto OPT_EVAL;


      /* --------------- */
    case OP_SET_SYMBOL_ALL_X:
      sc->y = find_symbol(sc, car(sc->code));
      if (is_slot(sc->y)) 
	{
	  slot_set_value(sc->y, ((s7_function)fcdr(cdr(sc->code)))(sc, cadr(sc->code)));
	  IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sc->y); 
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);


      /* --------------- */
    case OP_INCREMENT_S_opCq:
      {
	s7_pointer sym;
	sym = find_symbol(sc, car(sc->code));
	if (is_slot(sym))
	  {
	    s7_pointer args;
	    args = fcdr(sc->code); /* cdadr(sc->code); */
	    car(sc->T2_2) = c_call(cadr(args))(sc, ecdr(args));
	    car(sc->T2_1) = slot_value(sym);
	    sc->value = c_call(cadr(sc->code))(sc, sc->T2_1);
	    slot_set_value(sym, sc->value);
	    goto START; 
	  }
      }
      eval_error(sc, "set! ~A: unbound variable", sc->code);

      
    case OP_INCREMENT_SZ:
      {
	s7_pointer sym;
	sym = find_symbol(sc, car(sc->code));
	if (is_slot(sym))
	  {
	    push_stack(sc, OP_INCREMENT_SZ_1, sym, sc->code);
	    sc->code = fcdr(sc->code); /* caddr(cadr(sc->code)); */
	    goto OPT_EVAL;
	  }
	eval_error(sc, "set! ~A: unbound variable", sc->code);
      }

    case OP_INCREMENT_SZ_1:
      car(sc->T2_1) = slot_value(sc->args);
      car(sc->T2_2) = sc->value;
      sc->value = c_call(cadr(sc->code))(sc, sc->T2_1);
      slot_set_value(sc->args, sc->value);
      goto START;
      


      /* --------------- */
    case OP_SET_SYMBOL_S:
      {
	s7_pointer sym;
	sym = find_symbol(sc, car(sc->code));
	if (is_slot(sym))
	  {
	    slot_set_value(sym, finder(sc, cadr(sc->code)));
	    IF_BEGIN_POP_STACK_ELSE_SET_VALUE(sc, sym);
	  }
	eval_error(sc, "set! ~A: unbound variable", sc->code);
      }
      

      /* --------------- */
    case OP_SET2:
      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 (!is_proper_list(sc, sc->args))                                 /* (set! ('(1 2) 1 . 2) 1) */
	    eval_error(sc, "set! target arguments are an improper list: ~A", sc->args);
	  
	  /* in all of these cases, we might need to GC protect the temporary lists */
	  
	  if (is_multiple_value(sc->value))
	    sc->code = cons(sc, sc->SET, s7_append(sc, multiple_value(sc->value), s7_append(sc, sc->args, sc->code))); /* drop into OP_SET */
	  else
	    {
	      if (sc->args != sc->NIL)
		{
		  push_op_stack(sc, sc->List_Set);
		  push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code));
		  sc->code = car(sc->args);
		}
	      else eval_error(sc, "list set!: not enough arguments: ~S", sc->code);
	      goto EVAL;
	    }
	  /* timings: old 3.25, new 2.34 (1.93 direct), (12.2): 1.34
	   *    (time (let ((L '((1 2 3)))) (do ((i 0 (+ i 1))) ((= i 10000000)) (set! ((L 0) 1) i)) L))
	   */
	}
      else
	{
	  if (s7_is_vector(sc->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)
		{
		  push_op_stack(sc, sc->Vector_Set);
		  push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code));
		  sc->code = car(sc->args);
		}
	      else eval_error(sc, "vector set!: not enough arguments: ~S", sc->code);
	      goto EVAL;
	    }
	  sc->code = cons_unchecked(sc, cons(sc, sc->value, sc->args), sc->code);
	}
      /* fall through */
      
      
      /* --------------- */
    case OP_SET:                                                             /* entry for set! */
      check_set(sc);
      
      /* --------------- */
    case OP_SET_UNCHECKED:
      if (is_pair(car(sc->code)))                                            /* has accessor */
	{
	  s7_pointer caar_code;
	  caar_code = caar(sc->code);
	  if (is_pair(caar_code))
	    {
	      push_stack(sc, OP_SET2, cdar(sc->code), cdr(sc->code));
	      sc->code = caar_code;
	      goto EVAL; 
	    }
	  
	  if (is_symbol(caar_code))
	    {
	      /* this was sc->x = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */
	      sc->x = find_symbol(sc, caar_code);
	      if (is_slot(sc->x))
		sc->x = slot_value(sc->x);
	      else eval_error(sc, "no generalized set for ~A", caar_code);
	    }
	  else sc->x = caar_code;
	  
	  /* code here is the accessor and the value without the "set!": ((window-width) 800) */
	  /*    (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */
	  
	  /* for these kinds of objects, some Schemes restrict set!
	   * (list-set! '(1 2 3) 1 32) is accepted but does it make sense?
	   * (set-car! '(1 . 2) 32)
	   * (string-set! "hiho" 1 #\z)
	   * (vector-set! #(1 2 3) 1 32)
	   * (let ((x (lambda () "hiho"))) (string-set! (x) 1 #\a))
	   * (let ((x (lambda () #(1 2 3)))) (vector-set! (x) 1 32))
	   * (let ((str "hiho")) (string-set! str 1 #\x) str)
	   * (let ((v #(1 2 3))) (vector-set! v 1 32) v)
	   * (let ((x (lambda () "hiho"))) (string-set! (x) 1 #\x) (x))
	   *
	   *   It seems weird that we can reach into both the function body, and its closure:
	   *   (let ((xx (let ((x '(1 2 3))) (lambda () x)))) (list-set! (xx) 1 32) (xx)) -> '(1 32 3)
	   *
	   * (let* ((x '(1 2)) (y (list x)) (z (car y))) (list-set! z 1 32) (list x y z))
	   * ((1 32) ((1 32)) (1 32))
	   *
	   * (string-set! (symbol->string 'symbol->string) 1 #\X) -> error currently also in Guile "string is read-only"
	   * (setf (elt (symbol-name 'xyz) 1) #\X) -> error in CL "read-only string"
	   */
	  /* for gmp case, indices need to be decoded via s7_integer, not just integer */

	  switch (type(sc->x))
	    {
	    case T_C_OBJECT:
	      {
		s7_pointer settee, index, val;
		
		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for object-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for object-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if ((is_null(cdr(settee))) ||
		    (!is_null(cddr(settee))))
		  {
		    /* no-index or multi-index case -- use slow version */
		    push_op_stack(sc, sc->Object_Set);
		    if (is_null(cdr(settee)))
		      {
			push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cddr(sc->code));
			sc->code = cadr(sc->code);
		      }
		    else
		      {
			push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), s7_append(sc, cddr(settee), cdr(sc->code)));
			sc->code = cadr(settee);
		      }
		    goto EVAL;
		  }

		index = cadr(settee);
		if (!is_pair(index))
		  {
		    if (is_symbol(index))
		      index = finder(sc, index);

		    val = cadr(sc->code);
		    if (!is_pair(val))
		      {
			s7_pointer (*set_3)(s7_scheme *sc, void *val, s7_pointer index, s7_pointer value);
			s7_pointer obj;
			obj = sc->x;

			if (is_symbol(val))
			  val = finder(sc, val);

			if ((c_object_has_array(obj)) &&
			    (is_integer(index)) &&
			    (integer(index) >= 0) &&
			    (type(val) == T_REAL) &&
			    (integer(index) < c_object_array_length(obj)))
			  {
			    c_object_array(obj)[integer(index)] = real(val);
			    sc->value = val;
			    goto START;
			  }

			set_3 = c_object_set_3(sc->x);
			if (set_3)
			  sc->value = (*(set_3))(sc, c_object_value(sc->x), index, val);
			else
			  {
			    car(sc->T2_1) = index;
			    car(sc->T2_2) = val;
			    sc->value = (*(c_object_set(sc->x)))(sc, sc->x, sc->T2_1);
			  }
			goto START;
		      }
		    if ((c_object_has_array(sc->x)) ||
			(c_object_set_3(sc->x)))
			push_op_stack(sc, sc->Object_Set_3); /* calls to g_internal_object_set_3 */
		    else push_op_stack(sc, sc->Object_Set);
		    sc->args = list_2(sc, index, sc->x);
		    sc->code = cdr(sc->code);
		    goto EVAL_ARGS;
		  }
		else
		  {
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cdr(sc->code));
		    if ((c_object_has_array(sc->x)) ||
			(c_object_set_3(sc->x)))
		      push_op_stack(sc, sc->Object_Set_3);
		    else push_op_stack(sc, sc->Object_Set);
		    sc->code = cadr(settee);
		  }
		goto EVAL;
	      }
	      break;
	      
	    case T_INT_VECTOR:
	    case T_FLOAT_VECTOR:
	    case T_VECTOR:
	      {
		/* sc->x is the vector, sc->code is expr without the set! */
		/*  args have not been evaluated! */

		s7_pointer settee, index, val;
		
		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for vector-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for vector-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if (is_null(cdr(settee)))
		  s7_wrong_number_of_args_error(sc, "no index for vector-set!: ~S", sc->code);
		if ((!is_null(cddr(settee))) ||
		    (vector_is_multidimensional(sc->x)))
		  {
		    /* multi-index case -- use slow version */
		    push_op_stack(sc, sc->Vector_Set);
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), s7_append(sc, cddr(settee), cdr(sc->code)));
		    sc->code = cadr(settee);
		    goto EVAL;
		  }

		index = cadr(settee);
		if (!is_pair(index))
		  {
		    s7_Int ind;
		    
		    if (is_symbol(index))
		      index = finder(sc, index);
		    if (!s7_is_integer(index))
		      eval_error(sc, "vector-set!: index must be an integer: ~S", sc->code);
		    ind = s7_integer(index);
		    if ((ind < 0) ||
			(ind >= vector_length(sc->x)))
		      out_of_range(sc, sc->VECTOR_SET, small_int(2), index, "should be between 0 and the vector length");
		    val = cadr(sc->code);
		    if (!is_pair(val))
		      {
			if (is_symbol(val))
			  val = finder(sc, val);
			vector_setter(sc->x)(sc, sc->x, ind, val);
			sc->value = val;
			goto START;
		      }
		    push_op_stack(sc, sc->Vector_Set);
		    sc->args = list_2(sc, index, sc->x);
		    sc->code = cdr(sc->code);
		    goto EVAL_ARGS;
		  }
		else
		  {
		    /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens
		     */
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cdr(sc->code));
		    push_op_stack(sc, sc->Vector_Set);
		    sc->code = cadr(settee);
		  }
	      }
	      break;
	      
	    case T_STRING:
	      {
		/* sc->code = cons(sc, sc->String_Set, s7_append(sc, car(sc->code), cdr(sc->code))); 
		 *
		 * 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 settee, index, val;
		
		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for string-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for string-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if (is_null(cdr(settee))) /* there's an index: (set! (str i) #\a), code is ((str 0) #\1) */
		  s7_wrong_number_of_args_error(sc, "no index for string-set!: ~S", sc->code);
		if (!is_null(cddr(settee)))
		  s7_wrong_number_of_args_error(sc, "too many indices for string-set!: ~S", sc->code);
		
		/* if there's one index (the standard case), and it is not a pair, and there's one value (also standard)
		 *    and it is not a pair, let's optimize this thing!
		 *    sc->x is what we're setting, cadar is the index, cadr is the new value
		 */
		index = cadr(settee);
		if (!is_pair(index))
		  {
		    s7_Int ind;
		    
		    if (is_symbol(index))
		      index = finder(sc, index);
		    if (!s7_is_integer(index))
		      eval_error(sc, "string-set!: index must be an integer: ~S", sc->code);
		    ind = s7_integer(index);
		    if ((ind < 0) ||
			(ind >= string_length(sc->x)))
		      out_of_range(sc, sc->STRING_SET, small_int(2), index, "should be between 0 and the string length");
		    
		    val = cadr(sc->code);
		    if (!is_pair(val))
		      {
			if (is_symbol(val))
			  val = finder(sc, val);
			if (s7_is_character(val))
			  {
			    string_value(sc->x)[ind] = character(val);
			    sc->value = val;
			    goto START;
			  }
			else
			  {
			    if ((is_bytevector(sc->x)) &&
				(s7_is_integer(val)))
			      {
				int ic;
				ic = s7_integer(val);
				if ((ic < 0) || (ic > 255))
				  eval_error(sc, "string-set!: value must be a character: ~S", sc->code);
				string_value(sc->x)[ind] = (char)ic;
				sc->value = val;
				goto START;
			      }
			  }
			eval_error(sc, "string-set!: value must be a character: ~S", sc->code);
		      }
		    push_op_stack(sc, sc->String_Set);
		    sc->args = list_2(sc, index, sc->x);
		    sc->code = cdr(sc->code);
		    goto EVAL_ARGS;
		  }
		else
		  {
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cdr(sc->code));
		    push_op_stack(sc, sc->String_Set);
		    sc->code = cadar(sc->code);
		  }
	      }
	      break;
	      
	    case T_PAIR:
	      /* code: ((lst 1) 32) from (let ((lst '(1 2 3))) (set! (lst 1) 32))
	       * old form:
	       *    sc->code = cons(sc, sc->List_Set, s7_append(sc, car(sc->code), cdr(sc->code))); 
	       *    old: 2.32, new: 1.77 (1.50 direct), (12.2): 1.07
	       *    (time (let ((lst '(1 2 3))) (do ((i 0 (+ i 1))) ((= i 10000000)) (set! (lst 1) 32))))
	       */
	      {
		s7_pointer settee, index, val;
		
		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for list-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for list-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if (is_null(cdr(settee)))
		  s7_wrong_number_of_args_error(sc, "no index for list-set!: ~S", sc->code);

		index = cadr(settee);
		val = cadr(sc->code);

		if ((!is_null(cddr(settee))) ||
		    (is_pair(index)) ||
		    (is_pair(val)))
		  {
		    push_op_stack(sc, sc->List_Set);
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), s7_append(sc, cddr(settee), cdr(sc->code)));
		    sc->code = index;
		    goto EVAL;
		  }

		if (is_symbol(index))
		  index = finder(sc, index);
		if (is_symbol(val))
		  val = finder(sc, val);

		car(sc->T2_1) = index;
		car(sc->T2_2) = val;
		sc->value = g_list_set_1(sc, sc->x, sc->T2_1, 2);
		goto START;
	      }
	      break;

	      
	    case T_HASH_TABLE:
	      {
		s7_pointer settee, key, val;
		
		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for hash-table-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for hash-table-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if (is_null(cdr(settee)))
		  s7_wrong_number_of_args_error(sc, "no key for hash-table-set!: ~S", sc->code);
		if (!is_null(cddr(settee)))
		  s7_wrong_number_of_args_error(sc, "too many keys for hash-table-set!: ~S", sc->code);
		
		key = cadr(settee);
		if (!is_pair(key))
		  {
		    if (is_symbol(key))
		      key = finder(sc, key);
		    val = cadr(sc->code);
		    if (!is_pair(val))
		      {
			if (is_symbol(val))
			  val = finder(sc, val);
			sc->value = s7_hash_table_set(sc, sc->x, key, val);
			goto START;
		      }
		    push_op_stack(sc, sc->Hash_Table_Set);
		    sc->args = list_2(sc, key, sc->x);
		    sc->code = cdr(sc->code);
		    goto EVAL_ARGS;
		  }
		else
		  {
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cdr(sc->code));
		    push_op_stack(sc, sc->Hash_Table_Set);
		    sc->code = cadar(sc->code);
		  }
	      }
	      break;
	      
	      
	    case T_ENVIRONMENT:
	      /* sc->code = cons(sc, sc->Environment_Set, s7_append(sc, car(sc->code), cdr(sc->code))); */
	      {
		s7_pointer settee, key, val;
		/* code: ((gen 'input) input) from (set! (gen 'input) input)
		 */

		if (is_null(cdr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "no value for environment-set!: ~S", sc->code);
		if (!is_null(cddr(sc->code)))
		  s7_wrong_number_of_args_error(sc, "too many values for environment-set!: ~S", sc->code);
		
		settee = car(sc->code);
		if (is_null(cdr(settee)))
		  s7_wrong_number_of_args_error(sc, "no identifier for environment-set!: ~S", sc->code);
		if (!is_null(cddr(settee)))
		  s7_wrong_number_of_args_error(sc, "too many identifiers for environment-set!: ~S", sc->code);
		
		key = cadr(settee);
		if ((is_pair(key)) &&
		    (car(key) == sc->QUOTE))
		  {
		    key = cadr(key);
		    val = cadr(sc->code);
		    if (!is_pair(val))
		      {
			if (is_symbol(val))
			  val = finder(sc, val);
			sc->value = s7_environment_set(sc, sc->x, key, val);
			goto START;
		      }
		    push_op_stack(sc, sc->Environment_Set);
		    sc->args = list_2(sc, key, sc->x);
		    sc->code = cdr(sc->code);
		    goto EVAL_ARGS;
		  }
		else
		  {
		    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->x), cdr(sc->code));
		    push_op_stack(sc, sc->Environment_Set);
		    sc->code = cadar(sc->code);
		  }
	      }
	      break;
	      
	      
	    case T_C_MACRO:
	    case T_C_OPT_ARGS_FUNCTION:
	    case T_C_RST_ARGS_FUNCTION:
	    case T_C_ANY_ARGS_FUNCTION:                       /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */
	    case T_C_FUNCTION:
	      /* perhaps it has a setter */
	      /* the only T_C_LST_ARGS function is internal: {list}, so it doesn't need a setter */
	      
	      if (is_procedure(c_function_setter(sc->x)))
		{
		  /* sc->code = cons(sc, c_function_setter(sc->x), s7_append(sc, cdar(sc->code), cdr(sc->code))); */
		  if (is_pair(cdar(sc->code)))
		    {
		      if ((is_symbol(cadr(sc->code))) &&
			  (is_symbol(cadar(sc->code))))
			{
			  if (is_null(cddar(sc->code)))
			    {
			      car(sc->T2_1) = finder(sc, cadar(sc->code));
			      car(sc->T2_2) = finder(sc, cadr(sc->code));
			      sc->args = sc->T2_1;
			      sc->code = c_function_setter(sc->x);
			      goto APPLY; /* check arg num etc */
			    }
			  if ((is_symbol(caddar(sc->code))) &&
			      (is_null(cdddar(sc->code))))
			    {
			      car(sc->T3_1) = finder(sc, cadar(sc->code));
			      car(sc->T3_2) = finder(sc, caddar(sc->code));
			      car(sc->T3_3) = finder(sc, cadr(sc->code));
			      sc->args = sc->T3_1;
			      sc->code = c_function_setter(sc->x);
			      goto APPLY; /* check arg num etc */
			    }
			}

		      push_op_stack(sc, c_function_setter(sc->x));
		      push_stack(sc, OP_EVAL_ARGS1, sc->NIL, s7_append(sc, cddar(sc->code), cdr(sc->code)));
		      sc->code = cadar(sc->code);
		    }
		  else
		    {
		      if ((is_null(cddr(sc->code))) &&
			  (!is_pair(cadr(sc->code))))
			{
			  if (is_symbol(cadr(sc->code)))
			    car(sc->T1_1) = finder(sc, cadr(sc->code));
			  else car(sc->T1_1) = cadr(sc->code);
			  sc->args = sc->T1_1;
			  sc->code = c_function_setter(sc->x);
			  goto APPLY; /* check arg num etc */
			}
		      push_op_stack(sc, c_function_setter(sc->x));
		      push_stack(sc, OP_EVAL_ARGS1, sc->NIL, cddr(sc->code));
		      sc->code = cadr(sc->code);
		    }
		}
	      else
		{
		  if (is_any_macro(c_function_setter(sc->x)))
		    {
		      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
		      if (is_null(cdar(sc->code)))
			sc->args = list_1(sc, cons(sc, c_function_setter(sc->x), cdr(sc->code)));
		      else sc->args = list_1(sc, cons(sc, c_function_setter(sc->x), s7_append(sc, cdar(sc->code), cdr(sc->code))));
		      sc->code = c_function_setter(sc->x);
		      goto APPLY;
		    }
		  else eval_error(sc, "no generalized set for ~A", caar_code);
		}
	      break;
	      
	    case T_MACRO:
	    case T_BACRO:
	    case T_CLOSURE:
	    case T_CLOSURE_STAR:
	      if (is_procedure(closure_setter(sc->x))) /* appears to be caar_code */
		{
		  /* (set! (o g) ...), here sc->x = o, sc->code = ((o g) ...) */
		  
		  push_op_stack(sc, closure_setter(sc->x));
		  if (is_null(cdar(sc->code)))
		    {
		      push_stack(sc, OP_EVAL_ARGS1, sc->NIL, cddr(sc->code));
		      sc->code = cadr(sc->code);
		    }
		  else 
		    {
		      if (is_null(cddar(sc->code)))
			push_stack(sc, OP_EVAL_ARGS1, sc->NIL, cdr(sc->code));
		      else push_stack(sc, OP_EVAL_ARGS1, sc->NIL, s7_append(sc, cddar(sc->code), cdr(sc->code)));
		      sc->code = cadar(sc->code);
		    }
		}
	      else
		{
		  if (is_any_macro(closure_setter(sc->x)))
		    {
		      push_stack(sc, OP_EVAL_MACRO, sc->NIL, sc->args);
		      if (is_null(cdar(sc->code)))
			sc->args = list_1(sc, cons(sc, closure_setter(sc->x), cdr(sc->code)));
		      else sc->args = list_1(sc, cons(sc, closure_setter(sc->x), s7_append(sc, cdar(sc->code), cdr(sc->code))));
		      sc->code = closure_setter(sc->x);
		      goto APPLY;
		    }
		  else eval_error(sc, "no generalized set for ~A", caar_code);
		}
	      break;
	      
	    default:                                         /* (set! (1 2) 3) */
	      eval_error(sc, "no generalized set for ~A", caar_code);
	    }
	  /* sc->x = sc->NIL; */
	  goto EVAL;
	}
      

      /* --------------- */
    case OP_SET_NORMAL:
      {
	s7_pointer x;
	x = cadr(sc->code);
	if (is_pair(x))
	  {
	    push_stack_no_args(sc, OP_SET1, car(sc->code));
	    sc->code = x;
	    goto EVAL; 
	  }
	
	if (is_symbol(x))
	  sc->value = finder(sc, x);
	else sc->value = x;
	sc->code = car(sc->code);
      }
      

      /* --------------- */
    case OP_SET1:  
      /* if unbound variable hook here, we need the binding, not the current value */
      sc->y = find_symbol(sc, sc->code);
      if (is_slot(sc->y)) 
	{
	  if (symbol_has_accessor(sc->code))
	    {
	      s7_pointer func;
	      func = cadr(s7_gc_protected_at(sc, symbol_accessor(sc->code)));
	      if (is_procedure(func))
		{
		  if (is_c_function(func))
		    {
		      car(sc->T2_1) = sc->code;
		      car(sc->T2_2) = sc->value;
		      sc->value = c_function_call(func)(sc, sc->T2_1);
		      if (sc->value == sc->ERROR) /* backwards compatibility... */
			return(s7_error(sc, sc->ERROR,
					list_3(sc, make_protected_string(sc, "can't set ~S to ~S"), car(sc->T2_1), car(sc->T2_2))));
		    }
		  else
		    {
		      sc->args = list_2(sc, sc->code, sc->value);
		      push_stack(sc, OP_SET_WITH_ACCESSOR, sc->args, sc->y); /* op, args, code */
		      sc->code = func;
		      goto APPLY;
		    }
		}
	    }
	  else
	    {
	      if (is_syntax(slot_value(sc->y)))
		eval_error(sc, "can't set! ~A", sc->code);
	    }
	  slot_set_value(sc->y, sc->value); 
	  goto START;
	}
      eval_error(sc, "set! ~A: unbound variable", sc->code);


      /* --------------- */
    case OP_SET_WITH_ACCESSOR:
      if (sc->value == sc->ERROR) /* backwards compatibility... */
	return(s7_error(sc, sc->ERROR,
			list_3(sc, make_protected_string(sc, "can't set ~S to ~S"), car(sc->args), cadr(sc->args))));
      slot_set_value(sc->code, sc->value); 
      goto START;
      
      
      
      /* -------------------------------- IF -------------------------------- */
    case OP_IF:
      check_if(sc);
      push_stack_no_args(sc, OP_IF1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;
      

      /* --------------- */
    case OP_IF1:
      if (is_true(sc, sc->value))
	sc->code = car(sc->code);
      else sc->code = cadr(sc->code);   /* even pre-optimization, (if #f #f) ==> #<unspecified> because car(sc->NIL) = sc->UNSPECIFIED */
      if (is_pair(sc->code))
	goto EVAL; 
      if (is_symbol(sc->code))
	sc->value = finder(sc, sc->code);
      else sc->value = sc->code;
      goto START;
      
      
      /* --------------- */
    case OP_IF_P_P_P:
      push_stack_no_args(sc, OP_IF_PPP, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_IF_Z_P_P:
      push_stack_no_args(sc, OP_IF_PPP, cdr(sc->code));
      sc->code = car(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_IF_A_P_P:
      if (is_true(sc, ((s7_function)fcdr(sc->code))(sc, car(sc->code))))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL;
      

      /* --------------- */
    case OP_IF_B_P_P:
      {
	s7_pointer code;
	code = sc->code;
	push_stack_no_args(sc, OP_IF_PPP, cdr(code));
	code = car(code);
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }
      
      
      /* --------------- */
    case OP_IF_ANDP_P_P:
      push_stack_no_args(sc, OP_IF_PPP, cdr(sc->code));
      sc->code = cdar(sc->code);
      goto AND_P;
      
      
      /* --------------- */
    case OP_IF_ORP_P_P:
      push_stack_no_args(sc, OP_IF_PPP, cdr(sc->code));
      sc->code = cdar(sc->code);
      goto OR_P;
      
      
      /* --------------- */
    case OP_IF_PPP:
      if (is_true(sc, sc->value))
	sc->code = car(sc->code);
      else sc->code = cadr(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_IF_P_P:
      push_stack_no_args(sc, OP_IF_PP, cadr(sc->code));
      sc->code = car(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_IF_Z_P:
      push_stack_no_args(sc, OP_IF_PP, fcdr(sc->code));
      sc->code = car(sc->code);
      goto OPT_EVAL;
      
      
#if (!WITH_GMP)
      /* --------------- */
    case OP_IF_GT_P:
      {
	/* code: ((> (magnitude (- old new)) 0.001)...)
	 */
	s7_pointer arg, val1, val2;
	bool happy;
	arg = fcdr(sc->code);  /* cadr(cadr(test)) => (- old new) */
	val1 = finder(sc, cadr(arg));
	val2 = finder(sc, caddr(arg));
	if ((type(val1) == T_REAL) &&
	    (type(val2) == T_REAL))
	  happy = (fabs(real(val1) - real(val2)) > real(caddar(sc->code)));
	else
	  {
	    s7_Double x;
	    car(sc->T2_1) = val1;
	    car(sc->T2_2) = val2;
	    car(sc->T1_1) = g_subtract_2(sc, sc->T2_1);
	    x = s7_number_to_real(sc, g_magnitude(sc, sc->T1_1)); /* or maybe c_call here to get abs? */
	    happy = (x > real(caddar(sc->code)));
	  }
	if (happy)
	  {
	    sc->code = cadr(sc->code);
	    goto EVAL;
	  }
	sc->value = sc->UNSPECIFIED;
	IF_BEGIN_POP_STACK(sc); 
      }
#endif
      
      
      /* --------------- */
    case OP_IF_A_P:
      if (is_true(sc, ((s7_function)fcdr(sc->code))(sc, car(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL;
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      
      /* --------------- */
    case OP_IF_B_P:
      {
	s7_pointer code;
	code = sc->code;
	push_stack_no_args(sc, OP_IF_PP, cadr(code));
	code = car(code);
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }
      
      
      /* --------------- */
    case OP_IF_ANDP_P:
      push_stack_no_args(sc, OP_IF_PP, cadr(sc->code));
      sc->code = cdar(sc->code);
      goto AND_P;
      
      
      /* --------------- */
    case OP_IF_ORP_P:
      push_stack_no_args(sc, OP_IF_PP, cadr(sc->code));
      sc->code = cdar(sc->code);
      goto OR_P;
      
      
      /* --------------- */
    case OP_IF_PP:
      if (is_true(sc, sc->value))
	goto EVAL;  /* almost never happens */
      sc->value = sc->UNSPECIFIED;  
      IF_BEGIN_POP_STACK(sc); 
      

      /* --------------- */
    case OP_IF_P_P_X:
      push_stack_no_args(sc, OP_IF_PPX, cdr(sc->code));
      sc->code = car(sc->code);
      if (is_optimized(sc->code))
	goto OPT_EVAL;
      goto EVAL; 
      

      /* --------------- */
    case OP_IF_PPX:
      if (is_true(sc, sc->value))
	{
	  sc->code = car(sc->code);
	  goto EVAL; 
	}
      sc->value = cadr(sc->code);
      if (is_symbol(sc->value)) /* lat 2592129 2592129 */
	sc->value = finder(sc, sc->value);
      goto START;
      
      
      /* --------------- */
    case OP_IF_P_X_P:
      push_stack_no_args(sc, OP_IF_PXP, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_IF_PXP:
      if (is_true(sc, sc->value))
	{
	  sc->value = car(sc->code);
	  if (is_symbol(sc->value))
	    sc->value = finder(sc, sc->value);
	  goto START;
	}
      sc->code = cadr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_IF_P_X_X:
      push_stack_no_args(sc, OP_IF_PXX, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_IF_PXX:
      if (is_true(sc, sc->value))
	sc->value = car(sc->code);
      else sc->value = cadr(sc->code);
      
      if (is_symbol(sc->value))
	sc->value = finder(sc, sc->value);
      goto START;
      
      
      /* --------------- */
    case OP_IF_S_P_P:
      if (is_true(sc, finder(sc, car(sc->code))))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_IF_S_P:
      if (is_true(sc, finder(sc, car(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      
      /* --------------- */
    case OP_IF_S_P_X:
      if (is_true(sc, finder(sc, car(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      if (is_symbol(caddr(sc->code)))
	sc->value = finder(sc, caddr(sc->code));
      else sc->value = caddr(sc->code);
      goto START;
      
      
      /* --------------- */
    case OP_IF_S_X_P:
      if (is_true(sc, finder(sc, car(sc->code))))
	{
	  sc->value = cadr(sc->code);
	  if (is_symbol(sc->value))
	    sc->value = finder(sc, sc->value);
	  goto START;
	}
      sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_SAFE_IF_Z_Z:
      push_stack_no_args(sc, OP_SAFE_IF_Z_Z_1, fcdr(sc->code));
      sc->code = car(sc->code); 
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_SAFE_IF_Z_Z_1:
      if (is_true(sc, sc->value))
	goto OPT_EVAL; 
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      
      /* --------------- */
    case OP_SAFE_IF_CC_X_P:
      {
	s7_pointer code;
	code = sc->code;
	if (is_true(sc, c_call(car(code))(sc, cdar(code))))
	  {
	    sc->value = cadr(code);
	    if (is_symbol(sc->value))
	      sc->value = finder(sc, sc->value);
	    goto START;
	  }
	sc->code = caddr(code);
	goto EVAL; 
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_CC_P:
      {
	s7_pointer code;
	code = sc->code;
	if (is_true(sc, c_call(car(code))(sc, cdar(code))))
	  {
	    sc->code = cadr(code);
	    goto EVAL; 
	  }
	else sc->value = sc->UNSPECIFIED;
	IF_BEGIN_POP_STACK(sc); 
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_CC_P_P:
      {
	s7_pointer code;
	code = sc->code;
	if (is_true(sc, c_call(car(code))(sc, cdar(code))))
	  sc->code = cadr(code);
	else sc->code = caddr(code);
	goto EVAL; 
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_CS_X_P:
      {
	s7_pointer code;
	code = sc->code;
	car(sc->T1_1) = finder(sc, fcdr(code));
	if (is_true(sc, c_call(car(code))(sc, sc->T1_1)))
	  {
	    sc->value = cadr(code);
	    if (is_symbol(sc->value))
	      sc->value = finder(sc, sc->value);
	    goto START;
	  }
	sc->code = caddr(code);
	goto EVAL;
      }
      

      /* --------------- */
    case OP_SAFE_IF_CSS_X_P:
      {
	s7_pointer code;
	code = sc->code;
	car(sc->T2_1) = finder(sc, cadar(code));
	car(sc->T2_2) = finder(sc, fcdr(code));
	if (is_true(sc, c_call(car(code))(sc, sc->T2_1)))
	  {
	    sc->value = cadr(code);
	    if (is_symbol(sc->value))
	      sc->value = finder(sc, sc->value);
	    goto START;
	  }
	sc->code = caddr(code);
	goto EVAL; 
      }
      

      /* --------------- */
    case OP_SAFE_IF_CSC_X_P:
      {
	s7_pointer code;
	code = sc->code;
	car(sc->T2_1) = finder(sc, cadar(code));
	car(sc->T2_2) = fcdr(code);
	if (is_true(sc, c_call(car(code))(sc, sc->T2_1)))
	  {
	    sc->value = cadr(code);
	    if (is_symbol(sc->value))
	      sc->value = finder(sc, sc->value);
	    goto START;
	  }
	sc->code = caddr(code);
	goto EVAL; 
      }
      

      /* --------------- */
    case OP_SAFE_IF_CSC_X_O_A:
      {
	/* (if (< n 2) n (f ...)) */
	s7_pointer code;
	code = sc->code;
	sc->value = finder(sc, cadar(code)); /* tricky -- the same symbol is used twice, and if expr true, it is the returned value */
	car(sc->T2_1) = sc->value;
	car(sc->T2_2) = fcdr(code);
	if (is_true(sc, c_call(car(code))(sc, sc->T2_1)))
	  goto START;
	sc->code = caddr(code);
	goto OPT_EVAL; 
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_CS_P_X:
      {
	s7_pointer code;
	code = sc->code;
	car(sc->T1_1) = finder(sc, fcdr(code));
	if (is_true(sc, c_call(car(code))(sc, sc->T1_1)))
	  {
	    sc->code = cadr(code);
	    goto EVAL; 
	  }
	sc->value = caddr(code);
	if (is_symbol(sc->value))
	  sc->value = finder(sc, sc->value);
	goto START;
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_IS_PAIR_P_X:
      if (is_pair(finder(sc, fcdr(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = caddr(sc->code);
      if (is_symbol(sc->value))
	sc->value = finder(sc, sc->value);
      goto START;
      
      
      /* --------------- */
    case OP_SAFE_IF_CS_P_P:
      car(sc->T1_1) = finder(sc, fcdr(sc->code));
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T1_1)))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_SAFE_IF_IS_PAIR_P_P:
      if (is_pair(finder(sc, fcdr(sc->code))))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_SAFE_IF_IS_SYMBOL_P_P:
      if (is_symbol(finder(sc, fcdr(sc->code))))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_SAFE_IF_IS_NULL_Q_P:
      {
	s7_pointer code;
	code = sc->code;
	if (is_null(finder(sc, fcdr(code))))
	  {
	    sc->value = cadr(cadr(code));
	    goto START;
	  }
	code = caddr(code);
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }
      
      
      /* --------------- */
    case OP_SAFE_IF_IS_NULL_S_P:
      {
	s7_pointer code;
	code = sc->code;
	if (is_null(finder(sc, fcdr(code))))
	  {
	    sc->value = finder(sc, cadr(code));
	    goto START;
	  }
	code = caddr(code);
	sc->op = (opcode_t)lifted_op(code);
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }

      
      /* --------------- */
    case OP_SAFE_IF_CS_P:
      car(sc->T1_1) = finder(sc, fcdr(sc->code));
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T1_1)))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      
      /* --------------- */
    case OP_SAFE_IF_CSQ_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = fcdr(sc->code);
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      
      /* --------------- */
    case OP_SAFE_IF_CSQ_P_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = fcdr(sc->code);
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_SAFE_IF_CSS_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = finder(sc, fcdr(sc->code));
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	{
	  sc->code = cadr(sc->code);
	  if (is_optimized(sc->code))
	    goto OPT_EVAL;
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      IF_BEGIN_POP_STACK(sc); 
      
      
      /* --------------- */
    case OP_SAFE_IF_CSS_P_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = finder(sc, fcdr(sc->code));
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_SAFE_IF_CSC_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = fcdr(sc->code);
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      

      /* --------------- */
    case OP_SAFE_IF_CSC_P_P:
      car(sc->T2_1) = finder(sc, cadr(car(sc->code)));
      car(sc->T2_2) = fcdr(sc->code);
      if (is_true(sc, c_call(car(sc->code))(sc, sc->T2_1)))
	sc->code = cadr(sc->code);
      else sc->code = caddr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_SAFE_IF_IS_PAIR_P:
      if (is_pair(finder(sc, fcdr(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      IF_BEGIN_POP_STACK(sc); 
      

      /* --------------- */
    case OP_SAFE_IF_IS_SYMBOL_P:
      if (is_symbol(finder(sc, fcdr(sc->code))))
	{
	  sc->code = cadr(sc->code);
	  goto EVAL; 
	}
      sc->value = sc->UNSPECIFIED;
      goto START;
      
      

      /* --------------- */
    case OP_SAFE_IF_C_SS_P:
      {
	s7_pointer args, val1;
	args = fcdr(sc->code);
	val1 = finder(sc, cadr(args));
	car(sc->T2_2) = finder(sc, caddr(args));
	car(sc->T2_1) = val1;
	car(sc->T1_1) = c_call(args)(sc, sc->T2_1);
	if (is_true(sc, c_call(car(sc->code))(sc, sc->T1_1)))
	  {
	    sc->code = cadr(sc->code);
	    goto EVAL; 
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }
      
      
      /* --------------- */
    case OP_SAFE_C_P_1:
      car(sc->T1_1) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T1_1);
      goto START;
      
      
      /* --------------- */
    case OP_SAFE_C_PP_1:
      /* unless multiple values from last call (first arg), sc->args == sc->NIL because we pushed that.
       *   we get here only from SAFE_C_PP.
       *
       * currently splice_in_values changes the operator so if we get here, sc->value is the result of the first arg
       *
       * safe_c_pp -> 1, but if mv, -> 3
       * 1: -> 2, if mv -> 4
       * 2: done (both normal)
       * 3: -> 5, but if mv, -> 6
       * 4: done (1 normal, 2 mv)
       * 5: done (1 mv, 2 normal)
       * 6: done (both mv)
       *
       * I think safe_c_ppp would require 18 branches
       */
      push_stack(sc, OP_SAFE_C_PP_2, sc->value, sc->code); /* mv -> 3 */
      sc->code = caddr(sc->code);
      if (is_optimized(sc->code))
	goto OPT_EVAL;
      goto EVAL; 
      

      /* --------------- */
    case OP_SAFE_C_PP_2:
      /* we get here only if neither arg returned multiple values, so sc->args is the first value, and sc->value the second
       */
      car(sc->T2_1) = sc->args;
      car(sc->T2_2) = sc->value;
      sc->value = c_call(sc->code)(sc, sc->T2_1);
      goto START;


      /* --------------- */
    case OP_SAFE_C_PP_3:
      /* we get here if the first arg returned multiple values
       */
      push_stack(sc, OP_SAFE_C_PP_5, sc->value, sc->code);
      sc->code = caddr(sc->code);
      if (is_optimized(sc->code))
	goto OPT_EVAL;
      goto EVAL; 


    case OP_SAFE_C_PP_4:
      /* we get here if the first arg result was normal, but the second had multiple values */
      sc->args = cons(sc, sc->args, sc->value);
      goto PP_MM;

    case OP_SAFE_C_PP_5:
      /* 1 mv, 2, normal */
      sc->args = s7_append(sc, sc->args, list_1(sc, sc->value));
      goto PP_MM;

    case OP_SAFE_C_PP_6:
      /* both mv */
      sc->args = s7_append(sc, sc->args, sc->value);
      
    PP_MM:
      /* 
       * c_call(sc->code) here refers to the fcdr field which is g_add_2, but we have any number of args from a values call
       *   the original (unoptimized) function is (hopefully) c_function_base(ecdr(sc->code))?
       *
       *   (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (ho 2))) (hi)) -> 7
       *   (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) -> 10
       *   (let () (define (ho a) (+ a 2)) (define (hi) (+ (values 3 4) (ho 1))) (hi)) -> 10
       *   (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10
       */
      sc->code = c_function_base(ecdr(sc->code));
      goto APPLY;

      
      /* --------------- */
    case OP_C_P_1:
      sc->value = c_call(sc->code)(sc, list_1(sc, sc->value));
      goto START;

    case OP_C_P_2:
      /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2)))
       */
      sc->code = c_function_base(ecdr(sc->code)); /* see comment above */
      sc->args = copy_list(sc, sc->value);
      goto APPLY;
      

      /* --------------- */
    case OP_C_SP_1:
      sc->value = c_call(sc->code)(sc, list_2(sc, sc->args, sc->value));
      goto START;

    case OP_C_SP_2:
      /* op_c_sp_1 -> mv case: (map + (values '(1 2 3) #(1 2 3)))
       */
      sc->code = c_function_base(ecdr(sc->code)); 
      sc->args = cons(sc, sc->args, copy_list(sc, sc->value));
      goto APPLY;
      
      
      
      
      /* -------------------------------- LET -------------------------------- */
      
    case OP_LET_NO_VARS:
      NEW_FRAME(sc, sc->envir, sc->envir); 
      sc->code = cdr(sc->code);            /* ignore the () */
      goto BEGIN;
      
      
      /* --------------- */
    case OP_NAMED_LET_NO_VARS:
      NEW_FRAME(sc, sc->envir, sc->envir); 
      sc->args = sc->NIL;                  /* the let args */
      sc->x = make_closure(sc, sc->NIL, cddr(sc->code), T_CLOSURE);
      add_slot(sc, car(sc->code), sc->x); 
      sc->code = cddr(sc->code);
      sc->x = sc->NIL;
      goto BEGIN;
      
      
      /* --------------- */
    case OP_LET_C:
      /* one var, init is constant, incoming sc->code is '(((var val))...)!
       */
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(sc->code), fcdr(sc->code));
      sc->code = cdr(sc->code);
      if (is_pair(cdr(sc->code)))
	push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_LET_C_P:
      /* one var, init is constant, incoming sc->code is '(((var val))...)!
       *   body is one statement
       */
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(sc->code), fcdr(sc->code));
      sc->code = cadr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_LET_C_D:
      /* one var, init is constant, incoming sc->code is '(((var val))...)!
       *   body is one optimized statement
       */
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(sc->code), fcdr(sc->code));
      sc->code = cadr(sc->code);
      goto OPT_EVAL;
      
      
      /* --------------- */
    case OP_LET_S:
      /* one var, init is symbol, incoming sc->code is '(((var sym))...)
       */
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(sc->code), finder(sc, fcdr(sc->code)));
      sc->code = cdr(sc->code);
      push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_LET_S_P:
      /* one var, init is symbol, incoming sc->code is '(((var sym))...)
       */
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(sc->code), finder(sc, fcdr(sc->code)));
      sc->code = cadr(sc->code);
      goto EVAL; 
      
      
      /* --------------- */
    case OP_LET_Q:
      /* one var, init is quoted, incoming sc->code is '(((var 'val))...)
       */
      {
	s7_pointer binding;
	binding = caar(sc->code);
	NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, car(binding), cadr(cadr(binding)));
	sc->code = cdr(sc->code);
	goto BEGIN;
      }
      
      /* --------------- */
    case OP_LET_R:
      {
	s7_pointer binding;
	binding = caar(sc->code);
	car(sc->T1_1) = finder(sc, fcdr(sc->code));
	sc->value = c_call(cadr(binding))(sc, sc->T1_1);
	NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, car(binding), sc->value);
	push_stack_no_args(sc, OP_BEGIN1, cddr(sc->code));
	sc->code = cadr(sc->code);
	goto EVAL;
      }
      

      /* --------------- */
    case OP_LET_R_P:
      {
	s7_pointer binding;
	binding = caar(sc->code);
	car(sc->T1_1) = finder(sc, fcdr(sc->code));
	sc->value = c_call(cadr(binding))(sc, sc->T1_1);
	NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, car(binding), sc->value);
	sc->code = cadr(sc->code);
	goto EVAL; 
      }
      

      /* --------------- */
    case OP_LET_opCq:
      /* one var, init is safe_c_c */
      {
	s7_pointer binding;
	binding = caar(sc->code);
	sc->value = c_call(cadr(binding))(sc, cdadr(binding));
	NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, car(binding), sc->value);
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      

      /* --------------- */
    case OP_LET_opSSq:
      /* one var, init is safe_c_ss
       */
      {
	s7_pointer binding, largs, in_val;
	binding = caar(sc->code);
	largs = cadr(binding);
	in_val = finder(sc, cadr(largs));
	car(sc->T2_2) = finder(sc, caddr(largs));
	car(sc->T2_1) = in_val;
	sc->value = c_call(largs)(sc, sc->T2_1);
	NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, car(binding), sc->value);
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      

      /* --------------- */
    case OP_LET_CAR_P:
      {
	s7_pointer val, code;
	opcode_t op;
	
	code = sc->code;
	val = finder(sc, fcdr(code));
	if (!is_pair(val)) 
	  {
	    val = g_car(sc, list_1(sc, val));
	    NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(code), val);
	  }
	else 
	  {
	    NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, gcdr(code), car(val));
	  }
	
	code = cadr(code);
	op = (opcode_t)lifted_op(code);
	if (op == OP_SAFE_IF_CC_X_P)
	  {
	    code = cdr(code);
	    if (is_true(sc, c_call(car(code))(sc, cdar(code))))
	      {
		sc->value = cadr(code);
		if (is_symbol(sc->value))
		  sc->value = finder(sc, sc->value);
		goto START;
	      }
	    sc->code = caddr(code);
	    goto EVAL;
	  }
	sc->op = op;
	sc->code = cdr(code);
	goto START_WITHOUT_POP_STACK;
      }
      

      /* --------------- */
    case OP_LET_O:
      push_stack(sc, OP_LET_O1, fcdr(cdr(sc->code)), cdr(sc->code));
      sc->code = fcdr(sc->code);
      if (!is_optimized(sc->code))
	goto EVAL; 
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_LET_O1:
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, sc->args, sc->value);
      if (is_pair(cdr(sc->code)))
	push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_LET_Z_O:
      push_stack(sc, OP_LET_O2, fcdr(cdr(sc->code)), cadr(sc->code));
      sc->code = fcdr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_LET_O_O:
      push_stack(sc, OP_LET_O2, fcdr(cdr(sc->code)), cadr(sc->code));
      sc->code = fcdr(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_LET_O2:
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, sc->args, sc->value);
      goto NS_EVAL; 
      
      
      /* --------------- */
    case OP_LET_Z_P:
      /* sc->code here is the let form without "let": (((val binding)) ...)
       *   in t456 it's all h_apply_ss, in t502 h_safe_c_sp
       */
      push_stack(sc, OP_LET_O3, fcdr(cdr(sc->code)), cadr(sc->code));
      sc->code = fcdr(sc->code);
      goto OPT_EVAL;
      

      /* --------------- */
    case OP_LET_O_P:
      /* hooboy, both fcdrs here can be NULL!  But it requires a grim determination to screw up
       *   no matter what.  A macro that defines two functions in for-each, each of which shares code,
       *   and one is called before the other gets to be optimized.  Has this ever happened
       *   in real life?  Call tree-copy and move on.
       */
      push_stack(sc, OP_LET_O3, fcdr(cdr(sc->code)), cadr(sc->code));
      sc->code = fcdr(sc->code);
      goto EVAL; 
      

      /* --------------- */
    case OP_LET_O3:
      NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, sc->args, sc->value);
      sc->op = (opcode_t)lifted_op(sc->code);
      sc->code = cdr(sc->code);
      goto START_WITHOUT_POP_STACK;
      
      
      /* --------------- */
    case OP_LET_ALL_C:
      {
	s7_pointer p;
	NEW_FRAME(sc, sc->envir, sc->envir);
	for (p = car(sc->code); is_pair(p); p = cdr(p))
	  ADD_SLOT(sc->envir, caar(p), cadar(p)); 
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      
      
      /* --------------- */
    case OP_LET_ALL_S:
      /* n vars, all inits are symbols.  We need to GC-protect the new frame-list as it is being
       *    created without tying the new frame into sc->envir until the end.
       */
      {
	s7_pointer p, frame;
	frame = make_simple_environment(sc);
	sc->args = frame;
	for (p = car(sc->code); is_pair(p); p = cdr(p))
	  ADD_SLOT(frame, caar(p), finder(sc, cadar(p)));
	environment_number++;
	sc->envir = frame;
	sc->code = cdr(sc->code);
	goto BEGIN;
      }
      

      /* --------------- */
    case OP_LET_ALL_R:
      {
	s7_pointer p, frame;
	frame = make_simple_environment(sc);   	
	sc->args = frame;
	for (p = car(sc->code); is_pair(p); p = cdr(p))
	  {
	    s7_pointer cp;
	    cp = cadar(p);
	    car(sc->T1_1) = finder(sc, cadr(cp));
	    ADD_SLOT(frame, caar(p), c_call(cp)(sc, sc->T1_1)); 
	  }
	environment_number++;
	sc->envir = frame;
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      

    case OP_LET_ALL_X:
      {
	s7_pointer p, frame;
	frame = make_simple_environment(sc);   		
	sc->args = frame; 
	for (p = car(sc->code); is_pair(p); p = cdr(p))
	  {
	    s7_pointer arg;
	    arg = cdar(p);
	    arg = ((s7_function)fcdr(arg))(sc, car(arg));
	    ADD_SLOT(frame, caar(p), arg);
	  }
	environment_number++;
	sc->envir = frame;
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      
      
      /* --------------- */
    case OP_NAMED_LET:
      sc->args = sc->NIL;
      sc->value = sc->code;
      sc->code = cadr(sc->code);
      goto LET1;
      

      /* --------------- */
    case OP_LET_UNCHECKED:
      /* not named, but has vars */
      {
	s7_pointer x;
	NEW_CELL(sc, x);
	car(x) = sc->code;
	cdr(x) = sc->NIL;
	set_type(x, T_PAIR);
	sc->args = x;
	sc->code = car(sc->code);
	goto LET1A;
      }
      
      
      /* --------------- */
    case 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;
	check_let(sc);
	sc->args = sc->NIL;
	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;
	    NEW_FRAME(sc, sc->envir, sc->envir);
	    if (named_let)
	      {    
		sc->x = make_closure(sc, sc->NIL, cddr(sc->code), T_CLOSURE); /* args = () in new closure, see NAMED_LET_NO_VARS above */
		/* if this is a safe closure, we can build its env in advance and name it (a thunk in this case)
		 */
		set_function_env(closure_environment(sc->x));
		environment_function(closure_environment(sc->x)) = car(sc->code);

		add_slot(sc, car(sc->code), sc->x); 
		sc->code = cddr(sc->code);
		sc->x = sc->NIL;
	      }
	    else 
	      {
		sc->code = cdr(sc->code);
	      }
	    goto BEGIN;
	  }
      }
      
      
      /* --------------- */
    LET1:
    case OP_LET1:       /* let -- calculate parameters */
      /* sc->args = cons(sc, sc->value, sc->args); */
      {
	s7_pointer x, y;
	
	NEW_CELL(sc, x);
	car(x) = sc->value; /* the first time (now handled above), this saves the entire let body across the evaluations -- we pick it up later */
	cdr(x) = sc->args;
	set_type(x, T_PAIR);
	sc->args = x;
	
	if (is_pair(sc->code)) 
	  { 
	  LET1A:
	    x = cadar(sc->code);
	    
	    if (is_pair(x))
	      {
		push_stack(sc, OP_LET1, sc->args, cdr(sc->code));
		sc->code = x;
		if (is_optimized(x))
		  goto OPT_EVAL;
		goto EVAL;  
		/* this push_stack/goto can't be optimized away via a local optimize_data case statement
		 *    because any c_call can trigger an embedded call on the evaluator (for example,
		 *    open-sound involves both hooks, and s7_load if the corresponding .scm code exists),
		 *    so we have to protect sc->code and sc->args via the stack.  (I subsequently added
		 *    some protection here, but debugging this is hard, and the gain is not huge).
		 */
	      }
	    if (is_symbol(x))
	      sc->value = finder(sc, x);
	    else sc->value = x;
	    sc->code = cdr(sc->code);
	    goto LET1;
	  }
	
	x = safe_reverse_in_place(sc, sc->args);
	sc->code = car(x); /* restore the original form */
	y = cdr(x);        /* use sc->args as the new frame */
	sc->envir = old_frame_in_env(sc, x, sc->envir);
	
	{
	  bool named_let;
	  named_let = is_symbol(car(sc->code));
	  if (named_let)
	    {
	      /* we need to check the current environment for ridiculous cases like
	       *    (let hiho ((hiho 4)) hiho) -- I guess hiho is 4
	       */
	      s7_pointer let_name;
	      let_name = car(sc->code);
	      sc->envir = new_frame_in_env(sc, sc->envir);
	      
	      sc->w = sc->NIL;
	      for (x = cadr(sc->code); is_pair(x); x = cdr(x)) 
		sc->w = cons(sc, caar(x), sc->w);
	      
	      sc->x = make_closure(sc, safe_reverse_in_place(sc, sc->w), cddr(sc->code), T_CLOSURE);
	      if (is_safe_closure(sc->x))
		{
		  s7_pointer arg, new_env;
		  new_env = new_frame_in_env(sc, sc->envir);
		  closure_environment(sc->x) = new_env;
		  for (arg = closure_args(sc->x); is_pair(arg); arg = cdr(arg))
		    s7_make_slot(sc, new_env, car(arg), sc->NIL);
		  environment_slots(new_env) = reverse_slots(sc, environment_slots(new_env));
		}
	      add_slot(sc, let_name, sc->x); 
	      sc->x = sc->NIL;
	      
	      sc->envir = new_frame_in_env(sc, sc->envir);
	      for (x = cadr(sc->code); is_not_null(y); x = cdr(x)) 
		{
		  s7_pointer sym, args, val;
		  /* reuse the value cells as the new frame slots */
		  
		  sym = caar(x);
		  if (sym == let_name) let_name = sc->NIL;
		  val = car(y);
		  args = cdr(y);
		  
		  slot_symbol(y) = sym;
		  if (symbol_has_accessor(sym))
		    slot_set_value(y, call_symbol_bind(sc, sym, val));
		  else slot_set_value(y, val);
		  set_type(y, T_SLOT | T_IMMUTABLE);
		  next_slot(y) = environment_slots(sc->envir);
		  environment_slots(sc->envir) = y;
		  symbol_set_local(sym, environment_id(sc->envir), y);
		  
		  y = args;
		}
	      sc->code = cddr(sc->code);
	    }
	  else
	    {
	      s7_pointer e;
	      unsigned long long int id;
	      
	      e = sc->envir;
	      id = environment_id(e);
	      
	      for (x = car(sc->code); is_not_null(y); x = cdr(x)) 
		{
		  s7_pointer sym, args, val;
		  /* reuse the value cells as the new frame slots */
		  
		  sym = caar(x);
		  val = car(y);
		  args = cdr(y);
		  
		  slot_symbol(y) = sym;
		  symbol_set_local(sym, id, y);
		  if (symbol_has_accessor(sym))
		    slot_set_value(y, call_symbol_bind(sc, sym, val));
		  else slot_set_value(y, val);
		  set_type(y, T_SLOT | T_IMMUTABLE);
		  next_slot(y) = environment_slots(e);
		  environment_slots(e) = y;
		  
		  y = args;
		}
	      sc->code = cdr(sc->code);
	    }
	}
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }
      
      
      /* -------------------------------- LET* -------------------------------- */      

    case OP_LET_STAR_ALL_X:
      {
	s7_pointer p;
	for (p = car(sc->code); is_pair(p); p = cdr(p))
	  {
	    s7_pointer arg;
	    arg = cdar(p);
	    arg = ((s7_function)fcdr(arg))(sc, car(arg));
	    NEW_FRAME_WITH_SLOT(sc, sc->envir, sc->envir, caar(p), arg);
	  }
	sc->code = cdr(sc->code);
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }


      /* --------------- */
    case OP_NAMED_LET_STAR:
      push_stack(sc, OP_LET_STAR1, sc->code, cadr(sc->code));
      sc->code = fcdr(sc->code);
      goto EVAL;

      
    case OP_LET_STAR2:
      push_stack(sc, OP_LET_STAR1, sc->code, car(sc->code));
      sc->code = fcdr(sc->code);
      goto EVAL;


      /* --------------- */
    case OP_LET_STAR:
      check_let_star(sc);

      
      /* --------------- */
    case OP_LET_STAR_UNCHECKED:
      if (is_symbol(car(sc->code)))
	{
	  sc->x = car(sc->code);
	  sc->value = cdr(sc->code);
	  if (is_null(car(sc->value)))
	    {
	      sc->envir = new_frame_in_env(sc, sc->envir);
	      sc->code = cdr(sc->value);
	      add_slot(sc, sc->x, make_closure(sc, sc->NIL, sc->code, T_CLOSURE_STAR));
	      goto BEGIN;
	    }
	}
      else
	{
	  if (is_null(car(sc->code)))
	    {
	      sc->envir = new_frame_in_env(sc, sc->envir);
	      sc->code = cdr(sc->code);
	      goto BEGIN;
	    }
	}

      if (is_symbol(car(sc->code)))
	{
	  push_stack(sc, OP_LET_STAR1, sc->code, cadr(sc->code));
	  sc->code = cadr(caadr(sc->code));
	}
      else
	{
	  push_stack(sc, OP_LET_STAR1, sc->code, car(sc->code));
	  /* args is the let body, saved for later, code is the list of vars+initial-values */
	  sc->code = cadr(caar(sc->code));
	  /* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */
	}
      goto EVAL;
      
      
      /* --------------- */
    LET_STAR1:
    case OP_LET_STAR1:    /* let* -- calculate parameters */
      /* we can't skip (or reuse) this new frame -- we have to imitate a nested let, otherwise
       *
       *   (let ((f1 (lambda (arg) (+ arg 1))))
       *     (let* ((x 32)
       *            (f1 (lambda (arg) (f1 (+ x arg)))))
       *       (f1 1)))
       *
       * will hang.
       */
      NEW_FRAME_WITH_CHECKED_SLOT(sc, sc->envir, sc->envir, caar(sc->code), sc->value);
      
      sc->code = cdr(sc->code);
      if (is_pair(sc->code)) 
	{ 
	  s7_pointer x;
	  x = cadar(sc->code);
	  if (is_pair(x))
	    {
	      push_stack(sc, OP_LET_STAR1, sc->args, sc->code); 
	      sc->code = x;
	      if (is_optimized(x))
		goto OPT_EVAL;
	      goto EVAL; 
	    }
	  
	  if (is_symbol(x))
	    sc->value = finder(sc, x);
	  else sc->value = x;
	  goto LET_STAR1;
	} 

      sc->code = sc->args; /* original sc->code set in push_stack above */
      if (is_symbol(car(sc->code)))
	{
	  /* now we need to declare the new function */
	  add_slot(sc, car(sc->code), make_closure(sc, cadr(sc->code), cddr(sc->code), T_CLOSURE_STAR));
	  sc->code = cddr(sc->code);
	}
      else sc->code = cdr(sc->code);
      if (is_pair(cdr(sc->code)))
	push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
      sc->code = car(sc->code);
      goto EVAL;


      
      
      /* -------------------------------- LETREC -------------------------------- */
      
    case OP_LETREC:
      check_letrec(sc);
      
      /* --------------- */
    case OP_LETREC_UNCHECKED:
      /* get all local vars and set to #<undefined>
       * get parallel list of values
       * eval each member of values list with env still full of #<undefined>'s
       * assign each value to its variable
       * eval body
       *
       * which means that (letrec ((x x)) x) is not an error!
       */
      sc->envir = new_frame_in_env(sc, sc->envir); 
      if (is_pair(car(sc->code)))
	{
	  s7_pointer x;
	  for (x = car(sc->code); is_not_null(x); x = cdr(x))
	    {
	      s7_pointer slot;
	      slot = add_slot(sc, caar(x), sc->UNDEFINED);
	      slot_pending_value(slot) = sc->UNDEFINED;
	      slot_expression(slot) = cadar(x);
	    }
	  sc->args = environment_slots(sc->envir);
	  push_stack(sc, OP_LETREC1, sc->args, sc->code);
	  sc->code = slot_expression(sc->args);
	  goto EVAL;
	}
      sc->code = cdr(sc->code);
      goto BEGIN;
      

      /* --------------- */
    case OP_LETREC1:
      slot_pending_value(sc->args) = sc->value;
      sc->args = next_slot(sc->args);
      if (is_slot(sc->args))
	{
	  push_stack(sc, OP_LETREC1, sc->args, sc->code);
	  sc->code = slot_expression(sc->args);
	  goto EVAL;
	}
      else
	{
	  s7_pointer slot;
	  for (slot = environment_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
	    {
	      if (symbol_has_accessor(slot_symbol(slot)))
		slot_set_value(slot, call_symbol_bind(sc, slot_symbol(slot), slot_pending_value(slot)));
	      else slot_set_value(slot, slot_pending_value(slot));
	    }
	  sc->code = cdr(sc->code);
	  if (is_pair(cdr(sc->code)))
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	  sc->code = car(sc->code);
	  goto EVAL;
	}

      

      /* -------------------------------- COND -------------------------------- */      
    case OP_COND:
      check_cond(sc);

      /* --------------- */
    case OP_COND_UNCHECKED:
      push_stack(sc, OP_COND1, sc->NIL, sc->code);
      sc->code = caar(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_COND1:
      if (is_true(sc, sc->value))     /* got a hit (is_true -> not false, so else is true even though it has no value) */
	{
	  sc->code = cdar(sc->code);
	  if (is_null(sc->code))
	    {
	      if (is_multiple_value(sc->value))                             /* (+ 1 (cond ((values 2 3)))) */
		sc->value = splice_in_values(sc, multiple_value(sc->value));
	      /* no result clause, so return test, (cond (#t)) -> #t, (cond ((+ 1 2))) -> 3 */
	      goto START;
	    }

	  if ((is_pair(sc->code)) &&
	      (car(sc->code) == sc->FEED_TO) &&
	      (s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
	    {
	      if (is_multiple_value(sc->value))                             /* (cond ((values 1 2) => +)) */
		sc->code = cons(sc, cadr(sc->code), multiple_value(sc->value));
	      else sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->QUOTE, sc->value)); 
	      goto EVAL; 
	    }

	  /* (cond (#t 1)) sc->code is (1), but we're leaving syntax checks to OP_BEGIN: (cond (#t . 1)) etc */
	  goto BEGIN;
	}

      sc->code = cdr(sc->code);
      if (is_null(sc->code))
	{
	  sc->value = sc->NIL;
	  goto START;
	} 
	  
      push_stack_no_args(sc, OP_COND1, sc->code);
      sc->code = caar(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    case OP_COND_SIMPLE:
      push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
      sc->code = caar(sc->code);
      goto EVAL;
      
      
      /* --------------- */
    COND1_SIMPLE:
    case OP_COND1_SIMPLE:
      if (is_true(sc, sc->value))
	{
	  sc->code = cdar(sc->code);
	  if (is_null(sc->code))
	    {
	      if (is_multiple_value(sc->value))
		sc->value = splice_in_values(sc, multiple_value(sc->value));
	      goto START;
	    }
	  if (is_pair(cdr(sc->code)))
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	  sc->code = car(sc->code);
	  goto EVAL;
	}

      sc->code = cdr(sc->code);
      if (is_null(sc->code))
	{
	  sc->value = sc->NIL;
	  goto START;
	} 
      if (is_pair(caar(sc->code)))
	{
	  push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
	  sc->code = caar(sc->code);
	  goto EVAL; 
	}
      sc->value = caar(sc->code);
      if (is_symbol(sc->value))
	sc->value = finder(sc, sc->value);
      goto COND1_SIMPLE;


      /* --------------- */
    case OP_COND_ALL_X:
      {
	s7_pointer p;
	for (p = sc->code; is_pair(p); p = cdr(p))
	  {
	    sc->value = ((s7_function)fcdr(car(p)))(sc, caar(p));
	    if (is_true(sc, sc->value))
	      {
		sc->code = cdar(p);
		if (is_null(sc->code))
		  {
		    if (is_multiple_value(sc->value))
		      sc->value = splice_in_values(sc, multiple_value(sc->value));
		    goto START;
		  }
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	  }
	sc->value = sc->NIL;
	goto START;
      }


      /* -------------------------------- AND -------------------------------- */
    case OP_AND:
      check_and(sc);
      if (is_null(sc->code))
	{
	  sc->value = sc->T;
	  goto START;
	}
      goto AND1;

      /* --------------- */
    case OP_AND1:
      if ((is_false(sc, sc->value)) ||
	  (is_null(sc->code)))
	goto START;

      /* --------------- */
    AND1:
    case OP_AND_UNCHECKED:
      {
	s7_pointer p;
	p = car(sc->code);
	if (!is_pair(p))
	  {
	    if (is_symbol(p))
	      sc->value = SYMBOL_TO_VALUE(sc, p); /* a toss-up over finder: better in some cases, worse in others */
	    else sc->value = p;

	    if ((is_false(sc, sc->value)) ||
		(is_null(cdr(sc->code))))
	      goto START;

	    sc->code = cdr(sc->code);
	    goto AND1;
	  }

	if (is_not_null(cdr(sc->code)))
	  push_stack_no_args(sc, OP_AND1, cdr(sc->code));
	sc->code = p;
	if (is_optimized(p))
	  goto OPT_EVAL;
	goto EVAL; 
      }


      /* --------------- */
    case OP_AND_P1:
      if ((is_false(sc, sc->value)) ||
	  (is_null(sc->code)))
	goto START; 
      /* fall through */

      /* --------------- */
    AND_P:
    case OP_AND_P:
      if (fcdr(sc->code))
	{
	  sc->value = ((s7_function)fcdr(sc->code))(sc, car(sc->code));
	  if (is_false(sc, sc->value))
	    goto START;
	  sc->code = cdr(sc->code);
	  if (is_null(sc->code))
	    goto START;
	  goto AND_P;
	}
      else
	{
	  if (is_not_null(cdr(sc->code)))
	    push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); 
	  sc->code = car(sc->code);
	  goto EVAL; 
	}


      
      /* -------------------------------- OR -------------------------------- */      
    case OP_OR:
      check_or(sc);
      if (is_null(sc->code)) 
	{
	  sc->value = sc->F;
	  goto START;
	}
      goto OR1;

      /* --------------- */
    case OP_OR1:
      if ((is_true(sc, sc->value)) ||
	  (is_null(sc->code)))
	goto START;

      /* --------------- */
    OR1:
    case OP_OR_UNCHECKED:
      if (!is_pair(car(sc->code)))
	{
	  sc->value = car(sc->code);
	  if (is_symbol(sc->value))
	    sc->value = finder(sc, sc->value);

	  if ((is_true(sc, sc->value)) ||
	      (is_null(cdr(sc->code))))
	    goto START;

	  sc->code = cdr(sc->code);
	  goto OR1;
	}

      if (is_not_null(cdr(sc->code)))
	push_stack_no_args(sc, OP_OR1, cdr(sc->code)); 
      sc->code = car(sc->code);
      goto EVAL; 


      /* --------------- */
    case OP_OR_P1:
      if ((is_true(sc, sc->value)) ||
	  (is_null(sc->code)))
	goto START;
      /* fall through */

      /* --------------- */
    OR_P:
    case OP_OR_P:
      if (fcdr(sc->code))
	{
	  sc->value = ((s7_function)fcdr(sc->code))(sc, car(sc->code));
	  if (is_true(sc, sc->value))
	    goto START;
	  sc->code = cdr(sc->code);
	  if (is_null(sc->code))
	    goto START;
	  goto OR_P;
	}
      else
	{
	  if (is_not_null(cdr(sc->code)))
	    push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); 
	  sc->code = car(sc->code);
	  goto EVAL; 
	}


      /* --------------- */

      /* (define* (char= . args) (or (< (length args) 2) (apply char=? args)))
       */
      
      /* by going direct without a push_stack on the last one we get "tail recursion",
       *   but if the last arg (also in "and" above) is "values", there is a slight
       *   inconsistency: the values are returned and spliced into the caller if trailing, but
       *   are spliced into the "or" if not trailing, so
       *
       *   (+ 10 (or (values 1 2) #f))
       *   11
       *   (+ 10 (or #f (values 1 2)))
       *   13
       *   (+ 10 (or (or #f (values 1 2)) #f))
       *   11
       *
       * The tail recursion is more important.  This behavior matches that of "begin" -- if the
       * values statement is last, it splices into the next outer arglist.
       *
       * I tried implementing dynamic-binding by walking up the stack looking at envs, but
       *   for that to work in some cases, every new frame needs to be on the stack, hence
       *   OP_LET_UNWIND.  But that means the stack grows on every let, so tail recursion is
       *   defeated.  I'd have to notice tail calls and pop the stack, but I decided that
       *   was too much work for a minor (unneeded) feature.  Although the stack does not
       *   grow, we're depending on the GC to take care of the old local envs after the
       *   tail call.  My test:
       *
       * (let ((max-stack 0))
       *   (define (tc-1 a c) 
       *     (let ((b (+ a 1)) 
       *           (d (make-vector 1000)))
       *       (if (> (s7-stack-size) max-stack)
       *           (set! max-stack (s7-stack-size)))
       *       (if (< b c) 
       *           (tc-1 b c))))
       * (tc-1 0 3200000) max-stack)
       * 4
       *
       * indicated (via "top") that the memory footprint was not growing, and the "4"
       * shows the stack was ok, so I currently believe that s7 is doing tail calls
       * correctly.
       */


      /* -------------------------------- macro evaluation -------------------------------- */

    case OP_EVAL_MACRO:    /* after (scheme-side) macroexpansion, evaluate the resulting expression */
      /* 
       * (define-macro (hi a) `(+ ,a 1))
       * (hi 2)
       * here with value: (+ 2 1)
       */
      sc->code = sc->value;
      goto EVAL;


      /* --------------- */
    case OP_EXPANSION:
      /* 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 (sc->value == sc->NO_VALUE)
	sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT;
      else annotate_expansion(sc, sc->value);
      goto START;


      /* --------------- */
    case OP_DEFMACRO:
    case OP_DEFMACRO_STAR:
      /* defmacro(*) could be defined in terms of define-macro(*), but I guess this gives us better error messages */
      check_defmacro(sc);

      if (symbol_has_accessor(car(sc->code)))
	{
	  sc->value = bind_accessed_symbol(sc, OP_DEFMACRO_WITH_ACCESSOR, car(sc->code), sc->code);
	  if (sc->value == sc->NO_VALUE)
	    goto APPLY;
	  sc->code = sc->value;
	}

    DEFMACRO2:
      sc->x = car(sc->code);
      sc->z = cdr(sc->code);
      sc->y = s7_gensym(sc, "defmac");
      /* (defmacro hi (a b) `(+ ,a ,b)) becomes:
       *   sc->x: hi
       *   code: (lambda (defmac-21) 
       *               (apply (lambda (a b) 
       *                        (cons (quote +) (cons a (cons b (quote ()))))) 
       *                      (cdr defmac-21)))
       * the (cdr defmac...) is an unfortunate historical accident that is now very tricky to fix.
       */
      NEW_CELL_NO_CHECK(sc, sc->value);
      closure_args(sc->value) = list_1(sc, sc->y);
      closure_body(sc->value) = list_1(sc, 
				       cons(sc, 
					    sc->Apply,
					    cons(sc, 
						 cons(sc, 
						      (sc->op == OP_DEFMACRO_STAR) ? sc->LAMBDA_STAR : sc->LAMBDA,
						      sc->z),
						 list_1(sc, list_2(sc, sc->CDR, sc->y)))));
      closure_environment(sc->value) = sc->envir;
      closure_setter(sc->value) = sc->F;
      closure_arity(sc->value) = CLOSURE_ARITY_NOT_SET;
      sc->capture_env_counter++;
      sc->code = sc->x;
      sc->y = sc->NIL;
      sc->z = sc->NIL;
      goto MACRO;


      /* --------------- */
    case OP_DEFMACRO_WITH_ACCESSOR:
      if (sc->value == sc->ERROR) /* backwards compatibility... */
	return(s7_error(sc, sc->ERROR,
			list_3(sc, make_protected_string(sc, "can't defmacro ~S to ~S"), car(sc->args), cadr(sc->args))));
      sc->code = sc->value;
      goto DEFMACRO2;


      /* --------------- */
    case OP_DEFINE_MACRO_WITH_ACCESSOR:
      if (sc->value == sc->ERROR) /* backwards compatibility... */
	return(s7_error(sc, sc->ERROR,
			list_3(sc, make_protected_string(sc, "can't define-macro ~S to ~S"), car(sc->args), cadr(sc->args))));
      sc->code = sc->value;
      goto DEFINE_MACRO2;


      /* --------------- */
    case OP_DEFINE_BACRO:
    case OP_DEFINE_BACRO_STAR:
    case OP_DEFINE_EXPANSION:
    case OP_DEFINE_MACRO:
    case OP_DEFINE_MACRO_STAR:
      check_define_macro(sc);

      if (symbol_has_accessor(caar(sc->code)))
	{
	  sc->value = bind_accessed_symbol(sc, OP_DEFINE_MACRO_WITH_ACCESSOR, caar(sc->code), sc->code);
	  if (sc->value == sc->NO_VALUE)
	    goto APPLY;
	  sc->code = sc->value;
	}

      /* (define-macro (hi a) `(+ ,a 1))
       *   in this case we want cadr, not caddr of defmacro
       */

    DEFINE_MACRO2:
      sc->x = caar(sc->code);
      sc->z = cdr(sc->code);
      sc->y = s7_gensym(sc, "defmac");
      /* (define-macro (hi a b) `(+ ,a ,b)) becomes:
       *   sc->x: hi
       *   sc->code: (lambda ({defmac}-14) (apply (lambda (a b) ({list} '+ a b)) (cdr {defmac}-14)))
       */
      NEW_CELL_NO_CHECK(sc, sc->value);
      closure_args(sc->value) = list_1(sc, sc->y);
      closure_body(sc->value) = list_1(sc, 
					 cons(sc, 
					      sc->Apply,
					      cons(sc, 
						   cons(sc, 
							((sc->op == OP_DEFINE_MACRO_STAR) || 
							 (sc->op == OP_DEFINE_BACRO_STAR)) ? sc->LAMBDA_STAR : sc->LAMBDA,
							cons(sc,                /* cdar(sc->code) is the parameter list */
							     ((sc->op == OP_DEFINE_MACRO_STAR) || 
							      (sc->op == OP_DEFINE_BACRO_STAR)) ? quotify(sc, cdar(sc->code)) : cdar(sc->code),
							     sc->z)),
						   list_1(sc, list_2(sc, sc->CDR, sc->y)))));
      closure_environment(sc->value) = sc->envir;
      closure_setter(sc->value) = sc->F;
      closure_arity(sc->value) = CLOSURE_ARITY_NOT_SET;
      sc->capture_env_counter++;
      sc->code = sc->x; 
      sc->y = sc->NIL;
      sc->z = sc->NIL;

    MACRO:
      /* symbol? macro name has already been checked */
      /* find name in environment, and define it */
      sc->x = find_local_symbol(sc, sc->envir, sc->code); 
      if (is_slot(sc->x))
	slot_set_value(sc->x, sc->value); 
      else s7_make_slot(sc, sc->envir, sc->code, sc->value); /* was current but we've checked immutable already */

      if ((sc->op == OP_DEFINE_BACRO) ||
	  (sc->op == OP_DEFINE_BACRO_STAR))
	set_type(sc->value, T_BACRO | T_DONT_EVAL_ARGS | T_COPY_ARGS);
      else
	{
	  if (sc->op == OP_DEFINE_EXPANSION)
	    {
	      /* perhaps define-expansion should be define-reader-macro but that collides with historical uses. 
	       */
	      set_type(sc->value, T_MACRO | T_EXPANSION | T_DONT_EVAL_ARGS | T_COPY_ARGS);
	      set_type(sc->code, EXPANSION_TYPE);
	    }
	  else set_type(sc->value, T_MACRO | T_DONT_EVAL_ARGS | T_COPY_ARGS); 
	}

      /* optimize here seems to be a no-op? */
      sc->value = sc->code;
      goto START;
      
      
      /* --------------- */
    case OP_LAMBDA: 
      /* code is a lambda form minus the "lambda": ((a b) (+ a b)) */
      /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */
      {
	s7_pointer code, body;
	code = sc->code;
	body = cdr(code);

	if ((!is_pair(code)) ||
	    (!is_pair(body)))                               /* (lambda) or (lambda #f) or (lambda . 1) */
	  eval_error(sc, "lambda: no args or no body? ~A", code);
	check_lambda_args(sc, car(code), NULL);
	
	/* in many cases, this is a no-op -- we already checked at define */

	/* why can't we optimize hop=1 here? 
	 */
	optimize(sc, body, 0, sc->NIL);

	if ((is_overlaid(code)) &&
	    (cdr(ecdr(code)) == code))
	  set_syntax_op(code, sc->LAMBDA_UNCHECKED);
      }

      /* --------------- */
    case OP_LAMBDA_UNCHECKED:
      MAKE_CLOSURE(sc, sc->value, car(sc->code), cdr(sc->code), sc->envir);
      goto START;


      /* --------------- */
    case OP_LAMBDA_STAR:
      if ((!is_pair(sc->code)) ||
	  (!is_pair(cdr(sc->code))))                                          /* (lambda*) or (lambda* #f) */
	eval_error(sc, "lambda*: no args or no body? ~A", sc->code);
      car(sc->code) = check_lambda_star_args(sc, car(sc->code), NULL);
      optimize(sc, cdr(sc->code), 0, sc->NIL);
      if ((is_overlaid(sc->code)) &&
	  (cdr(ecdr(sc->code)) == sc->code))
	set_syntax_op(sc->code, sc->LAMBDA_STAR_UNCHECKED);


      /* --------------- */
    case OP_LAMBDA_STAR_UNCHECKED:
      sc->value = make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE_STAR);
      goto START;
      



      /* -------------------------------- CASE -------------------------------- */

    case OP_CASE:      /* case, car(sc->code) is the selector */
      check_case(sc);


      /* --------------- */
    case OP_CASE_UNCHECKED:
      {
	s7_pointer carc;
	carc = car(sc->code);
	if (!is_pair(carc))
	  {
	    if (is_symbol(carc))
	      sc->value = finder(sc, carc);
	    else sc->value = carc;
	    sc->code = cdr(sc->code);
	    /* fall through */
	  }
	else
	  {
	    push_stack_no_args(sc, OP_CASE1, cdr(sc->code));
	    sc->code = carc;
	    goto EVAL; 
	  }
      }
      
    case OP_CASE1: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      {
	s7_pointer x, y;
	if (is_simple(sc->value))
	  {
	    for (x = sc->code; is_pair(x); x = cdr(x))
	      {
		y = caar(x);
		if (!is_pair(y))
		  goto ELSE_CASE;
		do {
		  if (car(y) == sc->value)
		    goto ELSE_CASE;
		  y = cdr(y);
		} while (is_pair(y));
	      }
	  }
	else
	  {
	    for (x = sc->code; is_pair(x); x = cdr(x)) 
	      {
		y = caar(x);
		if (!is_pair(y))
		  goto ELSE_CASE;
		for (; is_pair(y); y = cdr(y)) 
		  if (s7_is_eqv(car(y), sc->value)) 
		    goto ELSE_CASE;
	      }
	  }
	/* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */
      ELSE_CASE:
	if (is_not_null(x))
	  {
	    sc->code = cdar(x);
	    
	    /* check for => */
	    if ((car(sc->code) == sc->FEED_TO) &&
		(s7_symbol_value(sc, sc->FEED_TO) == sc->UNDEFINED))
	      {
		sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->QUOTE, sc->value)); 
		goto EVAL; 
	      }
	    if (is_pair(cdr(sc->code)))
	      push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	    sc->code = car(sc->code);
	    goto EVAL;
	  }
	
	/* no match found */
	sc->value = sc->UNSPECIFIED; /* this was sc->NIL but the spec says case value is unspecified if no clauses match */
	goto START;
      }


      /* --------------- */
    case OP_CASE_SIMPLE: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple, and no =>
       */
      {
	s7_pointer x, y, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  {
	    y = fcdr(x);
	    if (!is_pair(y)) /* else? */
	      {
		sc->code = cdar(x);
		if (is_pair(cdr(sc->code)))
		  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		sc->code = car(sc->code);
		goto EVAL;
	      }
	    do {
	      if (car(y) == selector)
		{
		  sc->code = cdar(x);
		  if (is_pair(cdr(sc->code)))
		    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		  sc->code = car(sc->code);
		  goto EVAL;
		}
	      y = cdr(y);
	    } while (is_pair(y));
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    case OP_CASE_SIMPLER: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple, and no => and no else
       */
      {
	s7_pointer x, y, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  {
	    y = fcdr(x);
	    do {
	      if (car(y) == selector)
		{
		  sc->code = cdar(x);
		  if (is_pair(cdr(sc->code)))
		    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
		  sc->code = car(sc->code);
		  goto EVAL;
		}
	      y = cdr(y);
	    } while (is_pair(y));
	  }
	sc->value = sc->UNSPECIFIED;
	IF_BEGIN_POP_STACK(sc);
      }


      /* --------------- */
    case OP_CASE_SIMPLER_1: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple, and no => and no else, bodies are 1 liners
       */
      {
	s7_pointer x, y, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  {
	    y = fcdr(x);
	    do {
	      if (car(y) == selector)
		{
		  sc->code = ecdr(x); /* cadar(x); */
		  goto EVAL;
		}
	      y = cdr(y);
	    } while (is_pair(y));
	  }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    case OP_CASE_SIMPLER_SS: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume hop_safe_ss as selector, all keys are simple, and no => and no else, bodies are 1 liners
       */
      {
	s7_pointer x, y, selector, args;
	args = cdar(sc->code);
	x = finder(sc, car(args));
	car(sc->T2_2) = finder(sc, cadr(args));
	car(sc->T2_1) = x;
	selector = c_call(car(sc->code))(sc, sc->T2_1);

	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  {
	    y = fcdr(x);
	    do {
	      if (car(y) == selector)
		{
		  sc->code = ecdr(x); /* cadar(x); */
		  goto EVAL;
		}
	      y = cdr(y);
	    } while (is_pair(y));
	  }
	sc->value = sc->UNSPECIFIED;
	IF_BEGIN_POP_STACK(sc);
      }


      /* --------------- */
    case OP_CASE_SIMPLEST_SS:
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      {
	s7_pointer x, selector, args;
	args = cdar(sc->code);
	x = finder(sc, car(args));
	car(sc->T2_2) = finder(sc, cadr(args));
	car(sc->T2_1) = x;
	selector = c_call(car(sc->code))(sc, sc->T2_1);
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  if (fcdr(x) == selector)
	    {
	      sc->code = cdar(x);
	      if (is_pair(cdr(sc->code)))
		push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	      sc->code = car(sc->code);
	      goto EVAL;
	    }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }
      

      /* --------------- */
    case OP_CASE_SIMPLEST: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple and singletons, and no => and no else, bodies are 1 liners
       */
      {
	s7_pointer x, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  if (fcdr(x) == selector)
	    {
	      sc->code = ecdr(x); /* cadar(x); */ 
	      goto EVAL;
	    }
	sc->value = sc->UNSPECIFIED;
	goto START;
      }


      /* --------------- */
    case OP_CASE_SIMPLEST_ELSE: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple and singletons, and no =>, bodies are 1 liners
       */
      {
	s7_pointer x, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  if (fcdr(x) == selector)
	    {
	      sc->code = cadar(x); /* ecdr(x); */
	      goto EVAL;
	    }
	sc->code = gcdr(sc->code);
	goto EVAL;
      }


      /* --------------- */
    case OP_CASE_SIMPLEST_ELSE_C: 
      /* fprintf(stderr, "%s: %s\n", real_op_names[sc->op], DISPLAY(sc->code)); */
      /* assume symbol as selector, all keys are simple and singletons, and no =>, bodies are constants
       */
      {
	s7_pointer x, selector;
	selector = finder(sc, car(sc->code));
	for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	  if (fcdr(x) == selector)
	    {
	      sc->value = cadar(x); /* ecdr(x); but that requires setup in optimizer */
	      if (is_pair(sc->value))
		sc->value = cadr(sc->value);
	      goto START;
	    }
	sc->code = gcdr(sc->code);
	goto EVAL;
      }



      /* --------------- */
    case OP_ERROR_QUIT: 
    case OP_EVAL_DONE:
      /* this is the "time to quit" operator */
      return(sc->F);
      break;
      

      /* --------------- */
    case OP_BARRIER:
    case OP_CATCH_ALL:
    case OP_CATCH:
    case OP_CATCH_1:
      goto START;


      /* --------------- */
    case OP_DEACTIVATE_GOTO:
      call_exit_active(sc->args) = false;      /* as we leave the call-with-exit body, deactivate the exiter */
      goto START;


      /* --------------- */
    case OP_ERROR_HOOK_QUIT:
      sc->error_hook = sc->code;  /* restore old value */

      /* 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);
      sc->op = OP_ERROR_QUIT;
      if (sc->longjmp_ok)
	{
	  longjmp(sc->goto_start, 1);
	}
      return(sc->value); /* not executed I hope */

      
      /* --------------- */
    case OP_GET_OUTPUT_STRING:          /* from call-with-output-string and with-output-to-string -- return the string */
      sc->value = s7_make_string(sc, s7_get_output_string(sc, sc->code));
      goto START;


      /* --------------- */
    case OP_UNWIND_OUTPUT:
      {
	bool is_file;
	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->output_port = sc->args;
       
       if (is_file)
	 {
	   if (is_multiple_value(sc->value)) 
	     sc->value = splice_in_values(sc, multiple_value(sc->value));
	 }
       goto START;
      }


      /* --------------- */
    case OP_UNWIND_INPUT:
      if ((is_input_port(sc->code)) &&
	  (!port_is_closed(sc->code)))
	s7_close_input_port(sc, sc->code);

      if ((is_input_port(sc->args)) &&
	  (!port_is_closed(sc->args)))
	sc->input_port = sc->args;

      if (is_multiple_value(sc->value)) 
	sc->value = splice_in_values(sc, multiple_value(sc->value));
      goto START;


      /* --------------- */
    case OP_DYNAMIC_WIND:
      if (dynamic_wind_state(sc->code) == DWIND_INIT)
	{
	  dynamic_wind_state(sc->code) = DWIND_BODY;
	  push_stack(sc, OP_DYNAMIC_WIND, sc->NIL, sc->code);
	  sc->args = sc->NIL;
	  sc->code = dynamic_wind_body(sc->code);
	  goto APPLY;
	}
      else
	{
	  if (dynamic_wind_state(sc->code) == DWIND_BODY)
	    {
	      dynamic_wind_state(sc->code) = DWIND_FINISH;
	      if (dynamic_wind_out(sc->code) != sc->F)
		{
		  push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code);
		  sc->args = sc->NIL;
		  sc->code = dynamic_wind_out(sc->code);
		  goto APPLY;
		}
	      else
		{
		  if (is_multiple_value(sc->value))
		    sc->value = splice_in_values(sc, multiple_value(sc->value));
		  goto START;
		}
	    }
	  /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */
	  if (is_multiple_value(sc->args))
	    sc->value = splice_in_values(sc, multiple_value(sc->args));
	  else sc->value = sc->args;                         /* value saved above */ 
	  goto START;
	}
      break;


      /* -------------------------------- with-environment -------------------------------- */

    case OP_WITH_ENV_S:
      {
	s7_pointer e;
	e = finder(sc, car(sc->code));
	if (e == sc->global_env)
	  sc->envir = sc->NIL;
	else 
	  {
	    s7_pointer p;
	    if (!is_environment(e))
	      eval_error(sc, "with-environment takes an environment argument: ~A", e);
	    environment_id(e) = ++environment_number;
	    sc->envir = e;
	    for (p = environment_slots(e); is_slot(p); p = next_slot(p))
	      {
		s7_pointer sym;
		sym = slot_symbol(p);
		symbol_set_local(sym, environment_number, p);
	      }
	  }
	e = cdr(sc->code);
	if (is_pair(cdr(e)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(e));
	sc->code = car(e);
	goto EVAL;
      }
      

      /* --------------- */
    case OP_WITH_ENV:
      check_with_env(sc);


      /* --------------- */
    case OP_WITH_ENV_UNCHECKED:
      sc->value = car(sc->code);
      if (!is_pair(sc->value))
	{
	  if (is_symbol(sc->value))
	    sc->value = finder(sc, sc->value);
	  sc->code = cdr(sc->code);

	  if (!is_pair(sc->code))
	    {
	      if (!is_environment(sc->value))            /* (with-environment e abs) */
		eval_error(sc, "with-environment takes an environment argument: ~A", sc->value);
	      if (is_symbol(sc->code))
		sc->value = s7_symbol_local_value(sc, sc->code, sc->value);
	      else sc->value = sc->code;
	      goto START;
	    }
	  /* else fall through */
	}
      else
	{
	  push_stack(sc, OP_WITH_ENV1, sc->NIL, cdr(sc->code));
	  sc->code = sc->value;                          /* eval env arg */
	  goto EVAL;
	}

      
      /* --------------- */
    case OP_WITH_ENV1:
      {
	s7_pointer e;
	e = sc->value;
	if (!is_environment(e))                    /* (with-environment . "hi") */
	  eval_error(sc, "with-environment takes an environment argument: ~A", e);
	if (e == sc->global_env)
	  sc->envir = sc->NIL;                             /* (with-environment (global-environment) ...) */
	else 
	  {
	    s7_pointer p;
	    environment_id(e) = ++environment_number;
	    sc->envir = e;
	    for (p = environment_slots(e); is_slot(p); p = next_slot(p))
	      symbol_set_local(slot_symbol(p), environment_number, p);
	  }
	if (is_pair(cdr(sc->code)))
	  push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	sc->code = car(sc->code);
	goto EVAL;
      }


      /* --------------- */
    case OP_WITH_BAFFLE:
      NEW_FRAME(sc, sc->envir, sc->envir);
      add_slot(sc, sc->BAFFLE, make_baffle(sc));
      /* sc->code (the body) is ready to go */
      goto BEGIN;



      /* -------------------------------- the reader -------------------------------- */

    READ_LIST:
    case OP_READ_LIST: 
      /* sc->args is sc->NIL at first */
      /*    was: sc->args = cons(sc, sc->value, sc->args); */ 
      {
	s7_pointer x;
	NEW_CELL(sc, x);
	car(x) = sc->value;
	cdr(x) = sc->args;
	set_type(x, T_PAIR);
	sc->args = x;
      }
      
    case OP_READ_NEXT:
      /* sc->tok = token(sc); */
      /* this is 75% of the token calls, so expanding it saves lots of time */
      {
	int c;
	s7_pointer pt;

	pt = sc->input_port;
	c = port_read_white_space(pt)(sc, pt);

	switch (c) 
	  {
	  case '(':
	    sc->tok = token(sc);

	    if (sc->tok == TOKEN_ATOM)
	      {
		push_stack_no_code(sc, OP_READ_LIST, sc->args);
		CHECK_STACK_SIZE(sc);
		sc->value = port_read_name(sc->input_port)(sc, sc->input_port, NO_SHARP);
		sc->args = sc->NIL;
		goto READ_LIST;
	      }

	    /* after atom, nearly all remaining cases are left paren; can we do it directly?
	     */

	    if (sc->tok == TOKEN_RIGHT_PAREN)
	      {
		sc->value = sc->NIL;
		goto READ_LIST;
	      }
	    
	    if (sc->tok == TOKEN_DOT) 
	      {
		do {c = inchar(sc->input_port);} while ((c != ')') && (c != EOF));
		return(read_error(sc, "stray dot after '('?"));         /* (car '( . )) */
	      }
	    
	    if (sc->tok == TOKEN_EOF)
	      return(missing_close_paren_error(sc));
	    
	    push_stack_no_code(sc, OP_READ_LIST, sc->args);
	    CHECK_STACK_SIZE(sc);
	    push_stack_no_code(sc, OP_READ_LIST, sc->NIL);
	    sc->value = read_expression(sc);
	    goto START;

      
	  case ')':
	    sc->tok = TOKEN_RIGHT_PAREN;
	    break;
	    
	  case '.':
	    sc->tok = read_dot(sc, pt); /* dot or atom */
	    break;
	    
	  case '\'':
	    sc->tok = TOKEN_QUOTE;
	    push_stack_no_code(sc, OP_READ_LIST, sc->args);
	    sc->value = read_expression(sc);
	    goto START;
	    
	  case ';':
	    sc->tok = port_read_semicolon(pt)(sc, pt);
	    break;
	    
	  case '"':
	    sc->tok = TOKEN_DOUBLE_QUOTE;
	    sc->value = read_string_constant(sc, sc->input_port);
	    if (sc->value == sc->F)                                /* can happen if input code ends in the middle of a string */
	      return(read_error(sc, "end of input encountered while in a string"));
	    if (sc->value == sc->T)
	      return(read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"));
	    goto READ_LIST;
	    
	  case '`':
	    sc->tok = TOKEN_BACK_QUOTE;
	    push_stack_no_code(sc, OP_READ_LIST, sc->args);
	    sc->value = read_expression(sc);
	    goto START;
	    
	  case ',':
	    sc->tok = read_comma(sc, pt); /* at_mark or comma */
	    push_stack_no_code(sc, OP_READ_LIST, sc->args);
	    sc->value = read_expression(sc);
	    goto START;
	    
	  case '#':
	    sc->tok = read_sharp(sc, pt);
	    break;

	  case EOF:
	    return(missing_close_paren_error(sc));
	    
	  default: 
	    sc->strbuf[0] = c; 
	    sc->value = port_read_name(pt)(sc, pt, NO_SHARP);
	    goto READ_LIST;
	  }
      }

    READ_TOK:
      switch (sc->tok)
	{
	case TOKEN_RIGHT_PAREN:
	  /* sc->args can't be null here */
	  
	  sc->value = safe_reverse_in_place(sc, sc->args);
	  pair_line_number(sc->value) = port_line_number(sc->input_port) | (port_file_number(sc->input_port) << 20);
	  set_has_line_number(sc->value);
	  /* I think sc->input_port can't be nil -- it falls back on stdin now */

	  /* read-time macro expansion
	   *
	   *   (defmacro hi (a) (format #t "hi...") `(+ ,a 1))
	   *   (define (ho b) (+ 1 (hi b)))
	   *
	   * here sc->value is: (ho b), (hi b), (+ 1 (hi b)), (define (ho b) (+ 1 (hi b)))
	   * 
	   * but... first we can't tell for sure at this point that "hi" really is a macro
	   *
	   *   (letrec ((hi ... (hi...))) will be confused about the second hi,
	   *   or (call/cc (lambda (hi) (hi 1))) etc.
	   *
	   * second, figuring out that we're quoted is not easy -- we have to march all the
	   * way to the bottom of the stack looking for op_read_quote or op_read_vector
	   *
	   *    #(((hi)) 2) or '(((hi)))
	   *
	   * or op_read_list with args not equal (quote) or (macroexapand)
	   *
	   *    '(hi 3) or (macroexpand (hi 3) or (quote (hi 3))
	   *
	   * and those are only the problems I noticed!
	   *
	   * The hardest of these problems involve shadowing, so Rick asked for "define-expansion"
	   *   which is just like define-macro, but the programmer guarantees that the macro
	   *   name will not be shadowed.  So I'll also assume that the other funny cases are
	   *   being avoided -- see what happens!
	   *
	   *   (define-expansion (hi a) `(+ ,a 1))
	   *   (define (ho b) (+ 1 (hi b)))
	   *   (procedure-source ho) -> (lambda (b) (+ 1 (+ b 1)))
	   */
	  
	  if (is_expansion(car(sc->value)))                                  /* was checking the T_EXPANSION bit (car(sc->value) is a symbol) */
	    {
	      int loc;

	      loc = s7_stack_top(sc) - 1;
	      if ((loc >= 3) &&
		  (stack_op(sc->stack, loc) != OP_READ_QUOTE) &&             /* '(hi 1) for example */
		  (car(stack_args(sc->stack, loc)) != sc->QUOTE) &&          /* (quote (hi 1)) */
		  (car(stack_args(sc->stack, loc)) != sc->MACROEXPAND))      /* (macroexpand (hi 1)) */
		{
		  push_stack(sc, OP_EXPANSION, sc->NIL, sc->NIL);
		  sc->code = slot_value(find_symbol(sc, car(sc->value)));
		  sc->args = list_1(sc, sc->value); 
		  goto APPLY;
		}
	    }
	  
	  if ((is_symbol(car(sc->value))) &&
	      (is_pair(cdr(sc->value))))
	    {
	      set_ecdr(cdr(sc->value), sc->value);
	      set_overlay(cdr(sc->value));
	    }
	  /* I think it's too soon to scan every list at this point for symbols and pairs */
	  break;

	case TOKEN_EOF:
	  /* can't happen, I believe */
	  return(missing_close_paren_error(sc));

	case TOKEN_ATOM:
	  sc->value = port_read_name(sc->input_port)(sc, sc->input_port, NO_SHARP);
	  goto READ_LIST;
	  break;

	case TOKEN_SHARP_CONST:
	  sc->value = port_read_name(sc->input_port)(sc, sc->input_port, WITH_SHARP);
	  if (is_null(sc->value))
	    return(read_error(sc, "undefined # expression"));
	  if (sc->value == sc->NO_VALUE)
	    {
	      /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*))
	       * (+ 1 #;(* 2 3) 4)
	       * so we need to get the next token, act on it without any assumptions about read list
	       */
	      sc->tok = token(sc);
	      goto READ_TOK;
	    }
	  goto READ_LIST;
	  break;

	case TOKEN_DOUBLE_QUOTE:
	  sc->value = read_string_constant(sc, sc->input_port);
	  if (sc->value == sc->F)                                /* can happen if input code ends in the middle of a string */
	    return(read_error(sc, "end of input encountered while in a string"));
	  if (sc->value == sc->T)
	    return(read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"));
	  goto READ_LIST;
	  break;

	case TOKEN_DOT:
	  push_stack_no_code(sc, OP_READ_DOT, sc->args);
	  sc->tok = token(sc);
	  sc->value = read_expression(sc);
	  break;

	default:
	  /* 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_code(sc, OP_READ_LIST, sc->args);
	  sc->value = read_expression(sc);
	  /* check for op_read_list here and explicit pop_stack are slower */
	  break;
	}
      goto START;

      
      /* --------------- */
    case OP_READ_DOT:
      if (token(sc) != TOKEN_RIGHT_PAREN)
	{
	  back_up_stack(sc);
	  read_error(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)
       *
       * so we have to leave any error checks until later, I guess
       *   -- in eval_args1, if we end with non-pair-not-nil then
       *      something is fishy
       */
      sc->value = reverse_in_place(sc, sc->value, sc->args);
      goto START;
      
      
      /* --------------- */
    case OP_READ_QUOTE:
      /* can't check for sc->value = sc->NIL here because we want ''() to be different from '() */
      sc->value = list_2(sc, sc->QUOTE, sc->value);
      set_ecdr(cdr(sc->value), sc->value);
      set_overlay(cdr(sc->value));
      goto START;      
      
      
      /* --------------- */
    case OP_READ_QUASIQUOTE:
      /* this was pushed when the backquote was seen, then eventually we popped back to it */
      sc->value = g_quasiquote_1(sc, sc->value);
      /* 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.
       */
      goto START;
      
      
      /* --------------- */
    case OP_READ_VECTOR:
      if (!is_proper_list(sc, sc->value))       /* #(1 . 2) */
	return(read_error(sc, "vector constant data is not a proper list"));
      if (sc->args == small_int(1))             /* sc->args was sc->w earlier from read_sharp */
	sc->value = g_vector(sc, sc->value);
      else sc->value = g_multivector(sc, s7_integer(sc->args), sc->value);
      goto START;

      
      /* --------------- */
    case OP_READ_BYTEVECTOR:
      if (!is_proper_list(sc, sc->value))       /* #u8(1 . 2) */
	return(read_error(sc, "bytevector constant data is not a proper list"));
      sc->value = g_bytevector(sc, sc->value);
      goto START;

      
      /* --------------- */
#if WITH_QUASIQUOTE_VECTOR
    case OP_READ_QUASIQUOTE_VECTOR:
      /* this works only if the quasiquoted list elements can be evaluated in the read-time environment.
       *
       *    `#(1 ,@(list 1 2) 4) -> (apply vector ({list} 1 ({apply_values} (list 1 2)) 4)) -> #(1 1 2 4)
       *
       * Originally, I used:
       *
       *   sc->value = list_3(sc, sc->Apply, sc->Vector, g_quasiquote_1(sc, sc->value));
       *   goto START;
       *
       * which means that #(...) makes a vector at read time, but `#(...) is just like (vector ...).
       *
       *   :(let ((f1 (lambda () (let ((x 32)) #(x 0))))
       *          (f2 (lambda () (let ((x 32)) `#(,x 0)))))
       *      (eq? (f1) (f1)))
       *   #t
       *   :(let ((f1 (lambda () (let ((x 32)) #(x 0))))
       *          (f2 (lambda () (let ((x 32)) `#(,x 0)))))
       *      (eq? (f2) (f2)))
       *   #f
       *
       * The tricky part in s7 is that we might have quasiquoted multidimensional vectors
       */
      if (sc->args == small_int(1))
	sc->code = list_3(sc, sc->Apply, sc->Vector, g_quasiquote_1(sc, sc->value)); /* qq result will be evaluated (might include {list} etc) */
      else sc->code = list_4(sc, sc->Apply, sc->Multivector, sc->args, g_quasiquote_1(sc, sc->value));
      goto EVAL; 
#endif

      
      /* --------------- */
    case OP_READ_UNQUOTE:
      /* here if sc->value is a constant, the unquote is pointless */
      if ((is_pair(sc->value)) ||
	  (is_symbol(sc->value)))
	sc->value = list_2(sc, sc->UNQUOTE, sc->value);
      goto START;
      
      
      /* --------------- */
    case OP_READ_APPLY_VALUES:
      if (is_symbol(sc->value))
	{
	  s7_pointer lst;
	  lst = list_2(sc, sc->QQ_Apply_Values, sc->value);
	  set_unsafely_optimized(lst);
	  set_optimize_data(lst, HOP_C_S);
	  set_c_function(lst, sc->QQ_Apply_Values);
	  sc->value = list_2(sc, sc->UNQUOTE, lst);
	}
      else sc->value = list_2(sc, sc->UNQUOTE, list_2(sc, sc->QQ_Apply_Values, sc->value));
      goto START;
      
      
      /* --------------- */
    default:
      fprintf(stderr, "unknown operator: %d, %s in %s\n", 
	      (int)(sc->op), 
	      (((int)(sc->op) < OP_MAX_DEFINED) && ((int)(sc->op) >= 0)) ? op_names[(int)(sc->op)] : "?",
	      DISPLAY(sc->cur_code));
      return(sc->F);
    }

  return(sc->F);
}

#if WITH_GCC
#undef NEW_CELL
#define NEW_CELL(Sc, Obj) \
  do {						\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
    Obj = (*(--(Sc->free_heap_top))); \
    } while (0)
#endif



/* -------------------------------- multiprecision arithmetic -------------------------------- */

#if WITH_GMP

static mp_prec_t mpc_precision = 128;
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 void mpc_init_set(mpc_ptr z, mpc_ptr y, mpc_rnd_t rnd)
{
  mpc_init(z);
  mpc_set(z, y, rnd);
}


mpfr_t *s7_big_real(s7_pointer x)    {return(&big_real(x));}
mpz_t  *s7_big_integer(s7_pointer x) {return(&big_integer(x));}
mpq_t  *s7_big_ratio(s7_pointer x)   {return(&big_ratio(x));}
mpc_t  *s7_big_complex(s7_pointer x) {return(&big_complex(x));}

static char *mpfr_to_string(mpfr_t val, int radix)
{
  char *str, *tmp, *str1;
  mp_exp_t expptr;
  int i, len, ep;

  if (mpfr_zero_p(val))
    return(copy_string("0.0"));

  if (mpfr_nan_p(val))
    return(copy_string("nan.0"));
  if (mpfr_inf_p(val))
    {
      if (mpfr_signbit(val) == 0)
	return(copy_string("inf.0"));
      return(copy_string("-inf.0"));
    }

  str1 = mpfr_get_str(NULL, &expptr, radix, 0, val, GMP_RNDN);
  /* 0 -> full precision, but it's too hard to make this look like C formatted output.
   *  
   *  :(format #f "~,3F" pi)
   *  "3.141592653589793238462643383279502884195E0" 
   *  :(format #f "~,3F" 1.1234567890123)  ; not a bignum
   *  "1.123"
   *  :(format #f "~,3F" 1.12345678901234) ; a bignum
   *  "1.123456789012339999999999999999999999999E0"
   * 
   * but we don't know the exponent or the string length until after we call mpfr_get_str.
   */

  str = str1;
  ep = (int)expptr;
  len = safe_strlen(str);

  if (radix <= 10)
    {
      /* remove trailing 0's */
      for (i = len - 1; i > 3; i--)
	if (str[i] != '0')
	  break;
      if (i < len - 1)
	str[i + 1] = '\0';

      len += 64;
      tmp = (char *)malloc(len * sizeof(char));
  
      if (str[0] == '-')
	snprintf(tmp, len, "-%c.%sE%d", str[1], (char *)(str + 2), ep - 1);
      else snprintf(tmp, len, "%c.%sE%d", str[0], (char *)(str + 1), ep - 1);
    }
  else
    {
      /* if radix > 10, we should not be using the 'E' business -- need to move the decimal point */
      /* (number->string 1234.5678909876543212345 16) "4d2.91614dc3ab1f80e55a563311b8f308"
       * (number->string -1234.5678909876543212345 16) "-4d2.91614dc3ab1f80e55a563311b8f308"
       * (number->string 1234.5678909876543212345e8 16) "1cbe991a6a.c3f35c11868cb7e3fb75536"
       * (number->string 1234.5678909876543212345e-8 16) "0.0000cf204983a27e1eff701c562a870641e50"
       * (number->string 123456789098765432.12345e-8 16) "499602d2.fcd6e9e1748ba5adccc12c5a8"
       * (number->string 123456789098765432.1e20 16) "949b0f70beeac8895e74b18b9680000.00"
       */
      int loc = 0;
      tmp = (char *)calloc(len + ep + 64, sizeof(char));
      if (str[0] == '-')
	tmp[loc++] = (*str++);
      if (ep < 0)
	{
	  ep = -ep;
	  tmp[loc++] = '0';
	  tmp[loc++] = '.';
	  for (i = 0; i < ep; i++)
	    tmp[loc++] = '0';
	}
      else
	{
	  for (i = 0; i < ep; i++)
	    tmp[loc++] = (*str++);
	  tmp[loc++] = '.';
	}
      while (*str) tmp[loc++] = (*str++);
    }
  mpfr_free_str(str1);
  return(tmp);
}


static char *mpc_to_string(mpc_t val, int radix, use_write_t use_write)
{
  char *rl, *im, *tmp;
  int len;
  mpfr_t a, b;

  mpfr_init(a);
  mpc_real(a, val, GMP_RNDN);
  rl = mpfr_to_string(a, radix);
  mpfr_init(b);
  mpc_imag(b, val, GMP_RNDN);
  im = mpfr_to_string(b, radix);

  len = safe_strlen(rl) + safe_strlen(im) + 128;
  tmp = (char *)malloc(len * sizeof(char));
  
  if (use_write == USE_READABLE_WRITE)
    snprintf(tmp, len, "(make-rectangular %s %s)", rl, im);
  else snprintf(tmp, len, "%s%s%si", rl, (im[0] == '-') ? "" : "+", im); 

  free(rl);
  free(im);
  return(tmp);
}


static char *big_number_to_string_with_radix(s7_pointer p, int radix, int width, int *nlen, use_write_t use_write)
{
  char *str = NULL;

  switch (type(p))
    {
    case T_BIG_INTEGER:
      str = mpz_get_str(NULL, radix, big_integer(p));
      break;

    case T_BIG_RATIO:
      str = mpq_get_str(NULL, radix, big_ratio(p));
      break;

    case T_BIG_REAL:
      str = mpfr_to_string(big_real(p), radix);
      break;

    default:
      str = mpc_to_string(big_complex(p), radix, use_write);
      break;
    }

  if (width > 0)
    {
      int len;
      len = safe_strlen(str);
      if (width > len)
	{
	  int spaces;
	  str = (char *)realloc(str, (width + 1) * sizeof(char));
	  spaces = width - len;
	  str[width] = '\0';
	  memmove((void *)(str + spaces), (void *)str, len);    
	  memset((void *)str, (int)' ', spaces);
	  (*nlen) = width;
	}
      else (*nlen) = len;
    }
  return(str);
}


static bool s7_is_one_or_big_one(s7_pointer p)
{
  bool result = false;

  if (!is_big_number(p))
    return(s7_is_one(p));

  if (type(p) == T_BIG_INTEGER)
    {
      mpz_t n;
      mpz_init_set_si(n, 1);
      result = (mpz_cmp(n, big_integer(p)) == 0);
      mpz_clear(n);
    }
  else
    {
      if (type(p) == T_BIG_REAL)
	{
	  mpfr_t n;
	  mpfr_init_set_d(n, 1.0, GMP_RNDN);
	  result = (mpfr_cmp(n, big_real(p)) == 0);
	  mpfr_clear(n);
	}
    }
  return(result);
}


static s7_pointer string_to_big_integer(s7_scheme *sc, const char *str, int radix)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_INTEGER);
  add_bigint(sc, x);
  mpz_init_set_str(big_integer(x), (str[0] == '+') ? (const char *)(str + 1) : str, radix);

  return(x);
}


static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_INTEGER);
  add_bigint(sc, x);
  mpz_init_set(big_integer(x), val);

  return(x);
}


s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val)
{
  return(mpz_to_big_integer(sc, *val));
}


static s7_pointer string_to_big_ratio(s7_scheme *sc, const char *str, int radix)
{
  s7_pointer x;
  mpq_t n;

  mpq_init(n);
  mpq_set_str(n, str, radix);
  mpq_canonicalize(n);

  if (mpz_cmp_ui(mpq_denref(n), 1) == 0)
    x = mpz_to_big_integer(sc, mpq_numref(n));
  else
    {
      NEW_CELL(sc, x);
      set_type(x, T_BIG_RATIO);
      add_bigratio(sc, x);
      mpq_init(big_ratio(x));
      mpq_set_num(big_ratio(x), mpq_numref(n));
      mpq_set_den(big_ratio(x), mpq_denref(n));
    }

  mpq_clear(n);
  return(x);
}


static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_RATIO);
  add_bigratio(sc, x);
  mpq_init(big_ratio(x));
  mpq_set_num(big_ratio(x), mpq_numref(val));
  mpq_set_den(big_ratio(x), mpq_denref(val));
  
  return(x);
}


s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val)
{
  return(mpq_to_big_ratio(sc, *val));
}


static s7_pointer mpz_to_big_ratio(s7_scheme *sc, mpz_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_RATIO);
  add_bigratio(sc, x);
  mpq_init(big_ratio(x));
  mpq_set_num(big_ratio(x), val);
  
  return(x);
}


static s7_pointer make_big_integer_or_ratio(s7_scheme *sc, s7_pointer z)
{
  if (mpz_cmp_ui(mpq_denref(big_ratio(z)), 1) == 0)
    return(mpz_to_big_integer(sc, mpq_numref(big_ratio(z))));
  return(z);
}


static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int radix)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);
  mpfr_init_set_str(big_real(x), str, radix, GMP_RNDN);

  return(x);
}

static void mpz_init_set_s7_Int(mpz_t n, s7_Int uval);

static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer p)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);

  switch (type(p))
    {
    case T_INTEGER: 
      {
	s7_Int val;
	val = s7_integer(p);
	if ((val <= S7_LONG_MAX) && (val >= S7_LONG_MIN))
	  mpfr_init_set_si(big_real(x), (int)val, GMP_RNDN);
	else mpfr_init_set_ld(big_real(x), (long double)val, GMP_RNDN);
      }
      break;

    case T_RATIO:
      /* here we can't use fraction(number(p)) even though that uses long double division because
       *   there are lots of long long int ratios that will still look the same.
       *   We have to do the actual bignum divide by hand.
       */
      {
	mpq_t rat;
	mpz_t n1, d1;

	mpz_init_set_s7_Int(n1, numerator(p));
	mpz_init_set_s7_Int(d1, denominator(p));
	mpq_init(rat);

	mpq_set_num(rat, n1);
	mpq_set_den(rat, d1);
	mpq_canonicalize(rat);
	mpfr_init_set_q(big_real(x), rat, GMP_RNDN);

	mpz_clear(n1);
	mpz_clear(d1);
	mpq_clear(rat);
      }
      break;

    default:
      mpfr_init_set_d(big_real(x), s7_real(p), GMP_RNDN);
      break;
    }

  return(x);
}


static s7_pointer mpz_to_big_real(s7_scheme *sc, mpz_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);
  mpfr_init_set_z(big_real(x), val, GMP_RNDN);

  return(x);
}


static s7_pointer mpq_to_big_real(s7_scheme *sc, mpq_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);
  mpfr_init_set_q(big_real(x), val, GMP_RNDN);

  return(x);
}


static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);
  mpfr_init_set(big_real(x), val, GMP_RNDN);

  return(x);
}


s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val)
{
  return(mpfr_to_big_real(sc, *val));
}


static s7_pointer big_pi(s7_scheme *sc)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_REAL);
  add_bigreal(sc, x);
  mpfr_init(big_real(x));
  mpfr_const_pi(big_real(x), GMP_RNDN);
  
  return(x);
}


static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer p)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));

  switch (type(p))
    {
    case T_INTEGER:
      {
	s7_Int val;
	val = s7_integer(p);
	if ((val <= S7_LONG_MAX) && (val >= S7_LONG_MIN))
	  mpc_set_si(big_complex(x), (long int)val, MPC_RNDNN);
	else mpc_set_d(big_complex(x), (double)val, MPC_RNDNN);
      }
      break;

    case T_RATIO:
      /* can't use fraction here */
      {
	mpfr_t temp;
	mpq_t rat;
	mpz_t n1, d1;

	mpz_init_set_s7_Int(n1, numerator(p));
	mpz_init_set_s7_Int(d1, denominator(p));
	mpq_init(rat);

	mpq_set_num(rat, n1);
	mpq_set_den(rat, d1);
	mpq_canonicalize(rat);
	mpfr_init_set_q(temp, rat, GMP_RNDN);
	mpc_set_fr(big_complex(x), temp, MPC_RNDNN);

	mpz_clear(n1);
	mpz_clear(d1);
	mpq_clear(rat);
	mpfr_clear(temp);
      }
      break;

    case T_REAL:
      mpc_set_d(big_complex(x), s7_real(p), MPC_RNDNN);
      break;

    default:
      mpc_set_d_d(big_complex(x), real_part(p), imag_part(p), MPC_RNDNN);
      break;
    }
  return(x);
}


static s7_pointer make_big_real_or_complex(s7_scheme *sc, s7_pointer z)
{
  double ipart;

  ipart = mpfr_get_d(mpc_imagref(big_complex(z)), GMP_RNDN);
  /* not mpfr_cmp_ui to 0 here because that misleads us when imag_part is NaN or inf */
  if (ipart == 0.0)
    return(mpfr_to_big_real(sc, mpc_realref(big_complex(z))));
  return(z);
}


static s7_pointer mpz_to_big_complex(s7_scheme *sc, mpz_t val)
{
  mpfr_t temp;
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));
  mpfr_init_set_z(temp, val, GMP_RNDN);
  mpc_set_fr(big_complex(x), temp, MPC_RNDNN);

  mpfr_clear(temp);
  return(x);
}


static s7_pointer mpq_to_big_complex(s7_scheme *sc, mpq_t val)
{
  mpfr_t temp;
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));
  mpfr_init_set_q(temp, val, GMP_RNDN);
  mpc_set_fr(big_complex(x), temp, MPC_RNDNN);

  mpfr_clear(temp);
  return(x);
}


static s7_pointer mpfr_to_big_complex(s7_scheme *sc, mpfr_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));
  mpc_set_fr(big_complex(x), val, MPC_RNDNN);

  return(x);
}


static s7_pointer mpc_to_big_complex(s7_scheme *sc, mpc_t val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));
  mpc_set(big_complex(x), val, MPC_RNDNN);

  return(x);
}


s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val)
{
  return(mpc_to_big_complex(sc, *val));
}


static s7_pointer make_big_complex(s7_scheme *sc, mpfr_t rl, mpfr_t im)
{
  /* there is no mpc_get_str equivalent, so we need to split up str,
   *   use make_big_real to get the 2 halves, then mpc_init, then
   *   mpc_set_fr_fr.
   */
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));
  mpc_set_fr_fr(big_complex(x), rl ,im, MPC_RNDNN);

  return(x);
}


/* gmp.h mpz_init_set_si the "si" part is "signed long int", so in the 64-bit case,
 *   s7_Int already fits.  I guess we can catch this (since no configure script)
 *   by noticing that sizeof(s7_Int) == sizeof(long int).
 */

static void mpz_init_set_s7_Int(mpz_t n, s7_Int uval)
{
  if (sizeof(s7_Int) == sizeof(long int))
    mpz_init_set_si(n, uval);
  else
    {
      if ((uval <= S7_LONG_MAX) && (uval >= S7_LONG_MIN))
	mpz_init_set_si(n, (int)uval);
      else
	{ 
	  /* long long int to gmp mpz_t */
	  bool need_sign;
	  long long int val;
	  val = (long long int)uval;
	  /* handle one special case (sigh) */
	  if (val == S7_LLONG_MIN)
	    mpz_init_set_str(n, "-9223372036854775808", 10);
	  else
	    {
	      need_sign = (val < 0);
	      if (need_sign) val = -val;
	      mpz_init_set_si(n, val >> 32);
	      mpz_mul_2exp(n, n, 32);
	      mpz_add_ui(n, n, (unsigned int)(val & 0xffffffff));
	      if (need_sign) mpz_neg(n, n);
	    }
	}
    }
}


static s7_pointer s7_Int_to_big_integer(s7_scheme *sc, s7_Int val)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_INTEGER);
  add_bigint(sc, x);
  mpz_init_set_s7_Int(big_integer(x), val);

  return(x);
}


static s7_Int big_integer_to_s7_Int(mpz_t n)
{
  long long int high, low;
  mpz_t x;
  bool need_sign = false;

  if (sizeof(s7_Int) == sizeof(long int))
    return(mpz_get_si(n));

  if (mpz_fits_sint_p(n))
    return((s7_Int)mpz_get_si(n));
  /* special case as always is most-negative-fixnum */

  mpz_init_set(x, n);
  if (mpz_cmp_ui(x, 0) < 0)
    {
      need_sign = true;
      mpz_neg(x, x);
    }
  low = mpz_get_ui(x);
  if (low == S7_LLONG_MIN)
    return(S7_LLONG_MIN);

  mpz_fdiv_q_2exp(x, x, 32);
  high = mpz_get_ui(x);
  mpz_clear(x);
  if (need_sign)
    return(-(low + (high << 32)));
  return(low + (high << 32));
}

/* (expt 1/2 9223372036854775807) */


static mpq_t *s7_Ints_to_mpq(s7_Int num, s7_Int den)
{
  mpq_t *n;
  n = (mpq_t *)malloc(sizeof(mpq_t));
  mpq_init(*n);
  if ((num <= S7_LONG_MAX) && (num >= S7_LONG_MIN) &&
      (den <= S7_LONG_MAX) && (den >= S7_LONG_MIN))
    mpq_set_si(*n, (long int)num, (long int)den);
  else
    {
      mpz_t n1, d1;
      mpz_init_set_s7_Int(n1, num);
      mpz_init_set_s7_Int(d1, den);
      mpq_set_num(*n, n1);
      mpq_set_den(*n, d1);
      mpq_canonicalize(*n);
      mpz_clear(n1);
      mpz_clear(d1);
    }
  return(n);
}


static mpfr_t *s7_Double_to_mpfr(s7_Double val)
{
  mpfr_t *n;
  n = (mpfr_t *)malloc(sizeof(mpfr_t));
  mpfr_init_set_d(*n, val, GMP_RNDN);
  return(n);
}


static mpc_t *s7_Doubles_to_mpc(s7_Double rl, s7_Double im)
{
  mpc_t *n;
  n = (mpc_t *)malloc(sizeof(mpc_t));
  mpc_init(*n);
  mpc_set_d_d(*n, rl, im, MPC_RNDNN);
  return(n);
}


static s7_pointer s7_ratio_to_big_ratio(s7_scheme *sc, s7_Int num, s7_Int den)
{
  s7_pointer x;

  NEW_CELL(sc, x);
  set_type(x, T_BIG_RATIO);
  add_bigratio(sc, x);
  mpq_init(big_ratio(x));

  if ((num <= S7_LONG_MAX) && (num >= S7_LONG_MIN) &&
      (den <= S7_LONG_MAX) && (den >= S7_LONG_MIN))
    mpq_set_si(big_ratio(x), (long int)num, (long int)den);
  else
    {
      mpz_t n1, d1;
      mpz_init_set_s7_Int(n1, num);
      mpz_init_set_s7_Int(d1, den);
      mpq_set_num(big_ratio(x), n1);
      mpq_set_den(big_ratio(x), d1);
      mpq_canonicalize(big_ratio(x));
      mpz_clear(n1);
      mpz_clear(d1);
    }

  return(x);
}


static bool big_numbers_are_eqv(s7_pointer a, s7_pointer b)
{
  bool result;
  /* either or both can be big here, but not neither */

  if ((!is_big_number(a)) && (!is_big_number(b)))
    return(false);
  
  if (s7_is_integer(a))
    {
      mpz_t a1, b1;
      if (!(s7_is_integer(b))) return(false);

      if ((is_big_number(a)) && (is_big_number(b)))
	return(mpz_cmp(big_integer(a), big_integer(b)) == 0);

      if (is_big_number(a))
	mpz_init_set(a1, big_integer(a));
      else mpz_init_set_s7_Int(a1, s7_integer(a));

      if (is_big_number(b))
	mpz_init_set(b1, big_integer(b));
      else mpz_init_set_s7_Int(b1, s7_integer(b));
      result = (mpz_cmp(a1, b1) == 0);

      mpz_clear(a1);
      mpz_clear(b1);
      return(result);
    }

  if (s7_is_ratio(a))
    {
      mpq_t *a1, *b1;
      if (!s7_is_ratio(b)) return(false);

      if ((is_big_number(a)) && (is_big_number(b)))
	return(mpq_cmp(big_ratio(a), big_ratio(b)) == 0);

      if (is_big_number(a))
	a1 = &big_ratio(a);
      else a1 = s7_Ints_to_mpq(numerator(a), denominator(a));
      if (is_big_number(b))
	b1 = &big_ratio(b);
      else b1 = s7_Ints_to_mpq(numerator(b), denominator(b));

      result = (mpq_cmp(*a1, *b1) == 0);

      if (!is_big_number(a))
	{
	  mpq_clear(*a1);
	  free(a1);
	}
      if (!is_big_number(b))
	{
	  mpq_clear(*b1);
	  free(b1);
	}
      return(result);
    }

  if (s7_is_real(a))
    {
      mpfr_t *a1, *b1;

      /* s7_is_real is not finicky enough here -- (eqv? 1.0 1) should return #f */
      if (is_big_number(b))
	{
	  if (type(b) != T_BIG_REAL)
	    return(false);
	}
      else
	{
	  if (type(b) != T_REAL)
	    return(false);
	}

      if ((is_big_number(a)) && (is_big_number(b)))
	return(mpfr_equal_p(big_real(a), big_real(b)));

      if (is_big_number(a))
	a1 = &big_real(a);
      else a1 = s7_Double_to_mpfr(s7_real(a));

      if (is_big_number(b))
	b1 = &big_real(b);
      else b1 = s7_Double_to_mpfr(s7_real(b));

      result = (mpfr_cmp(*a1, *b1) == 0);

      if (!is_big_number(a))
	{
	  mpfr_clear(*a1);
	  free(a1);
	}
      if (!is_big_number(b))
	{
	  mpfr_clear(*b1);
	  free(b1);
	}
      return(result);
    }

  if (s7_is_complex(a))
    {
      mpc_t *a1, *b1;
      /* s7_is_complex is not finicky enough here */

      if ((type(b) != T_BIG_COMPLEX) &&
	  (type(b) != T_COMPLEX))
	return(false);

      /* (eqv? (bignum "1+i") 1+1i) */
      if ((is_big_number(a)) && (is_big_number(b)))
	return(mpc_cmp(big_complex(a), big_complex(b)) == 0);

      if (is_big_number(a))
	a1 = &big_complex(a);
      else a1 = s7_Doubles_to_mpc(real_part(a), imag_part(a));

      if (is_big_number(b))
	b1 = &big_complex(b);
      else b1 = s7_Doubles_to_mpc(real_part(b), imag_part(b));

      result = (mpc_cmp(*a1, *b1) == 0);

      if (!is_big_number(a))
	{
	  mpc_clear(*a1);
	  free(a1);
	}
      if (!is_big_number(b))
	{
	  mpc_clear(*b1);
	  free(b1);
	}
      return(result);
    }

  return(false);
}


static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int radix)
{
  s7_Int val;
  bool overflow = false;

  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, int radix)
{
  s7_Int n, d;
  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!
   */
  d = string_to_integer(dstr, radix, &overflow);
  if (!overflow)
    {
      if (d == 0)
	return(real_NaN);

      n = string_to_integer(nstr, radix, &overflow);
      if (!overflow)
	return(s7_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_pointer string_to_either_real(s7_scheme *sc, const char *str, int radix)
{
  bool overflow = false;
  s7_Double val;

  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, int 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 n, d;

	  /* q can include the slash and denominator */
	  n = string_to_integer(q, radix, &overflow);
	  if (overflow)
	    return(string_to_big_ratio(sc, q, radix));
	  else
	    {
	      d = string_to_integer(slash1, radix, &overflow);
	      if (!overflow)
		(*d_rl) = (s7_Double)n / (s7_Double)d;
	      else return(string_to_big_ratio(sc, q, radix));
	    }
	}
      else
	{
	  s7_Int val;

	  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, 
					   int radix, int has_plus_or_minus)
{
  /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */
  double d_rl = 0.0, d_im = 0.0;
  s7_pointer p_rl = NULL, p_im = NULL, result;
  mpfr_t m_rl, m_im;

  p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl);
  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 */
      if ((!p_im) ||
	  (s7_is_zero(p_im)))
	{
	  if (!p_rl)
	    return(make_real(sc, d_rl));
	  return(p_rl);
	}
    }

  if ((!p_rl) && (!p_im))
    return(s7_make_complex(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im));

  if (p_rl)
    mpfr_init_set(m_rl, big_real(promote_number(sc, T_BIG_REAL, p_rl)), GMP_RNDN);
  else mpfr_init_set_d(m_rl, d_rl, GMP_RNDN);

  if (p_im)
    mpfr_init_set(m_im, big_real(promote_number(sc, T_BIG_REAL, p_im)), GMP_RNDN);
  else mpfr_init_set_d(m_im, d_im, GMP_RNDN);

  if (has_plus_or_minus == -1) 
    mpfr_neg(m_im, m_im, GMP_RNDN);

  result = make_big_complex(sc, m_rl, m_im);
  
  mpfr_clear(m_rl);
  mpfr_clear(m_im);
  return(result);
}


static int big_type_to_result_type(int cur_type, int next_type)
{
  if ((cur_type == T_BIG_COMPLEX) || 
      (cur_type == T_COMPLEX) ||
      (next_type == T_BIG_COMPLEX))
    return(T_BIG_COMPLEX);

  if ((cur_type == T_BIG_REAL) ||
      (cur_type == T_REAL) ||
      (next_type == T_BIG_REAL))
    return(T_BIG_REAL);

  if ((cur_type == T_BIG_RATIO) ||
      (cur_type == T_RATIO) ||
      (next_type == T_BIG_RATIO))
    return(T_BIG_RATIO);

  return(T_BIG_INTEGER);
}


static int normal_type_to_result_type(int cur_type, int next_type)
{
  if (cur_type > T_COMPLEX)
    next_type += 4;
  if (cur_type > next_type)
    return(cur_type);
  return(next_type);
}


static s7_pointer promote_number_1(s7_scheme *sc, int type, s7_pointer x, bool copy)
{
  /* x can be any number -- need to convert it to the current result type */

  switch (type)
    {
    case T_BIG_INTEGER:
      if (is_big_number(x)) 
	{
	  if (copy)
	    return(mpz_to_big_integer(sc, big_integer(x)));
	  return(x);                       /* can only be T_BIG_INTEGER here */
	}
      return(s7_Int_to_big_integer(sc, s7_integer(x))); /* can only be integer here */
      break;

    case T_BIG_RATIO:
      if (is_big_number(x))
	{
	  if (type(x) == T_BIG_RATIO) 
	    {
	      if (copy)
		return(mpq_to_big_ratio(sc, big_ratio(x)));
	      return(x);
	    }
	  return(mpz_to_big_ratio(sc, big_integer(x)));
	}
      if (type(x) == T_INTEGER)
	return(s7_ratio_to_big_ratio(sc, integer(x), 1));
      return(s7_ratio_to_big_ratio(sc, numerator(x), denominator(x)));
      break;

    case T_BIG_REAL:
      if (is_big_number(x))
	{
	  if (type(x) == T_BIG_REAL) 
	    {
	      if (copy)
		return(mpfr_to_big_real(sc, big_real(x)));
	      return(x);
	    }
	  if (type(x) == T_BIG_RATIO) 
	    return(mpq_to_big_real(sc, big_ratio(x)));
	  return(mpz_to_big_real(sc, big_integer(x)));
	}
      return(s7_number_to_big_real(sc, x));
      break;

    default:
      if (is_big_number(x))
	{
	  if (type(x) == T_BIG_COMPLEX) 
	    {
	      if (copy)
		return(mpc_to_big_complex(sc, big_complex(x)));
	      return(x);
	    }
	  if (type(x) == T_BIG_REAL) 
	    return(mpfr_to_big_complex(sc, big_real(x)));
	  if (type(x) == T_BIG_RATIO) 
	    return(mpq_to_big_complex(sc, big_ratio(x)));
	  return(mpz_to_big_complex(sc, big_integer(x)));
	}
      return(s7_number_to_big_complex(sc, x));
      break;
    }

  return(sc->NIL);
}


static s7_pointer promote_number(s7_scheme *sc, int type, s7_pointer x)
{
  return(promote_number_1(sc, type, x, false));
}


static s7_pointer to_big(s7_scheme *sc, s7_pointer x)
{
  if (is_big_number(x))
    return(x);
  switch (type(x))
    {
    case T_INTEGER:
      return(s7_Int_to_big_integer(sc, integer(x)));
      
    case T_RATIO:
      return(s7_ratio_to_big_ratio(sc, numerator(x), denominator(x)));

    case T_REAL:
      return(s7_number_to_big_real(sc, x));

    default:
      return(s7_number_to_big_complex(sc, x));
    }
}


static s7_pointer copy_and_promote_number(s7_scheme *sc, int type, s7_pointer x)
{
  return(promote_number_1(sc, type, x, true));
}


void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj) 
{
  /* if the same bignum object is assigned to each element, different vector elements
   *    are actually the same -- we need to make a copy of obj for each one
   */
  if (is_big_number(obj))
    {
      int gc_loc;
      s7_Int i, len;
      s7_pointer *tp;

      if (type(vec) != T_VECTOR)
	wrong_type_argument_with_type(sc, sc->VECTOR_FILL, small_int(1), vec, make_protected_string(sc, "a normal vector"));

      len = vector_length(vec);
      tp = (s7_pointer *)(vector_elements(vec));

      /* we'll be calling new_cell below, hence the GC, so make sure the elements are markable,
       *   and the vector itself is GC protected (we can be called within make-vector).
       */
      gc_loc = s7_gc_protect(sc, vec);
      vector_fill(sc, vec, sc->NIL); 

      switch (type(obj))
	{
	case T_BIG_INTEGER:
	  for (i = 0; i < len; i++) 
	    tp[i] = mpz_to_big_integer(sc, big_integer(obj));
	  break;

	case T_BIG_RATIO:
	  for (i = 0; i < len; i++) 
	    tp[i] = mpq_to_big_ratio(sc, big_ratio(obj));
	  break;

	case T_BIG_REAL:
	  for (i = 0; i < len; i++) 
	    tp[i] = mpfr_to_big_real(sc, big_real(obj));
	  break;

	default:
	  for (i = 0; i < len; i++) 
	    tp[i] = mpc_to_big_complex(sc, big_complex(obj));
	  break;
	}

      s7_gc_unprotect_at(sc, gc_loc);
    }
  else vector_fill(sc, vec, obj);
}


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'"
  s7_pointer p;

  p = g_string_to_number_1(sc, args, sc->BIGNUM); 
  if (is_false(sc, p))                                       /* (bignum "1/3.0") */
    s7_error(sc, make_symbol(sc, "bignum-error"),
	     list_2(sc,
		    make_protected_string(sc, "bignum argument does not represent a number: ~S"),
		    car(args)));

  switch (type(p))
    {
    case T_INTEGER:  
      return(promote_number(sc, T_BIG_INTEGER, p));

    case T_RATIO:
      return(promote_number(sc, T_BIG_RATIO, p));

      /* we can't use promote_number here because it propogates C-double inaccuracies
       *    (rationalize (bignum "0.1") 0) should return 1/10 not 3602879701896397/36028797018963968
       */
    case T_REAL:
      if (is_NaN(real(p))) return(p);
      return(string_to_big_real(sc, string_value(car(args)), (is_pair(cdr(args))) ? s7_integer(cadr(args)) : 10));

    case T_COMPLEX:
      /* PERHAPS: read complex via gmp, (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968
       */
      return(promote_number(sc, T_BIG_COMPLEX, p));

    default:
      return(p);
    }
}


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."
  return(s7_make_boolean(sc, is_big_number(car(args))));
}


static s7_Int add_max = 0;

static s7_pointer big_add(s7_scheme *sc, s7_pointer args)
{
  int result_type = T_INTEGER;
  s7_pointer x, result;

  if (is_null(args))
    return(small_int(0));

  if ((is_null(cdr(args))) && (s7_is_number(car(args))))
    return(car(args));

  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      s7_pointer p;
      p = car(x);
      if (!is_number(p))
	{
	  if (!is_big_number(p))
	    {
	      CHECK_METHOD(sc, p, sc->ADD, args);
	      return(wrong_type_argument_n_with_type(sc, sc->ADD, position_of(x, args), p, A_NUMBER));
	    }
	  else result_type = big_type_to_result_type(result_type, type(p));
	}
      else result_type = normal_type_to_result_type(result_type, type(p));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_add(sc, args));

  result = copy_and_promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      s7_pointer arg;
      arg = promote_number(sc, result_type, car(x));

      switch (result_type)
	{
	case T_BIG_INTEGER:
	  mpz_add(big_integer(result), big_integer(result), big_integer(arg));
	  break;
	  
	case T_BIG_RATIO:
	  mpq_add(big_ratio(result), big_ratio(result), big_ratio(arg));
	  break;
	  
	case T_BIG_REAL:
	  mpfr_add(big_real(result), big_real(result), big_real(arg), GMP_RNDN);
	  break;
	  
	case T_BIG_COMPLEX:
	  mpc_add(big_complex(result), big_complex(result), big_complex(arg), MPC_RNDNN);
	  break;
	}
    }
  
  switch (result_type)
      {
      case T_BIG_RATIO:
	return(make_big_integer_or_ratio(sc, result));

      case T_BIG_COMPLEX:
	return(make_big_real_or_complex(sc, result));
      }
  return(result);
}


static s7_pointer big_negate(s7_scheme *sc, s7_pointer args)
{
  /* assume cdr(args) is nil and we're called from subtract, so check for big num else call g_subtract */
  s7_pointer p, x;

  p = car(args);
  switch (type(p))
    {
    case T_BIG_INTEGER:
      x = mpz_to_big_integer(sc, big_integer(p));
      mpz_neg(big_integer(x), big_integer(x));
      return(x);

    case T_BIG_RATIO:
      x = mpq_to_big_ratio(sc, big_ratio(p));
      mpq_neg(big_ratio(x), big_ratio(x));
      return(x);

    case T_BIG_REAL:
      x = mpfr_to_big_real(sc, big_real(p));
      mpfr_neg(big_real(x), big_real(x), GMP_RNDN);
      return(x);

    case T_BIG_COMPLEX:
      x = mpc_to_big_complex(sc, big_complex(p));
      mpc_neg(big_complex(x), big_complex(x), MPC_RNDNN);
      return(x);

    case T_INTEGER: 
      if (integer(p) == S7_LLONG_MIN)
	{
	  x = s7_Int_to_big_integer(sc, integer(p));
	  mpz_neg(big_integer(x), big_integer(x));
	  return(x);
	}
      return(make_integer(sc, -integer(p)));
      
    case T_RATIO:
      return(s7_make_ratio(sc, -numerator(p), denominator(p)));
      
    case T_REAL:
      return(make_real(sc, -real(p)));
      
    default:
      return(s7_make_complex(sc, -real_part(p), -imag_part(p)));
    }
}


static s7_pointer big_subtract(s7_scheme *sc, s7_pointer args)
{
  int result_type = T_INTEGER;
  s7_pointer x, result;

  if (!s7_is_number(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->MINUS, args);
      return(wrong_type_argument_with_type(sc, sc->MINUS, small_int(1), car(args), A_NUMBER));
    }
  if (is_null(cdr(args))) 
    return(big_negate(sc, args));

  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      s7_pointer p;
      p = car(x);
      if (!is_number(p))
	{
	  if (!is_big_number(p))
	    {
	      CHECK_METHOD(sc, p, sc->MINUS, args);
	      return(wrong_type_argument_n_with_type(sc, sc->MINUS, position_of(x, args), p, A_NUMBER));
	    }
	  else result_type = big_type_to_result_type(result_type, type(p));
	}
      else result_type = normal_type_to_result_type(result_type, type(p));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_subtract(sc, args));

  result = copy_and_promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      s7_pointer arg;
      arg = promote_number(sc, result_type, car(x));

      switch (result_type)
	{
	case T_BIG_INTEGER:
	  mpz_sub(big_integer(result), big_integer(result), big_integer(arg));
	  break;
	  
	case T_BIG_RATIO:
	  mpq_sub(big_ratio(result), big_ratio(result), big_ratio(arg));
	  break;
	  
	case T_BIG_REAL:
	  mpfr_sub(big_real(result), big_real(result), big_real(arg), GMP_RNDN);
	  break;
	  
	case T_BIG_COMPLEX:
	  mpc_sub(big_complex(result), big_complex(result), big_complex(arg), MPC_RNDNN);
	  break;
	}
    }

  switch (result_type)
    {
      case T_BIG_RATIO:
	return(make_big_integer_or_ratio(sc, result));

      case T_BIG_COMPLEX:
	return(make_big_real_or_complex(sc, result));
      }
  return(result);
}


static s7_pointer big_multiply(s7_scheme *sc, s7_pointer args)
{
  int result_type = T_INTEGER;
  s7_pointer x, result;

  if (is_null(args))
    return(small_int(1));

  if ((is_null(cdr(args))) && (s7_is_number(car(args))))
    return(car(args));

  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      s7_pointer p;
      p = car(x);
      if (!is_number(p))
	{
	  if (!is_big_number(p))
	    {
	      CHECK_METHOD(sc, p, sc->MULTIPLY, args);
	      return(wrong_type_argument_n_with_type(sc, sc->MULTIPLY, position_of(x, args), p, A_NUMBER));
	    }
	  else result_type = big_type_to_result_type(result_type, type(p));
	}
      else result_type = normal_type_to_result_type(result_type, type(p));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_multiply(sc, args));

  result = copy_and_promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      s7_pointer arg;
      arg = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  mpz_mul(big_integer(result), big_integer(result), big_integer(arg));
	  break;
	  
	case T_BIG_RATIO:
	  mpq_mul(big_ratio(result), big_ratio(result), big_ratio(arg));
	  break;

	case T_BIG_REAL:
	  mpfr_mul(big_real(result), big_real(result), big_real(arg), GMP_RNDN);
	  break;

	case T_BIG_COMPLEX:
	  mpc_mul(big_complex(result), big_complex(result), big_complex(arg), MPC_RNDNN);
	  break;
	}
    }

  switch (result_type)
    {
    case T_BIG_RATIO:
      return(make_big_integer_or_ratio(sc, result));

    case T_BIG_COMPLEX:
      return(make_big_real_or_complex(sc, result));
    }
  return(result);
}


static s7_pointer big_invert(s7_scheme *sc, s7_pointer args)
{
  /* assume cdr(args) is nil and we're called from divide, so check for big num else call g_divide */
  s7_pointer p, x;

  p = car(args);
  if (s7_is_zero(p))
    return(division_by_zero_error(sc, sc->DIVIDE, p));
  
  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) == S7_LLONG_MIN)
	{
	  mpz_t n1, d1;

	  NEW_CELL(sc, x);
	  set_type(x, T_BIG_RATIO);
	  add_bigratio(sc, x);

	  mpz_init_set_s7_Int(n1, 1);
	  mpz_init_set_s7_Int(d1, S7_LLONG_MIN);
	  mpq_set_num(big_ratio(x), n1);
	  mpq_set_den(big_ratio(x), d1);
	  mpq_canonicalize(big_ratio(x));
	  mpz_clear(n1);
	  mpz_clear(d1);

	  return(x);
	}
      return(s7_make_ratio(sc, 1, integer(p)));      /* a already checked, not 0 */
      
    case T_RATIO:
      return(s7_make_ratio(sc, denominator(p), numerator(p)));

    case T_REAL:
      return(make_real(sc, 1.0 / real(p)));

    case T_COMPLEX:
      {
	s7_Double r2, i2, den;
	r2 = real_part(p);
	i2 = imag_part(p);
	den = (r2 * r2 + i2 * i2);
	return(s7_make_complex(sc, r2 / den, -i2 / den));
      }

    case T_BIG_INTEGER:
      /* p might be 1 or -1 */
      {
	mpz_t n;

	mpz_init_set_si(n, 1);
	if (mpz_cmp(n, big_integer(p)) == 0)
	  {
	    mpz_clear(n);
	    return(small_int(1));
	  }
	mpz_set_si(n, -1);
	if (mpz_cmp(n, big_integer(p)) == 0)
	  {
	    mpz_clear(n);
	    return(s7_make_integer(sc, -1));
	  }

	NEW_CELL(sc, x);
	set_type(x, T_BIG_RATIO);
	add_bigratio(sc, x);
	mpq_init(big_ratio(x));

	mpz_set_ui(n, 1);
	mpq_set_num(big_ratio(x), n);
	mpz_clear(n);

	mpq_set_den(big_ratio(x), big_integer(p));
	mpq_canonicalize(big_ratio(x));
	return(x);
      }

    case T_BIG_RATIO:
      {
	mpz_t n;

	mpz_init_set_si(n, 1);
	if (mpz_cmp(n, mpq_numref(big_ratio(p))) == 0)
	  {
	    mpz_clear(n);
	    return(mpz_to_big_integer(sc, mpq_denref(big_ratio(p))));
	  }
	mpz_set_si(n, -1);
	if (mpz_cmp(n, mpq_numref(big_ratio(p))) == 0)
	  {
	    mpz_clear(n);
	    x = mpz_to_big_integer(sc, mpq_denref(big_ratio(p)));
	    mpz_neg(big_integer(x), big_integer(x));
	    return(x);
	  }
	mpz_clear(n);

	NEW_CELL(sc, x);
	set_type(x, T_BIG_RATIO);
	add_bigratio(sc, x);

	mpq_init(big_ratio(x));
	mpq_set_num(big_ratio(x), mpq_denref(big_ratio(p)));
	mpq_set_den(big_ratio(x), mpq_numref(big_ratio(p)));
	mpq_canonicalize(big_ratio(x));
	return(x);
      }

    case T_BIG_REAL:
      x = mpfr_to_big_real(sc, big_real(p));
      mpfr_ui_div(big_real(x), 1, big_real(x), GMP_RNDN);
      return(x);

    default:
      x = mpc_to_big_complex(sc, big_complex(p));
      mpc_ui_div(big_complex(x), 1, big_complex(x), MPC_RNDNN);
      return(x);
    }
}


static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
{
  int result_type = T_INTEGER;
  s7_pointer x, divisor, result;

  if (!s7_is_number(car(args)))
    {
      CHECK_METHOD(sc, car(args), sc->DIVIDE, args);
      return(wrong_type_argument_with_type(sc, sc->DIVIDE, small_int(1), car(args), A_NUMBER));
    }
  if (is_null(cdr(args))) 
    return(big_invert(sc, args));

  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      s7_pointer p;
      p = car(x);
      if (!is_number(p))
	{
	  if (!is_big_number(p))
	    {
	      CHECK_METHOD(sc, p, sc->DIVIDE, args);
	      return(wrong_type_argument_n_with_type(sc, sc->DIVIDE, position_of(x, args), p, A_NUMBER));
	    }
	  else result_type = big_type_to_result_type(result_type, type(p));
	}
      else result_type = normal_type_to_result_type(result_type, type(p));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_divide(sc, args));

  divisor = copy_and_promote_number(sc, result_type, cadr(args));

  for (x = cddr(args); is_not_null(x); x = cdr(x)) 
    {
      s7_pointer arg;
      arg = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  mpz_mul(big_integer(divisor), big_integer(divisor), big_integer(arg));
	  break;
	  
	case T_BIG_RATIO:
	  mpq_mul(big_ratio(divisor), big_ratio(divisor), big_ratio(arg));
	  break;
	  
	case T_BIG_REAL:
	  mpfr_mul(big_real(divisor), big_real(divisor), big_real(arg), GMP_RNDN);
	  break;
	  
	case T_BIG_COMPLEX:
	  mpc_mul(big_complex(divisor), big_complex(divisor), big_complex(arg), MPC_RNDNN);
	  break;
	}
    }
    
  if (s7_is_zero(divisor))
    return(division_by_zero_error(sc, sc->DIVIDE, args));

  result = copy_and_promote_number(sc, result_type, car(args));

  switch (result_type)
    {
    case T_BIG_INTEGER:
      {
	NEW_CELL(sc, x);
	set_type(x, T_BIG_RATIO);
	add_bigratio(sc, x);

	mpq_init(big_ratio(x));
	mpq_set_num(big_ratio(x), big_integer(result));
	mpq_set_den(big_ratio(x), big_integer(divisor));
	mpq_canonicalize(big_ratio(x));

	if (mpz_cmp_ui(mpq_denref(big_ratio(x)), 1) == 0)
	  return(mpz_to_big_integer(sc, mpq_numref(big_ratio(x))));
	return(x);
      }
      
    case T_BIG_RATIO:
      mpq_div(big_ratio(result), big_ratio(result), big_ratio(divisor));
      return(make_big_integer_or_ratio(sc, result));
      break;
      
    case T_BIG_REAL:
      mpfr_div(big_real(result), big_real(result), big_real(divisor), GMP_RNDN);
      break;
      
    case T_BIG_COMPLEX:
      mpc_div(big_complex(result), big_complex(result), big_complex(divisor), MPC_RNDNN);
      return(make_big_real_or_complex(sc, result));
      break;
    }

  return(result);
}


static s7_pointer big_abs(s7_scheme *sc, s7_pointer args)
{
  #define H_abs "(abs x) returns the absolute value of the real number x"
  s7_pointer p, x;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) < 0)
	{
	  if (integer(p) == S7_LLONG_MIN)
	    {
	      x = s7_Int_to_big_integer(sc, integer(p));
	      mpz_neg(big_integer(x), big_integer(x));
	      return(x);
	    }
	  return(make_integer(sc, -integer(p)));
	}
      return(p);

    case T_RATIO:
      if (numerator(p) < 0)
	return(s7_make_ratio(sc, -numerator(p), denominator(p)));
      return(p);

    case T_REAL:
      if (real(p) < 0.0)
	return(make_real(sc, -real(p)));
      return(p);

    case T_BIG_INTEGER:
      x = mpz_to_big_integer(sc, big_integer(p));
      mpz_abs(big_integer(x), big_integer(x));
      return(x);

    case T_BIG_RATIO:
      x = mpq_to_big_ratio(sc, big_ratio(p));
      mpq_abs(big_ratio(x), big_ratio(x));
      return(x);

    case T_BIG_REAL:
      x = mpfr_to_big_real(sc, big_real(p));
      mpfr_abs(big_real(x), big_real(x), GMP_RNDN);
      return(x);

    default:
      CHECK_METHOD(sc, p, sc->ABS, args);
      return(simple_wrong_type_argument(sc, sc->ABS, p, T_REAL));
    }
}


static s7_pointer big_magnitude(s7_scheme *sc, s7_pointer args)
{
  #define H_magnitude "(magnitude z) returns the magnitude of z"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->MAGNITUDE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->MAGNITUDE, p, A_NUMBER));
    }

  if (type(p) == T_BIG_COMPLEX)
    {
      mpfr_t n;
      mpfr_init(n);
      mpc_abs(n, big_complex(p), GMP_RNDN);
      p = mpfr_to_big_real(sc, n);
      mpfr_clear(n);
      return(p);
    }

  if (type(p) == T_COMPLEX)
    return(make_real(sc, hypot(imag_part(p), real_part(p))));

  return(big_abs(sc, args));
}


static s7_pointer big_angle(s7_scheme *sc, s7_pointer args)
{
  #define H_angle "(angle z) returns the angle of z"
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) < 0)
	return(real_pi);
      return(small_int(0));

    case T_RATIO:
      if (numerator(p) < 0)
	return(real_pi);
      return(small_int(0));

    case T_REAL:
      if (is_NaN(real(p))) return(p);
      if (real(p) < 0.0)
	return(real_pi);
      return(real_zero);

    case T_COMPLEX:
      return(make_real(sc, atan2(imag_part(p), real_part(p))));

    case T_BIG_INTEGER:
      if (mpz_cmp_ui(big_integer(p), 0) >= 0)
	return(small_int(0));
      return(big_pi(sc));

    case T_BIG_RATIO:
      if (mpq_cmp_ui(big_ratio(p), 0, 1) >= 0)
	return(small_int(0));
      return(big_pi(sc));

    case T_BIG_REAL:
      {
	double x;
	x = mpfr_get_d(big_real(p), GMP_RNDN);
	/* mpfr_get_d returns inf or -inf if the arg is too large for a double */
	if (is_NaN(x)) return(p);
	if (x >= 0.0)
	  return(real_zero);
	return(big_pi(sc));
      }

    case T_BIG_COMPLEX:
      {
	s7_pointer x;
	NEW_CELL(sc, x);
	set_type(x, T_BIG_REAL);
	add_bigreal(sc, x);
	mpfr_init(big_real(x));
	mpc_arg(big_real(x), big_complex(p), GMP_RNDN);
	return(x);
      }
      
    default:
      CHECK_METHOD(sc, p, sc->ANGLE, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ANGLE, p, A_NUMBER));
    }
}


static s7_pointer big_make_rectangular(s7_scheme *sc, s7_pointer args)
{
  #define H_make_rectangular "(make-rectangular x1 x2) returns a complex number with real-part x1 and imaginary-part x2"

  s7_pointer p0, p1, p;
  mpfr_t rl, im;
  double x;

  p0 = car(args);
  if (!s7_is_real(p0))
    {
      CHECK_METHOD(sc, p0, sc->MAKE_RECTANGULAR, args);
      return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(1), p0, T_REAL));
    }
  p1 = cadr(args);
  if (!s7_is_real(p1))
    {
      CHECK_METHOD(sc, p1, sc->MAKE_RECTANGULAR, args);
      return(wrong_type_argument(sc, sc->MAKE_RECTANGULAR, small_int(2), p1, T_REAL));
    }
  if ((!is_big_number(p1)) && (s7_real(p1) == 0.0)) /* imag-part is not bignum and is 0.0 */
    return(p0);

  mpfr_init_set(im, big_real(promote_number(sc, T_BIG_REAL, p1)), GMP_RNDN);
  x = mpfr_get_d(im, GMP_RNDN);
  if (x == 0.0)                                   /* imag-part is bignum 0.0 */
    {
      mpfr_clear(im);
      return(p0);
    }

  mpfr_init_set(rl, big_real(promote_number(sc, T_BIG_REAL, p0)), GMP_RNDN);

  NEW_CELL(sc, p);
  set_type(p, T_BIG_COMPLEX);
  add_bignumber(sc, p);
  mpc_init(big_complex(p));
  mpc_set_fr_fr(big_complex(p), rl, im, MPC_RNDNN);

  mpfr_clear(rl);
  mpfr_clear(im);
  return(p);
}


/* (make-polar 0 (real-part (log 0))) = 0? or nan?
 */

static s7_pointer big_make_polar(s7_scheme *sc, s7_pointer args)
{
  #define H_make_polar "(make-polar mag ang) returns a complex number with magnitude mag and angle ang"

  s7_pointer p0, p1, p;
  mpfr_t ang, mag, rl, im;
  double x, y;

  p0 = car(args);
  if (!s7_is_real(p0))
    {
      CHECK_METHOD(sc, p0, sc->MAKE_POLAR, args);
      return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(1), p0, T_REAL));
    }
  p1 = cadr(args);
  if (!s7_is_real(p1))
    {
      CHECK_METHOD(sc, p1, sc->MAKE_POLAR, args);
      return(wrong_type_argument(sc, sc->MAKE_POLAR, small_int(2), p1, T_REAL));
    }
  mpfr_init_set(ang, big_real(promote_number(sc, T_BIG_REAL, p1)), GMP_RNDN);
  y = mpfr_get_d(ang, GMP_RNDN);

  if (is_NaN(y))
    {
      mpfr_clear(ang);
      return(real_NaN);
    }

  mpfr_init_set(mag, big_real(promote_number(sc, T_BIG_REAL, p0)), GMP_RNDN);
  x = mpfr_get_d(mag, GMP_RNDN);

  if (is_NaN(x))
    {
      mpfr_clear(ang);
      mpfr_clear(mag);
      return(real_NaN);
    }

  if ((x == 0.0) || (y == 0.0))
    {
      mpfr_clear(ang);
      mpfr_clear(mag);
      return(p0);
    }

  mpfr_init_set(im, ang, GMP_RNDN);
  mpfr_sin(im, im, GMP_RNDN);
  mpfr_mul(im, im, mag, GMP_RNDN);
      
  x = mpfr_get_d(im, GMP_RNDN);
  if (x == 0.0)
    {
      mpfr_clear(im);
      mpfr_clear(ang);
      mpfr_clear(mag);
      return(p0);
    }

  mpfr_init_set(rl, ang, GMP_RNDN);
  mpfr_cos(rl, rl, GMP_RNDN);
  mpfr_mul(rl, rl, mag, GMP_RNDN);

  NEW_CELL(sc, p);
  set_type(p, T_BIG_COMPLEX);
  add_bignumber(sc, p);
  mpc_init(big_complex(p));
  mpc_set_fr_fr(big_complex(p), rl, im, MPC_RNDNN);

  mpfr_clear(rl);
  mpfr_clear(im);
  mpfr_clear(ang);
  mpfr_clear(mag);
  return(p);
}


static s7_pointer big_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"
  /* either arg can be big, second is optional */
  s7_pointer p0, p1 = NULL, p;

  p0 = car(args);
  if (!s7_is_number(p0))
    {
      CHECK_METHOD(sc, p0, sc->LOG, args);
      return(wrong_type_argument_with_type(sc, sc->LOG, small_int(1), p0, A_NUMBER));
    }
  if (is_not_null(cdr(args)))
    {
      p1 = cadr(args);
      if (!s7_is_number(p1))
	{
	  CHECK_METHOD(sc, p1, sc->LOG, args);
	  return(wrong_type_argument_with_type(sc, sc->LOG, small_int(2), p1, A_NUMBER));
	}
    }

  if ((s7_is_real(p0)) &&
      ((!p1) || (s7_is_real(p1))))
    {
      double x, y = 0.0;

      p0 = promote_number(sc, T_BIG_REAL, p0);
      x = mpfr_get_d(big_real(p0), GMP_RNDN);
      if (is_NaN(x))
	return(real_NaN);

      if (p1) 
	{
	  p1 = promote_number(sc, T_BIG_REAL, p1);
	  y = mpfr_get_d(big_real(p1), GMP_RNDN);

	  /* we can't check y here for 1.0 (check for 0.0 apparently is ok):
	   *  :(log 100.0 (+ 1.0 (bignum "1e-16")))
	   *  ;log base, argument 2, 1.000000000000000100000000000000000000002E0, is out of range (can't be 0.0 or 1.0)
	   *  :(= 1.0 (+ 1.0 (bignum "1e-16")))
	   *  #f
	   */
	  if (is_NaN(y))
	    return(real_NaN);
	  if (y == 0.0)
	    return(out_of_range(sc, sc->LOG, small_int(2), p1, "can't be 0.0"));
	}
      if (x == 0.0)
	return(s7_make_complex(sc, -INFINITY, M_PI));

      if ((x > 0.0) && (y >= 0.0))
	{
	  mpfr_t n, base;

	  mpfr_init_set(n, big_real(p0), GMP_RNDN);
	  mpfr_log(n, n, GMP_RNDN);

	  if (!p1)
	    {
	      /* presumably log is safe with regard to real-part overflow giving a bogus int? */
	      if ((s7_is_rational(car(args))) &&
		  (mpfr_integer_p(n) != 0))
		{
		  NEW_CELL(sc, p);
		  set_type(p, T_BIG_INTEGER);
		  add_bigint(sc, p);
		  mpz_init(big_integer(p));
		  mpfr_get_z(big_integer(p), n, GMP_RNDN);
		}
	      else p = mpfr_to_big_real(sc, n);
	      mpfr_clear(n);
	      return(p);
	    }

	  mpfr_init_set(base, big_real(p1), GMP_RNDN);
	  mpfr_log(base, base, GMP_RNDN);
	  mpfr_div(n, n, base, GMP_RNDN);
	  mpfr_clear(base);

	  if ((s7_is_rational(car(args))) &&
	      (s7_is_rational(cadr(args))) &&
	      (mpfr_integer_p(n) != 0))
	    {
	      NEW_CELL(sc, p);
	      set_type(p, T_BIG_INTEGER);
	      add_bigint(sc, p);
	      mpz_init(big_integer(p));
	      mpfr_get_z(big_integer(p), n, GMP_RNDN);
	    }
	  else p = mpfr_to_big_real(sc, n);
	  mpfr_clear(n);
	  return(p);
	}
    }

  p0 = promote_number(sc, T_BIG_COMPLEX, p0);
  if (p1) p1 = promote_number(sc, T_BIG_COMPLEX, p1);
  {
    mpc_t n, base;
    double x;

    mpc_init(n);
    mpc_set(n, big_complex(p0), MPC_RNDNN);
    mpc_log(n, n, MPC_RNDNN);
    if (!p1)
      {
	p = mpc_to_big_complex(sc, n);
	mpc_clear(n);
	return(p);
      }

    mpc_init(base);
    mpc_set(base, big_complex(p1), MPC_RNDNN);
    mpc_log(base, base, MPC_RNDNN);
    mpc_div(n, n, base, MPC_RNDNN);
    mpc_clear(base);

    x = mpfr_get_d(mpc_imagref(n), GMP_RNDN);
    if (x == 0.0)
      p = mpfr_to_big_real(sc, mpc_realref(n));
    else p = mpc_to_big_complex(sc, n);

    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_sqrt(s7_scheme *sc, s7_pointer args)
{
  /* real >= 0 -> real, else complex */
  #define H_sqrt "(sqrt z) returns the square root of z"

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->SQRT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->SQRT, p, A_NUMBER));
    }
  p = to_big(sc, p);
    
  /* if big integer, try to return int if perfect square */
  if (type(p) == T_BIG_INTEGER)
    {
      if (mpz_cmp_ui(big_integer(p), 0) < 0)
	p = promote_number(sc, T_BIG_COMPLEX, p);
      else
	{
	  mpz_t n, rem;

	  mpz_init(rem);
	  mpz_init_set(n, big_integer(p));
	  mpz_sqrtrem(n, rem, n);

	  if (mpz_cmp_ui(rem, 0) == 0)
	    {
	      p = mpz_to_big_integer(sc, n);
	      mpz_clear(n);
	      mpz_clear(rem);
	      return(p);
	    }
	  mpz_clear(n);
	  mpz_clear(rem);
	  p = promote_number(sc, T_BIG_REAL, p);
	}
    }
  
  /* if big ratio, check both num and den for squares */
  if (type(p) == T_BIG_RATIO)
    {
      if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0)
	p = promote_number(sc, T_BIG_COMPLEX, p);
      else
	{
	  mpz_t n1, rem;
	  mpz_init(rem);
	  mpz_init_set(n1, mpq_numref(big_ratio(p)));
	  mpz_sqrtrem(n1, rem, n1);

	  if (mpz_cmp_ui(rem, 0) == 0)
	    {
	      mpz_t d1;
	      mpz_init_set(d1, mpq_denref(big_ratio(p)));
	      mpz_sqrtrem(d1, rem, d1);

	      if (mpz_cmp_ui(rem, 0) == 0)
		{
		  mpq_t n;
		  mpq_init(n);
		  mpq_set_num(n, n1);
		  mpq_set_den(n, d1);
		  mpq_canonicalize(n);
		  p = mpq_to_big_ratio(sc, n);
		  mpz_clear(n1);
		  mpz_clear(d1);
		  mpz_clear(rem);
		  mpq_clear(n);
		  return(p);
		}
	      mpz_clear(d1);
	    }

	  mpz_clear(n1);
	  mpz_clear(rem);
	  p = promote_number(sc, T_BIG_REAL, p);
	}
    }
  
  /* if real and not negative, use mpfr_sqrt */
  if (type(p) == T_BIG_REAL)
    {
      if (mpfr_cmp_ui(big_real(p), 0) < 0)
	p = promote_number(sc, T_BIG_COMPLEX, p);
      else
	{
	  mpfr_t n;
	  mpfr_init_set(n, big_real(p), GMP_RNDN);
	  mpfr_sqrt(n, n, GMP_RNDN);
	  p = mpfr_to_big_real(sc, n);
	  mpfr_clear(n);
	  return(p);
	}
    }
  
  /* p is a big number, so it must be complex at this point */
  {
    mpc_t n;
    mpc_init(n);
    mpc_set(n, big_complex(p), MPC_RNDNN);
    mpc_sqrt(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


/* (define (diff f a) (magnitude (- (f a) (f (bignum (number->string a))))))
 * (sin 1e15+1e15i) hangs in mpc 0.8.2, but appears to be fixed in the current svn sources
 */

enum {TRIG_NO_CHECK, TRIG_TAN_CHECK, TRIG_TANH_CHECK};

static s7_pointer big_trig(s7_scheme *sc, s7_pointer args, 
			   int (*mpfr_trig)(mpfr_ptr, mpfr_srcptr, mpfr_rnd_t),
			   int (*mpc_trig)(mpc_ptr, mpc_srcptr, mpc_rnd_t),
			   int tan_case, s7_pointer sym)
/* these declarations mimic the mpfr.h and mpc.h declarations.  It seems to me that
 *   they ought to be:
 *			   int (*mpfr_trig)(mpfr_t rop, mpfr_t op, mp_rnd_t rnd),
 *			   void (*mpc_trig)(mpc_t rop, mpc_t op, mpc_rnd_t rnd))
 */
{
  s7_pointer p;
  p = car(args);

  /* I think here we should always promote to bignum (otherwise, for example, (exp 800) -> inf)
   */
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sym, args);
      return(simple_wrong_type_argument_with_type(sc, sym, p, A_NUMBER));
    }
  if (s7_is_real(p))
    {
      mpfr_t n;
      mpfr_init_set(n, big_real(promote_number(sc, T_BIG_REAL, p)), GMP_RNDN);
      mpfr_trig(n, n, GMP_RNDN);
      /* it's confusing to check for ints here via mpfr_integer_p because it
       *   is dependent on the precision!  (exp 617/5) returns an integer if
       *   precision is 128, but a float if 512.
       */
      p = mpfr_to_big_real(sc, n);
      mpfr_clear(n);
      return(p);
    }

  if (!is_big_number(p))
    p = promote_number(sc, T_BIG_COMPLEX, p);

  if (tan_case == TRIG_TAN_CHECK)
    {
      if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(p), 1, 350))) > 0)
	return(s7_make_complex(sc, 0.0, 1.0));	
      if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(p), 1, -350))) < 0)
	return(s7_make_complex(sc, 0.0, -1.0));	
    }
  
  if (tan_case == TRIG_TANH_CHECK)
    {
      if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(p), 350, 1))) > 0)
	return(real_one);
      if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(p), -350, 1))) < 0)
	return(make_real(sc, -1.0));
    }
  
  {
    mpc_t n;
    double ix;

    mpc_init(n);
    mpc_trig(n, big_complex(p), MPC_RNDNN);  
    /* (sin (bignum "1e15+1e15i")) causes mpc to hang (e9 is ok, but e10 hangs) 
     *   (sin (bignum "0+1e10i")) -> 0+inf (sin (bignum "1+1e10i")) hangs
     *
     * before comparing imag-part to 0, we need to look for NaN and inf, else:
     *    (sinh 0+0/0i) -> 0.0
     *    (sinh (log 0.0)) -> inf.0
     */

    ix = mpfr_get_d(mpc_imagref(n), GMP_RNDN);
    if (ix == 0.0)
      {
	mpfr_t z;

	mpfr_init_set(z, mpc_realref(n), GMP_RNDN);
	p = mpfr_to_big_real(sc, z);
	mpfr_clear(z);
      }
    else p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_sin(s7_scheme *sc, s7_pointer args)
{
  #define H_sin "(sin z) returns sin(z)"
  return(big_trig(sc, args, mpfr_sin, mpc_sin, TRIG_NO_CHECK, sc->SIN));
}

s7_pointer s7_sin(s7_scheme *sc, s7_pointer x)
{
  return(big_sin(sc, cons(sc, x, sc->NIL)));
}


static s7_pointer big_cos(s7_scheme *sc, s7_pointer args)
{
  #define H_cos "(cos z) returns cos(z)"
  return(big_trig(sc, args, mpfr_cos, mpc_cos, TRIG_NO_CHECK, sc->COS));
}


s7_pointer s7_cos(s7_scheme *sc, s7_pointer x)
{
  return(big_cos(sc, cons(sc, x, sc->NIL)));
}


static s7_pointer big_tan(s7_scheme *sc, s7_pointer args)
{
  #define H_tan "(tan z) returns tan(z)"
  return(big_trig(sc, args, mpfr_tan, mpc_tan, TRIG_TAN_CHECK, sc->TAN));
}


static s7_pointer big_sinh(s7_scheme *sc, s7_pointer args)
{
  #define H_sinh "(sinh z) returns sinh(z)"
  /* currently (sinh 0+0/0i) -> 0.0? */
  return(big_trig(sc, args, mpfr_sinh, mpc_sinh, TRIG_NO_CHECK, sc->SINH));
}


static s7_pointer big_cosh(s7_scheme *sc, s7_pointer args)
{
  #define H_cosh "(cosh z) returns cosh(z)"
  return(big_trig(sc, args, mpfr_cosh, mpc_cosh, TRIG_NO_CHECK, sc->COSH));
}


static s7_pointer big_tanh(s7_scheme *sc, s7_pointer args)
{
  #define H_tanh "(tanh z) returns tanh(z)"
  return(big_trig(sc, args, mpfr_tanh, mpc_tanh, TRIG_TANH_CHECK, sc->TANH));
}


static s7_pointer big_exp(s7_scheme *sc, s7_pointer args)
{
  #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
  return(big_trig(sc, args, mpfr_exp, mpc_exp, TRIG_NO_CHECK, sc->EXP));
}


static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
{
  #define H_expt "(expt z1 z2) returns z1^z2"
  s7_pointer x, y, p;

  /* see comment under g_expt
   *  if (is_not_null(cddr(args)))
   *    return(big_expt(sc, list_2(sc, car(args), big_expt(sc, cdr(args)))));
   */

  x = car(args);
  if (!s7_is_number(x))
    {
      CHECK_METHOD(sc, x, sc->EXPT, args);
      return(wrong_type_argument_with_type(sc, sc->EXPT, small_int(1), x, A_NUMBER));
    }
  y = cadr(args);
  if (!s7_is_number(y))
    {
      CHECK_METHOD(sc, y, sc->EXPT, args);
      return(wrong_type_argument_with_type(sc, sc->EXPT, small_int(2), y, A_NUMBER));
    }
  if (s7_is_zero(x))
    {
      if ((s7_is_integer(x)) && 
	  (s7_is_integer(y)) &&
	  (s7_is_zero(y)))
	return(small_int(1));

      if (s7_is_real(y))
	{
	  if (s7_is_negative(y))
	    return(division_by_zero_error(sc, sc->EXPT, args));
	}
      else
	{
	  if (s7_is_negative(g_real_part(sc, cdr(args))))
	    return(division_by_zero_error(sc, sc->EXPT, args));
	}

      if ((s7_is_rational(x)) && 
	  (s7_is_rational(y)))
	return(small_int(0));

      return(real_zero);
    }

  if (s7_is_integer(y))
    {
      s7_Int yval;

      if (!is_big_number(y))
	yval = s7_integer(y);
      else yval = big_integer_to_s7_Int(big_integer(y));

      if (yval == 0)
	{
	  if (s7_is_rational(x))
	    return(small_int(1));
	  return(real_one);
	}

      if (yval == 1)
	return(x);

      if (!is_big_number(x))
	{
	  if ((s7_is_one(x)) || (s7_is_zero(x)))
	    return(x);
	}

      if ((yval < S7_LONG_MAX) &&
	  (yval > S7_LONG_MIN))
	{
	  if (s7_is_integer(x))
	    {
	      mpz_t n;
	      mpq_t r;

	      x = promote_number(sc, T_BIG_INTEGER, x);
	      mpz_init_set(n, big_integer(x));
	      if (yval >= 0)
		{
		  mpz_pow_ui(n, n, (unsigned int)yval);
		  p = mpz_to_big_integer(sc, n);
		  mpz_clear(n);
		  return(p);
		}

	      mpz_pow_ui(n, n, (unsigned int)(-yval));
	      mpq_init(r);
	      mpq_set_z(r, n);
	      mpq_inv(r, r);
	      if (mpz_cmp_ui(mpq_denref(r), 1) == 0)
		{
		  mpz_t z;
		  mpz_init_set(z, mpq_numref(r));
		  mpq_clear(r);
		  mpz_clear(n);
		  p = mpz_to_big_integer(sc, z);
		  mpz_clear(z);
		  return(p);
		}
	      mpz_clear(n);
	      p = mpq_to_big_ratio(sc, r);
	      mpq_clear(r);
	      return(p);
	    }
	}

      if (s7_is_ratio(x)) /* (here y is an integer) */
	{
	  mpz_t n, d;
	  mpq_t r;

	  if (yval > (S7_LLONG_MAX >> 4)) /* gmp aborts or segfaults if this is too large, but I don't know where the actual boundary is */
	    return(s7_out_of_range_error(sc, "integer expt exponent", 1, y, "gmp will segfault"));

	  x = promote_number(sc, T_BIG_RATIO, x);
	  mpz_init_set(n, mpq_numref(big_ratio(x)));
	  mpz_init_set(d, mpq_denref(big_ratio(x)));
	  mpq_init(r);
	  if (yval >= 0)
	    {
	      mpz_pow_ui(n, n, (unsigned int)yval);
	      mpz_pow_ui(d, d, (unsigned int)yval);
	      mpq_set_num(r, n);
	      mpq_set_den(r, d);
	    }
	  else
	    {
	      yval = -yval;
	      mpz_pow_ui(n, n, (unsigned int)yval);
	      mpz_pow_ui(d, d, (unsigned int)yval);
	      mpq_set_num(r, d);
	      mpq_set_den(r, n);	      
	      mpq_canonicalize(r);
	    }
	  mpz_clear(n);
	  mpz_clear(d);
	  if (mpz_cmp_ui(mpq_denref(r), 1) == 0)
	    {
	      mpz_t z;
	      mpz_init_set(z, mpq_numref(r));
	      mpq_clear(r);
	      p = mpz_to_big_integer(sc, z);
	      mpz_clear(z);
	      return(p);
	    }
	  p = mpq_to_big_ratio(sc, r);
	  mpq_clear(r);
	  return(p);
	}

      if (s7_is_real(x))
	{
	  mpfr_t z;
	  x = promote_number(sc, T_BIG_REAL, x);
	  mpfr_init_set(z, big_real(x), GMP_RNDN);
	  mpfr_pow_si(z, z, yval, GMP_RNDN);
	  p = mpfr_to_big_real(sc, z);
	  mpfr_clear(z);
	  return(p);
	}
    }

  if ((s7_is_ratio(y)) &&
      (numerator(y) == 1))
    {
      if (denominator(y) == 2)
	return(big_sqrt(sc, args));

      if ((s7_is_real(x)) &&
	  (denominator(y) == 3))
	{
	  mpfr_t z;
	  mpfr_init_set(z, big_real(promote_number(sc, T_BIG_REAL, x)), GMP_RNDN);
	  mpfr_cbrt(z, z, GMP_RNDN);
	  p = mpfr_to_big_real(sc, z);
	  mpfr_clear(z);
	  return(p);
	}
    }

  if ((s7_is_real(x)) &&
      (s7_is_real(y)) &&
      (s7_is_positive(x)))
    {
      mpfr_t z;
      mpfr_init_set(z, big_real(promote_number(sc, T_BIG_REAL, x)), GMP_RNDN);
      mpfr_pow(z, z, big_real(promote_number(sc, T_BIG_REAL, y)), GMP_RNDN);
      p = mpfr_to_big_real(sc, z);
      mpfr_clear(z);
      return(p);
    }

  {
    mpc_t cy;
    mpc_t z;
    
    x = promote_number(sc, T_BIG_COMPLEX, x);
    y = promote_number(sc, T_BIG_COMPLEX, y);
    
    mpc_init(z);
    mpc_set(z, big_complex(x), MPC_RNDNN);
    
    if (mpc_cmp_si_si(z, 0, 0) == 0)
      {
	mpc_clear(z);
	return(small_int(0));
      }
    
    if (mpc_cmp_si_si(z, 1, 0) == 0)
      {
	mpc_clear(z);
	return(small_int(1));
      }
    
    mpc_init(cy);
    mpc_set(cy, big_complex(y), MPC_RNDNN);
    mpc_pow(z, z, cy, MPC_RNDNN);
    mpc_clear(cy);
    
    if (mpfr_cmp_ui(mpc_imagref(z), 0) == 0)
      {
	mpfr_t n;
	if ((s7_is_rational(car(args))) &&
	    (s7_is_rational(cadr(args))) &&
	    (mpfr_integer_p(mpc_realref(z)) != 0))
	  {
	    /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum "617/5")) returns an int if precision=128, float if 512 */
	    /*   so first make sure we're within (say) 31 bits */
	    mpfr_t zi;
	    mpfr_init_set_ui(zi, S7_LONG_MAX, GMP_RNDN);
	    if (mpfr_cmpabs(mpc_realref(z), zi) < 0)
	      {
		mpz_t k;
		mpz_init(k);
		mpfr_get_z(k, mpc_realref(z), GMP_RNDN);
		mpc_clear(z);
		mpfr_clear(zi);
		p = mpz_to_big_integer(sc, k);
		mpz_clear(k);
		return(p);
	      }
	    mpfr_clear(zi);
	  }

	mpfr_init_set(n, mpc_realref(z), GMP_RNDN);
	mpc_clear(z);
	p = mpfr_to_big_real(sc, n);
	mpfr_clear(n);
	return(p);
      }
    
    p = mpc_to_big_complex(sc, z);
    mpc_clear(z);
    return(p);
  }
}


static s7_pointer big_asinh(s7_scheme *sc, s7_pointer args)
{
  #define H_asinh "(asinh z) returns asinh(z)"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->ASINH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ASINH, p, A_NUMBER));
    }
  if (s7_is_real(p))
    {
      mpfr_t n;
      p = promote_number(sc, T_BIG_REAL, p);
      mpfr_init_set(n, big_real(p), GMP_RNDN);
      mpfr_asinh(n, n, GMP_RNDN);
      p = mpfr_to_big_real(sc, n);
      mpfr_clear(n);
      return(p);
    }

  {
    mpc_t n;
    p = promote_number(sc, T_BIG_COMPLEX, p);
    mpc_init(n);
    mpc_set(n, big_complex(p), MPC_RNDNN);
    mpc_asinh(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_acosh(s7_scheme *sc, s7_pointer args)
{
  #define H_acosh "(acosh z) returns acosh(z)"
  s7_pointer p;
  double x;
  mpc_t n;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->ACOSH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ACOSH, p, A_NUMBER));
    }
  p = promote_number(sc, T_BIG_COMPLEX, p);
  
  mpc_init(n);
  mpc_set(n, big_complex(p), MPC_RNDNN);
  mpc_acosh(n, n, MPC_RNDNN);
  
  x = mpfr_get_d(mpc_imagref(n), GMP_RNDN);
  if (x == 0.0)
    p = mpfr_to_big_real(sc, mpc_realref(n));
  else p = mpc_to_big_complex(sc, n);
  mpc_clear(n);
  return(p);
}


static s7_pointer big_atanh(s7_scheme *sc, s7_pointer args)
{
  #define H_atanh "(atanh z) returns atanh(z)"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->ATANH, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ATANH, p, A_NUMBER));
    }
  if (s7_is_real(p))
    {
      bool ok;
      mpfr_t temp;
      p = promote_number(sc, T_BIG_REAL, p);
      mpfr_init_set_ui(temp, 1, GMP_RNDN);
      ok = (mpfr_cmpabs(big_real(p), temp) < 0);
      mpfr_clear(temp);
      if (ok)
	{
	  mpfr_t n;
	  mpfr_init_set(n, big_real(p), GMP_RNDN);
	  mpfr_atanh(n, n, GMP_RNDN);
	  p = mpfr_to_big_real(sc, n);
	  mpfr_clear(n);
	  return(p);
	}
    }

  {
    mpc_t n;
    p = promote_number(sc, T_BIG_COMPLEX, p);
    mpc_init(n);
    mpc_set(n, big_complex(p), MPC_RNDNN);
    mpc_atanh(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_atan(s7_scheme *sc, s7_pointer args)
{
  #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
  s7_pointer p0, p1 = NULL, p;

  p0 = car(args);
  if (!s7_is_number(p0))
    {
      CHECK_METHOD(sc, p0, sc->ATAN, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ATAN, p0, A_NUMBER));
    }
  if (is_not_null(cdr(args)))
    {
      p1 = cadr(args);
      if (!s7_is_real(p1))
	{
	  CHECK_METHOD(sc, p1, sc->ATAN, args);
	  return(wrong_type_argument(sc, sc->ATAN, small_int(2), p1, T_REAL));
	}
      if (!s7_is_real(p0))
	return(wrong_type_argument(sc, sc->ATAN, small_int(1), p0, T_REAL));

      p1 = promote_number(sc, T_BIG_REAL, p1);
    }

  if (s7_is_real(p0))
    {
      mpfr_t n;
      p0 = promote_number(sc, T_BIG_REAL, p0);
      mpfr_init_set(n, big_real(p0), GMP_RNDN);
      if (!p1)
	mpfr_atan(n, n, GMP_RNDN);
      else mpfr_atan2(n, n, big_real(p1), GMP_RNDN);
      p = mpfr_to_big_real(sc, n);
      mpfr_clear(n);
      return(p);
    }

  {
    mpc_t n;
    p0 = promote_number(sc, T_BIG_COMPLEX, p0);
    mpc_init_set(n, big_complex(p0), MPC_RNDNN);
    mpc_atan(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_acos(s7_scheme *sc, s7_pointer args)
{
  #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->ACOS, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ACOS, p, A_NUMBER));
    }
  if (s7_is_real(p))
    {
      bool ok;
      mpfr_t temp;
      mpfr_t n;
      p = promote_number(sc, T_BIG_REAL, p);
      mpfr_init_set(n, big_real(p), GMP_RNDN);
      mpfr_init_set_ui(temp, 1, GMP_RNDN);
      ok = (mpfr_cmpabs(n, temp) <= 0);
      mpfr_clear(temp);
      if (ok)
	{
	  mpfr_acos(n, n, GMP_RNDN);
	  p = mpfr_to_big_real(sc, n);
	  mpfr_clear(n);
	  return(p);
	}
      mpfr_clear(n);
    }

  {
    mpc_t n;
    p = promote_number(sc, T_BIG_COMPLEX, p);
    mpc_init_set(n, big_complex(p), MPC_RNDNN);
    mpc_acos(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_asin(s7_scheme *sc, s7_pointer args)
{
  #define H_asin "(asin z) returns asin(z); (sin (asin 1)) = 1"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    {
      CHECK_METHOD(sc, p, sc->ASIN, args);
      return(simple_wrong_type_argument_with_type(sc, sc->ASIN, p, A_NUMBER));
    }
  if (s7_is_real(p))
    {
      bool ok;
      mpfr_t temp;
      mpfr_t n;
      p = promote_number(sc, T_BIG_REAL, p);
      mpfr_init_set(n, big_real(p), GMP_RNDN);
      mpfr_init_set_ui(temp, 1, GMP_RNDN);
      ok = (mpfr_cmpabs(n, temp) <= 0);
      mpfr_clear(temp);
      if (ok)
	{
	  mpfr_asin(n, n, GMP_RNDN);
	  p = mpfr_to_big_real(sc, n);
	  mpfr_clear(n);
	  return(p);
	}
      mpfr_clear(n);
    }

  {
    mpc_t n;
    p = promote_number(sc, T_BIG_COMPLEX, p);
    mpc_init_set(n, big_complex(p), MPC_RNDNN);
    mpc_asin(n, n, MPC_RNDNN);
    p = mpc_to_big_complex(sc, n);
    mpc_clear(n);
    return(p);
  }
}


static s7_pointer big_lognot(s7_scheme *sc, s7_pointer args)
{
  if (type(car(args)) == T_BIG_INTEGER)
    {
      s7_pointer p;
      mpz_t n;
      mpz_init(n);
      mpz_com(n, big_integer(car(args)));
      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  return(g_lognot(sc, args));
}


static s7_pointer big_integer_length(s7_scheme *sc, s7_pointer args)
{
  if (type(car(args)) == T_BIG_INTEGER)
    {
      s7_pointer result;
      mpfr_t n;
      mpfr_init_set_z(n, big_integer(car(args)), GMP_RNDN);
      if (mpfr_cmp_ui(n, 0) < 0)
	mpfr_neg(n, n, GMP_RNDN);
      else mpfr_add_ui(n, n, 1, GMP_RNDN);
      mpfr_log2(n, n, GMP_RNDU);
      result = make_integer(sc, mpfr_get_si(n, GMP_RNDU));
      mpfr_clear(n);
      return(result);
    }
  return(g_integer_length(sc, args));
}


static s7_pointer big_ash(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p0, p1;

  p0 = car(args);
  p1 = cadr(args);
  /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums
   *   so there's no way to tell when it's safe to drop into g_ash instead.
   */
  if ((s7_is_integer(p0)) && /* this includes bignum ints... */
      (s7_is_integer(p1)))
    {
      mpz_t n;
      s7_Int shift;
      s7_pointer p;
      bool p0_is_big;
      int p0_compared_to_zero = 0;

      p0_is_big = is_big_number(p0);
      if (p0_is_big)
	p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0);
      else 
	{
	  if (s7_integer(p0) > 0)
	    p0_compared_to_zero = 1;
	  else
	    {
	      if (s7_integer(p0) < 0)
		p0_compared_to_zero = -1;
	      else p0_compared_to_zero = 0;
	    }
	}

      if (p0_compared_to_zero == 0)
	return(small_int(0));

      if (is_big_number(p1))
	{
	  if (!mpz_fits_sint_p(big_integer(p1)))
	    {
	      if (mpz_cmp_ui(big_integer(p1), 0) > 0)
		return(out_of_range(sc, sc->ASH, small_int(2), p1, "shift is too large"));

	      /* here if p0 is negative, we need to return -1 */
	      if (p0_compared_to_zero == 1)
		return(small_int(0));
	      return(make_integer(sc, -1));
	    }
	  shift = mpz_get_si(big_integer(p1));
	}
      else 
	{
	  shift = s7_integer(p1);
	  if (shift < S7_LONG_MIN)
	    {
	      if (p0_compared_to_zero == 1)
		return(small_int(0));
	      return(make_integer(sc, -1));
	    }
	}

      mpz_init_set(n, big_integer(promote_number(sc, T_BIG_INTEGER, p0)));
      if (shift > 0)     /* left */
	mpz_mul_2exp(n, n, shift);
      else
	{
	  if (shift < 0) /* right */
	    mpz_fdiv_q_2exp(n, n, (unsigned int)(-shift));
	}
      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  return(g_ash(sc, args));
}


static s7_pointer big_bits(s7_scheme *sc, s7_pointer args, s7_pointer sym, int start, s7_function g_bits, 
			   void (*mpz_bits)(mpz_ptr, mpz_srcptr, mpz_srcptr))
{
  s7_pointer x;
  bool use_bigs = false;
  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!s7_is_integer(car(x)))
	{
	  CHECK_METHOD(sc, car(x), sym, args);
	  return(wrong_type_argument_n(sc, sym, position_of(x, args), car(x), T_INTEGER));  
	}
      if (type(car(x)) == T_BIG_INTEGER)
	use_bigs = true;
    }
  if (use_bigs)
    {
      mpz_t n;
      mpz_init_set_si(n, 0);
      if (start == -1)
	mpz_sub_ui(n, n, 1);
      for (x = args; is_not_null(x); x = cdr(x))
	mpz_bits(n, n, big_integer(promote_number(sc, T_BIG_INTEGER, car(x))));
      x = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(x);
    }
  return(g_bits(sc, args));
}


static s7_pointer big_logand(s7_scheme *sc, s7_pointer args)
{
  if (is_null(args))
    return(make_integer(sc, -1));
  return(big_bits(sc, args, sc->LOGAND, -1, g_logand, mpz_and));
}


static s7_pointer big_logior(s7_scheme *sc, s7_pointer args)
{
  if (is_null(args))
    return(small_int(0));
  return(big_bits(sc, args, sc->LOGIOR, 0, g_logior, mpz_ior));
}


static s7_pointer big_logxor(s7_scheme *sc, s7_pointer args)
{
  if (is_null(args))
    return(small_int(0));
  return(big_bits(sc, args, sc->LOGXOR, 0, g_logxor, mpz_xor));
}


static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
{
  #define H_rationalize "(rationalize x err) returns the ratio with lowest denominator within err of x"

  /* 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.
   *
   * a confusing case:
   *      > (rationalize 5925563891587147521650777143.74135805596e05)
   *   should be 148139097289678688041269428593533951399/250000
   *   but that requires more than 128 bits of bignum-precision.
   */

  s7_pointer p0, p1 = NULL, p;
  mpfr_t error, ux, x0, x1;
  mpz_t i, i0, i1;
  double xx;

  p0 = car(args);
  if (!s7_is_real(p0))
    {
      CHECK_METHOD(sc, p0, sc->RATIONALIZE, args);
      return(wrong_type_argument(sc, sc->RATIONALIZE, small_int(1), p0, T_REAL));
    }
  /* p0 can be exact, but we still have to check it for simplification */
  if (is_not_null(cdr(args)))
    {
      double err_x;
      p1 = cadr(args);
      if (!s7_is_real(p1))              /* (rationalize (expt 2 60) -) */
	{
	  CHECK_METHOD(sc, p1, sc->RATIONALIZE, args);
	  return(wrong_type_argument(sc, sc->RATIONALIZE, small_int(2), p1, T_REAL));
	}
      if (is_big_number(p1))
	mpfr_init_set(error, big_real(promote_number(sc, T_BIG_REAL, p1)), GMP_RNDN);
      else mpfr_init_set_d(error, s7_number_to_real(sc, p1), GMP_RNDN);

      err_x = mpfr_get_d(error, GMP_RNDN);
      if (is_NaN(err_x))
	{
	  mpfr_clear(error);
	  return(out_of_range(sc, sc->RATIONALIZE, small_int(2), cadr(args), "error term is NaN"));
	}
      if (mpfr_inf_p(error) != 0)
	{
	  mpfr_clear(error);
	  return(small_int(0));
	}
      mpfr_abs(error, error, GMP_RNDN);
    }
  else mpfr_init_set_d(error, default_rationalize_error, GMP_RNDN);
  
  if (is_big_number(p0))
    mpfr_init_set(ux, big_real(promote_number(sc, T_BIG_REAL, p0)), GMP_RNDN);
  else mpfr_init_set_d(ux, s7_number_to_real(sc, p0), GMP_RNDN);

  xx = mpfr_get_d(ux, GMP_RNDN);  
  if (is_NaN(xx))
    {
      mpfr_clear(ux);
      mpfr_clear(error);
      return(out_of_range(sc, sc->RATIONALIZE, small_int(1), car(args), "argument is NaN"));
    }
  if (mpfr_inf_p(ux) != 0)
    {
      mpfr_clear(ux);
      mpfr_clear(error);
      return(out_of_range(sc, sc->RATIONALIZE, small_int(1), car(args), "argument is infinite"));
    }

  mpfr_init_set(x0, ux, GMP_RNDN);        /* x0 = ux - error */
  mpfr_sub(x0, x0, error, GMP_RNDN);
  mpfr_init_set(x1, ux, GMP_RNDN);        /* x1 = ux + error */
  mpfr_add(x1, x1, error, GMP_RNDN);
  mpz_init(i);
  mpfr_get_z(i, x0, GMP_RNDU);            /* i = ceil(x0) */
  
  if (mpfr_cmp_ui(error, 1) >= 0)         /* if (error >= 1.0) */
    {
      mpz_t n;
      
      if (mpfr_cmp_ui(x0, 0) < 0)                /* if (x0 < 0) */
	{
	  if (mpfr_cmp_ui(x1, 0) < 0)            /*   if (x1 < 0) */
	    {
	      mpz_init(n);
	      mpfr_get_z(n, x1, GMP_RNDD);       /*     num = floor(x1) */
	    }
	  else mpz_init_set_ui(n, 0);            /*   else num = 0 */
	}
      else mpz_init_set(n, i);                   /* else num = i */
      
      mpz_clear(i);
      mpfr_clear(ux);
      mpfr_clear(x0);
      mpfr_clear(x1);
      mpfr_clear(error);
      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  
  if (mpfr_cmp_z(x1, i) >= 0)                /* if (x1 >= i) */
    {
      mpz_t n;
      
      if (mpz_cmp_ui(i, 0) >= 0)            /* if (i >= 0) */
	mpz_init_set(n, i);                 /*   num = i */
      else
	{
	  mpz_init(n);
	  mpfr_get_z(n, x1, GMP_RNDD);      /* else num = floor(x1) */
	}
      
      mpz_clear(i);
      mpfr_clear(ux);
      mpfr_clear(x0);
      mpfr_clear(x1);
      mpfr_clear(error);
      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  
  {
    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;
    
    mpz_init(i0);
    mpz_init(i1);
    mpfr_get_z(i0, x0, GMP_RNDD);            /* i0 = floor(x0) */
    mpfr_get_z(i1, x1, GMP_RNDU);            /* i1 = ceil(x1) */
    
    mpz_init_set(p0, i0);                    /* p0 = i0 */
    mpz_init_set_ui(q0, 1);                  /* q0 = 1 */
    mpz_init_set(p1, i1);                    /* p1 = i1 */
    mpz_init_set_ui(q1, 1);                  /* q1 = 1 */
    mpfr_init(e0);
    mpfr_init(e1);
    mpfr_init(e0p);
    mpfr_init(e1p);
    mpfr_sub_z(e0, x0, i1, GMP_RNDN);        /* e0 = i1 - x0 */
    mpfr_neg(e0, e0, GMP_RNDN);
    mpfr_sub_z(e1, x0, i0, GMP_RNDN);        /* e1 = x0 - i0 */
    mpfr_sub_z(e0p, x1, i1, GMP_RNDN);       /* e0p = i1 - x1 */
    mpfr_neg(e0p, e0p, GMP_RNDN);
    mpfr_sub_z(e1p, x1, i0, GMP_RNDN);       /* e1p = x1 - i0 */
    
    mpfr_init(val);
    
    mpfr_init(old_e0);
    mpfr_init(old_e1);
    mpfr_init(old_e0p);
    
    mpz_init(r);
    mpz_init(r1);
    mpz_init(old_p1);
    mpz_init(old_q1);
    
    while (true)
      {
	mpfr_set_z(val, p0, GMP_RNDN);
	mpfr_div_z(val, val, q0, GMP_RNDN);  /* val = p0/q0 */
	
	if (((mpfr_cmp(x0, val) <= 0) &&      /* if ((x0 <= val) && (val <= x1)) */
	     (mpfr_cmp(val, x1) <= 0)) ||
	    (mpfr_cmp_ui(e1, 0) == 0) ||
	    (mpfr_cmp_ui(e1p, 0) == 0)) 
	  /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */
	  {
	    mpq_t q;
	    mpq_init(q);
	    mpq_set_num(q, p0);            /* return(p0/q0) */
	    mpq_set_den(q, q0);
	    
	    mpz_clear(i);
	    mpz_clear(i0);
	    mpz_clear(i1);
	    mpfr_clear(ux);
	    mpfr_clear(x0);
	    mpfr_clear(x1);
	    mpfr_clear(error);
	    
	    mpz_clear(p0);
	    mpz_clear(q0);
	    mpz_clear(r);
	    mpz_clear(r1);
	    mpz_clear(p1);
	    mpz_clear(q1);
	    mpz_clear(old_p1);
	    mpz_clear(old_q1);
	    
	    mpfr_clear(val);
	    mpfr_clear(e0);
	    mpfr_clear(e1);
	    mpfr_clear(e0p);
	    mpfr_clear(e1p);
	    mpfr_clear(old_e0);
	    mpfr_clear(old_e1);
	    mpfr_clear(old_e0p);
	    
	    p = mpq_to_big_ratio(sc, q);
	    mpq_clear(q);
	    return(p);
	  }
	
	mpfr_div(val, e0, e1, GMP_RNDN);
	mpfr_get_z(r, val, GMP_RNDD);           /* r = floor(e0/e1) */
	mpfr_div(val, e0p, e1p, GMP_RNDN);
	mpfr_get_z(r1, val, GMP_RNDU);          /* r1 = ceil(e0p/e1p) */
	if (mpz_cmp(r1, r) < 0)                 /* if (r1 < r) */
	  mpz_set(r, r1);                       /*   r = r1 */
	
	mpz_set(old_p1, p1);                    /* old_p1 = p1 */
	mpz_set(p1, p0);                        /* p1 = p0 */
	mpz_set(old_q1, q1);                    /* old_q1 = q1 */
	mpz_set(q1, q0);                        /* q1 = q0 */
	
	mpfr_set(old_e0, e0, GMP_RNDN);         /* old_e0 = e0 */
	mpfr_set(e0, e1p, GMP_RNDN);            /* e0 = e1p */
	mpfr_set(old_e0p, e0p, GMP_RNDN);       /* old_e0p = e0p */
	mpfr_set(e0p, e1, GMP_RNDN);            /* e0p = e1 */
	mpfr_set(old_e1, e1, GMP_RNDN);         /* old_e1 = e1 */
	
	mpz_mul(p0, p0, r);                     /* p0 = old_p1 + r * p0 */
	mpz_add(p0, p0, old_p1); 
	
	mpz_mul(q0, q0, r);                     /* q0 = old_q1 + r * q0 */
	mpz_add(q0, q0, old_q1); 
	
	mpfr_mul_z(e1, e1p, r, GMP_RNDN);       /* e1 = old_e0p - r * e1p */
	mpfr_sub(e1, old_e0p, e1, GMP_RNDN); 
	
	mpfr_mul_z(e1p, old_e1, r, GMP_RNDN);   /* e1p = old_e0 - r * old_e1 */
	mpfr_sub(e1p, old_e0, e1p, GMP_RNDN); 
      }
  }
}


static s7_pointer big_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"
  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))   /* apparently (exact->inexact 1+i) is not an error */
    {
      CHECK_METHOD(sc, p, sc->EXACT_TO_INEXACT, args);
      return(simple_wrong_type_argument_with_type(sc, sc->EXACT_TO_INEXACT, p, A_NUMBER));
    }
  if (!s7_is_rational(p))
    return(p);

  return(promote_number(sc, T_BIG_REAL, to_big(sc, p)));
}


static s7_pointer big_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"

  s7_pointer p;
  p = car(args);

  if (s7_is_rational(p))
    return(p);

  if (!s7_is_real(p))
    {
      CHECK_METHOD(sc, p, sc->INEXACT_TO_EXACT, args);
      return(simple_wrong_type_argument(sc, sc->INEXACT_TO_EXACT, p, T_REAL));
    }
  return(big_rationalize(sc, args));
}


static s7_pointer big_convert_to_int(s7_scheme *sc, s7_pointer args,
				     s7_pointer sym,
				     void (*div_func)(mpz_ptr, mpz_srcptr, mpz_srcptr),
				     mp_rnd_t mode)
{
  /* we can't go to the normal (non-gmp) functions here */
  s7_pointer p;
  mpz_t n;

  p = car(args);
  if (!s7_is_real(p))
    {
      CHECK_METHOD(sc, p, sym, args);
      return(simple_wrong_type_argument(sc, sym, p, T_REAL));
    }
  if (s7_is_integer(p))
    return(p);

  p = to_big(sc, p);
  if (type(p) == T_BIG_RATIO)
    {
      /* apparently we have to do the divide by hand */
      mpz_t d;
      mpz_init_set(n, mpq_numref(big_ratio(p)));
      mpz_init_set(d, mpq_denref(big_ratio(p)));
      div_func(n, n, d);
      mpz_clear(d);
    }
  else
    {
      if ((g_is_nan(sc, args) == sc->T) ||
	  (g_is_infinite(sc, args)) == sc->T)
	return(simple_out_of_range(sc, sym, p, "argument is NaN or infinite"));

      mpz_init(n);
      mpfr_get_z(n, big_real(p), mode);
    }
  p = mpz_to_big_integer(sc, n);
  mpz_clear(n);
  return(p);
}


static s7_pointer big_floor(s7_scheme *sc, s7_pointer args)
{
  #define H_floor "(floor x) returns the integer closest to x toward -inf"
  return(big_convert_to_int(sc, args, sc->FLOOR, mpz_fdiv_q, GMP_RNDD));
}


static s7_pointer big_ceiling(s7_scheme *sc, s7_pointer args)
{
  #define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
  return(big_convert_to_int(sc, args, sc->CEILING, mpz_cdiv_q, GMP_RNDU));
}


static s7_pointer big_truncate(s7_scheme *sc, s7_pointer args)
{
  #define H_truncate "(truncate x) returns the integer closest to x toward 0"
  return(big_convert_to_int(sc, args, sc->TRUNCATE, mpz_tdiv_q, GMP_RNDZ));
}


static s7_pointer big_round(s7_scheme *sc, s7_pointer args)
{
  #define H_round "(round x) returns the integer closest to x"
  s7_pointer p;
  mpz_t n;

  p = car(args);
  if (!s7_is_real(p))
    {
      CHECK_METHOD(sc, p, sc->ROUND, args);
      return(simple_wrong_type_argument(sc, sc->ROUND, p, T_REAL));
    }
  if (s7_is_integer(p))
    return(p);

  p = to_big(sc, p);
  if (type(p) == T_BIG_INTEGER)
    return(p);

  if (type(p) == T_BIG_RATIO)
    {
      int rnd;
      mpz_t rm;
      mpz_init_set(n, mpq_numref(big_ratio(p)));
      mpz_init(rm);
      mpz_fdiv_qr(n, rm, n, mpq_denref(big_ratio(p)));
      mpz_mul_ui(rm, rm, 2);
      rnd = mpz_cmpabs(rm, mpq_denref(big_ratio(p)));
      mpz_fdiv_q(rm, rm, mpq_denref(big_ratio(p)));
      if (rnd > 0)
	mpz_add(n, n, rm);
      else
	{
	  if (rnd == 0)
	    {
	      if (mpz_odd_p(n))
		mpz_add_ui(n, n, 1);
	    }
	}
      mpz_clear(rm);
      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }

  if ((g_is_nan(sc, args) == sc->T) ||
      (g_is_infinite(sc, args)) == sc->T)
    return(simple_out_of_range(sc, sc->ROUND, p, "argument is NaN or infinite"));

  {
    int cmp_res;
    mpz_t fl, ce;
    mpfr_t x, dfl, dce;
    mpfr_init_set(x, big_real(p), GMP_RNDN);
    mpz_init(fl);
    mpfr_get_z(fl, x, GMP_RNDD);           /* fl = floor(x) */
    mpz_init(ce);
    mpfr_get_z(ce, x, GMP_RNDU);           /* ce = ceil(x) */
    mpfr_init(dfl);
    mpfr_sub_z(dfl, x, fl, GMP_RNDN);      /* dfl = x - fl */
    mpfr_init(dce);
    mpfr_sub_z(dce, x, ce, GMP_RNDN);      /* dce = -(ce - x) */
    mpfr_neg(dce, dce, GMP_RNDN);          /*    and reversed */
    cmp_res = mpfr_cmp(dfl, dce);
    if (cmp_res > 0)                       /* if (dfl > dce) return(ce) */
      mpz_init_set(n, ce);
    else
      {
	if (cmp_res < 0)                   /* if (dfl < dce) return(fl) */
	  mpz_init_set(n, fl);
	else
	  {
	    if (mpz_even_p(fl))
	      mpz_init_set(n, fl);         /* if (mod(fl, 2) == 0) return(fl) */
	    else mpz_init_set(n, ce);      /* else return(ce) */
	  }
      }
    mpz_clear(fl);
    mpz_clear(ce);
    mpfr_clear(dfl);
    mpfr_clear(dce);
    mpfr_clear(x);
    p = mpz_to_big_integer(sc, n);
    mpz_clear(n);
    return(p);
  }
}


static s7_pointer big_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"

  s7_pointer x, y, p;
  x = car(args);
  y = cadr(args);

  if (!s7_is_real(x))
    {
      CHECK_METHOD(sc, x, sc->QUOTIENT, args);
      return(wrong_type_argument(sc, sc->QUOTIENT, small_int(1), x, T_REAL));
    }
  if (!s7_is_real(y))
    {
      CHECK_METHOD(sc, y, sc->QUOTIENT, args);
      return(wrong_type_argument(sc, sc->QUOTIENT, small_int(2), y, T_REAL));
    }
  if ((s7_is_integer(x)) &&
      (s7_is_integer(y)))
    {
      mpz_t n;
      x = to_big(sc, x);
      y = to_big(sc, y);

      if (s7_is_zero(y))
	return(division_by_zero_error(sc, sc->QUOTIENT, args));
	  
      mpz_init_set(n, big_integer(x));
      mpz_tdiv_q(n, n, big_integer(y));

      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  return(big_truncate(sc, list_1(sc, big_divide(sc, args))));
}


static s7_pointer big_remainder(s7_scheme *sc, s7_pointer args)
{
  #define H_remainder "(remainder x1 x2) returns the integer remainder of x1 and x2; (remainder 10 3) = 1"
  s7_pointer x, y, p;
  x = car(args);
  y = cadr(args);

  if (!s7_is_real(x))
    {
      CHECK_METHOD(sc, x, sc->REMAINDER, args);
      return(wrong_type_argument(sc, sc->REMAINDER, small_int(1), x, T_REAL));
    }
  if (!s7_is_real(y))
    {
      CHECK_METHOD(sc, y, sc->REMAINDER, args);
      return(wrong_type_argument(sc, sc->REMAINDER, small_int(2), y, T_REAL));
    }
  if ((s7_is_integer(x)) &&
      (s7_is_integer(y)))
    {
      mpz_t n;
      x = to_big(sc, x);
      y = to_big(sc, y);

      if (s7_is_zero(y))
	return(division_by_zero_error(sc, sc->REMAINDER, args));
	  
      mpz_init_set(n, big_integer(x));
      mpz_tdiv_r(n, n, big_integer(y));

      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  return(big_subtract(sc, 
          list_2(sc, x, 
           big_multiply(sc, 
            list_2(sc, y, 
             big_quotient(sc, args))))));
}


static s7_pointer big_modulo(s7_scheme *sc, s7_pointer args)
{
  #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1.  The arguments can be real numbers."
  s7_pointer a, b, p;

  a = car(args);
  if (!s7_is_real(a))
    {
      CHECK_METHOD(sc, a, sc->MODULO, args);
      return(wrong_type_argument(sc, sc->MODULO, small_int(1), a, T_REAL));
    }
  b = cadr(args);
  if (!s7_is_real(b))
    {
      CHECK_METHOD(sc, b, sc->MODULO, args);
      return(wrong_type_argument(sc, sc->MODULO, small_int(2), b, T_REAL));
    }
  a = to_big(sc, a);
  b = to_big(sc, b);

  if ((s7_is_integer(a)) &&
      (s7_is_integer(b)))
    {
      s7_pointer x, y;
      int cy, cz;
      mpz_t n;
      
      y = promote_number(sc, T_BIG_INTEGER, b);
      if (mpz_cmp_ui(big_integer(y), 0) == 0)
	return(a);
      
      x = promote_number(sc, T_BIG_INTEGER, a);
      /* mpz_mod is too tricky here */

      mpz_init_set(n, big_integer(x));
      mpz_fdiv_r(n, n, big_integer(y));
      cy = mpz_cmp_ui(big_integer(y), 0);
      cz = mpz_cmp_ui(n, 0);
      if (((cy < 0) && (cz > 0)) ||
	  ((cy > 0) && (cz < 0)))
	mpz_add(n, n, big_integer(y));

      p = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(p);
    }
  return(big_subtract(sc, 
          list_2(sc, a, 
           big_multiply(sc, 
            list_2(sc, b, 
    	     big_floor(sc, 
              list_1(sc, 
               big_divide(sc, 
	        list_2(sc, a, b)))))))));
}


static int big_real_scan_args(s7_scheme *sc, s7_pointer args)
{
  int i, result_type = T_INTEGER;
  s7_pointer arg;

  for (i = 1, arg = args; is_not_null(arg); i++, arg = cdr(arg)) 
    {
      s7_pointer p;
      p = car(arg);
      if (!s7_is_real(p))
	return(-i);
      if (is_big_number(p))
	result_type = big_type_to_result_type(result_type, type(p));
      else result_type = normal_type_to_result_type(result_type, type(p));
    }
  return(result_type);
}


static s7_pointer big_max(s7_scheme *sc, s7_pointer args)
{
  int result_type;
  s7_pointer x, result, arg;
  
  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->MAX, args);
      return(wrong_type_argument_n(sc, sc->MAX, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  if (result_type < T_BIG_INTEGER)
    return(g_max(sc, args));

  result = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      arg = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(result), big_integer(arg)) < 0)
	    result = arg;
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(result), big_ratio(arg)) < 0)
	    result = arg;
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(result), big_real(arg)) < 0)
	    result = arg;
	  break;
	}
    }
  if (result_type == T_BIG_RATIO) /* maybe actual result was an int */
    {
      if (mpz_cmp_ui(mpq_denref(big_ratio(result)), 1) == 0)
	{
	  mpz_t n;
	  s7_pointer p;
	  mpz_init_set(n, mpq_numref(big_ratio(result)));
	  p = mpz_to_big_integer(sc, n);
	  mpz_clear(n);
	  return(p);
	}
    }
  return(result);
}


static s7_pointer big_min(s7_scheme *sc, s7_pointer args)
{
  int result_type;
  s7_pointer x, result, arg;
  
  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->MIN, args);
      return(wrong_type_argument_n(sc, sc->MIN, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  if (result_type < T_BIG_INTEGER)
    return(g_min(sc, args));

  result = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      arg = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(result), big_integer(arg)) > 0)
	    result = arg;
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(result), big_ratio(arg)) > 0)
	    result = arg;
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(result), big_real(arg)) > 0)
	    result = arg;
	  break;
	}
    }
  if (result_type == T_BIG_RATIO) /* maybe actual result was an int */
    {
      if (mpz_cmp_ui(mpq_denref(big_ratio(result)), 1) == 0)
	{
	  mpz_t n;
	  s7_pointer p;
	  mpz_init_set(n, mpq_numref(big_ratio(result)));
	  p = mpz_to_big_integer(sc, n);
	  mpz_clear(n);
	  return(p);
	}
    }
  return(result);
}


static s7_pointer big_less(s7_scheme *sc, s7_pointer args)
{
  #define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
  int result_type;
  s7_pointer x, previous, current;
  
  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->LT, args);
      return(wrong_type_argument_n(sc, sc->LT, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  /* don't try to use g_less here */
  if (result_type < T_BIG_INTEGER)
    result_type += 4;
  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      current = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(previous), big_integer(current)) >= 0) return(sc->F);
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(previous), big_ratio(current)) >= 0) return(sc->F);
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(previous), big_real(current)) >= 0) return(sc->F);
	  break;
	}
      previous = current;
    }
  return(sc->T);
}


static s7_pointer big_less_or_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in increasing order"
  int result_type;
  s7_pointer x, previous, current;
  
  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->LEQ, args);
      return(wrong_type_argument_n(sc, sc->LEQ, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  if (result_type < T_BIG_INTEGER)
    result_type += 4;
  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      current = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(previous), big_integer(current)) > 0) return(sc->F);
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(previous), big_ratio(current)) > 0) return(sc->F);
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(previous), big_real(current)) > 0) return(sc->F);
	  break;
	}
      previous = current;
    }
  return(sc->T);
}


static s7_pointer big_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
  int result_type;
  s7_pointer x, previous, current;

  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->GT, args);
      return(wrong_type_argument_n(sc, sc->GT, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  if (result_type < T_BIG_INTEGER)
    result_type += 4;
  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      current = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(previous), big_integer(current)) <= 0) return(sc->F);
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(previous), big_ratio(current)) <= 0) return(sc->F);
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(previous), big_real(current)) <= 0) return(sc->F);
	  break;
	}
      previous = current;
    }
  return(sc->T);
}


static s7_pointer big_greater_or_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in decreasing order"
  int result_type;
  s7_pointer x, previous, current;
  
  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    {
      CHECK_METHOD(sc, car(args), sc->GEQ, args);
      return(wrong_type_argument_n(sc, sc->GEQ, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));
    }
  if (result_type < T_BIG_INTEGER)
    result_type += 4;
  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x)) 
    {
      current = promote_number(sc, result_type, car(x));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(previous), big_integer(current)) < 0) return(sc->F);
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(previous), big_ratio(current)) < 0) return(sc->F);
	  break;

	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(previous), big_real(current)) < 0) return(sc->F);
	  break;
	}
      previous = current;
    }
  return(sc->T);
}


static s7_pointer big_equal(s7_scheme *sc, s7_pointer args)
{
  int result_type = T_INTEGER;
  s7_pointer x, y, result;

  for (x = args; is_not_null(x); x = cdr(x)) 
    {
      s7_pointer p;
      p = car(x);
      if (!is_number(p))
	{
	  if (!is_big_number(p))
	    {
	      CHECK_METHOD(sc, p, sc->EQ, args);
	      return(wrong_type_argument_n_with_type(sc, sc->EQ, position_of(x, args), p, A_NUMBER));
	    }
	  else result_type = big_type_to_result_type(result_type, type(p));
	}
      else 
	{
	  switch (type(p))
	    {
	    case T_INTEGER:
	    case T_RATIO:
	      break;

	    case T_REAL:
	      if (is_NaN(real(p)))  /* (= (bignum "3") 1/0) */
		return(sc->F);

	    default:
	      if ((is_NaN(real_part(p))) ||
		  (is_NaN(imag_part(p))))
		return(sc->F);
	    }
	  result_type = normal_type_to_result_type(result_type, type(p));
	}
    }

  if (result_type < T_BIG_INTEGER)
    return(g_equal(sc, args));

  result = promote_number(sc, result_type, car(args));

  for (y = cdr(args); is_not_null(y); y = cdr(y)) 
    {
      s7_pointer arg;
      arg = promote_number(sc, result_type, car(y));
      switch (result_type)
	{
	case T_BIG_INTEGER:
	  if (mpz_cmp(big_integer(result), big_integer(arg)) != 0) return(sc->F);
	  break;
	  
	case T_BIG_RATIO:
	  if (mpq_cmp(big_ratio(result), big_ratio(arg)) != 0) return(sc->F);
	  break;
	  
	case T_BIG_REAL:
	  if (mpfr_cmp(big_real(result), big_real(arg)) != 0) return(sc->F);
	  break;
	  
	case T_BIG_COMPLEX:
	  if (mpc_cmp(big_complex(result), big_complex(arg)) != 0) return(sc->F);
	  break;
	}
    }
  return(sc->T);
}


static s7_pointer big_gcd(s7_scheme *sc, s7_pointer args)
{
  #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
  bool rats = false;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x)) 
    if (!s7_is_rational(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->GCD, args);
	return(wrong_type_argument_n_with_type(sc, sc->GCD, position_of(x, args), car(x), A_RATIONAL));
      }
    else rats = ((rats) || (!s7_is_integer(car(x))));

  if (is_null(cdr(args)))    /* (gcd -2305843009213693951/4611686018427387903) */
    return(big_abs(sc, args)); 

  if (!rats)
    {
      mpz_t n;
      mpz_init(n);
      for (x = args; is_not_null(x); x = cdr(x)) 
	{
	  mpz_gcd(n, n, big_integer(promote_number(sc, T_BIG_INTEGER, car(x))));
	  if (mpz_cmp_ui(n, 1) == 0)
	    {
	      mpz_clear(n);
	      return(small_int(1));
	    }
	}
      x = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(x);
    }

  {
    s7_pointer rat;
    mpq_t q;
    mpz_t n, d;
    
    rat = promote_number(sc, T_BIG_RATIO, car(args));
    mpz_init_set(n, mpq_numref(big_ratio(rat)));
    mpz_init_set(d, mpq_denref(big_ratio(rat)));
    for (x = cdr(args); is_not_null(x); x = cdr(x))
      {
	rat = promote_number(sc, T_BIG_RATIO, car(x));
	mpz_gcd(n, n, mpq_numref(big_ratio(rat)));
	mpz_lcm(d, d, mpq_denref(big_ratio(rat)));
      }
    if (mpz_cmp_ui(d, 1) == 0)
      {
	rat = mpz_to_big_integer(sc, n);
	mpz_clear(n);
	mpz_clear(d);
	return(rat);
      }

    mpq_init(q);
    mpq_set_num(q, n);
    mpq_set_den(q, d);
    mpz_clear(n);
    mpz_clear(d);

    x = mpq_to_big_ratio(sc, q);
    mpq_clear(q);
    return(x);
  }
}


static s7_pointer big_lcm(s7_scheme *sc, s7_pointer args)
{
  #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
  s7_pointer x;
  bool rats = false;

  for (x = args; is_not_null(x); x = cdr(x)) 
    if (!s7_is_rational(car(x)))
      {
	CHECK_METHOD(sc, car(x), sc->LCM, args);
	return(wrong_type_argument_n_with_type(sc, sc->LCM, position_of(x, args), car(x), A_RATIONAL));
      }
    else rats = ((rats) || (!s7_is_integer(car(x))));
  
   if (is_null(cdr(args)))    /* (lcm -2305843009213693951/4611686018427387903) */
      return(big_abs(sc, args)); 
    
   if (!rats)
    {
      mpz_t n;
      mpz_init(n);
      mpz_set_ui(n, 1);
      for (x = args; is_not_null(x); x = cdr(x)) 
	{
	  mpz_lcm(n, n, big_integer(promote_number(sc, T_BIG_INTEGER, car(x))));
	  if (mpz_cmp_ui(n, 0) == 0)
	    {
	      mpz_clear(n);
	      return(small_int(0));
	    }
	}
      x = mpz_to_big_integer(sc, n);
      mpz_clear(n);
      return(x);
    }

  {
    s7_pointer rat;
    mpq_t q;
    mpz_t n, d;
    
    rat = promote_number(sc, T_BIG_RATIO, car(args));
    mpz_init_set(n, mpq_numref(big_ratio(rat)));
    if (mpz_cmp_ui(n, 0) == 0)
      {
	mpz_clear(n);
	return(small_int(0));
      }

    mpz_init_set(d, mpq_denref(big_ratio(rat)));
    for (x = cdr(args); is_not_null(x); x = cdr(x))
      {
	rat = promote_number(sc, T_BIG_RATIO, car(x));
	mpz_lcm(n, n, mpq_numref(big_ratio(rat)));
	if (mpz_cmp_ui(n, 0) == 0)
	  {
	    mpz_clear(n);
	    mpz_clear(d);
	    return(small_int(0));
	  }
	mpz_gcd(d, d, mpq_denref(big_ratio(rat)));
      }

    if (mpz_cmp_ui(d, 1) == 0)
      {
	rat = mpz_to_big_integer(sc, n);
	mpz_clear(n);
	mpz_clear(d);
	return(rat);
      }

    mpq_init(q);
    mpq_set_num(q, n);
    mpq_set_den(q, d);
    mpz_clear(n);
    mpz_clear(d);
    x = mpq_to_big_ratio(sc, q);
    mpq_clear(q);
    return(x);
  }
}


static s7_pointer g_bignum_precision(s7_scheme *sc, s7_pointer args)
{
  #define H_bignum_precision "(bignum-precision) returns the number of bits used for floats and complex numbers. It can be set."
  return(make_integer(sc, (int)mpfr_get_default_prec()));
}


static s7_pointer g_set_bignum_precision(s7_scheme *sc, s7_pointer args)
{
  mp_prec_t bits;
  s7_Int precision;

  if (!s7_is_integer(car(args)))
    return(simple_wrong_type_argument(sc, sc->BIGNUM_PRECISION, car(args), T_INTEGER));

  precision = s7_integer(car(args));
  if (precision <= 1)                   /* (set! (bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */
    return(s7_out_of_range_error(sc, "set! bignum-precision", 0, car(args), "has to be greater than 1"));    

  bits = (mp_prec_t)precision;
  mpfr_set_default_prec(bits);
  mpc_set_default_precision(bits);
  s7_symbol_set_value(sc, sc->PI, big_pi(sc));
  return(car(args));
}


typedef struct {
  gmp_randstate_t state;
} s7_big_rng_t;


static char *print_big_rng(s7_scheme *sc, void *val)
{
  char *buf;
  s7_big_rng_t *r = (s7_big_rng_t *)val;
  buf = (char *)malloc(64 * sizeof(char));
  snprintf(buf, 64, "#<big-rng %p>", r);
  return(buf);
}


static void free_big_rng(void *val)
{
  s7_big_rng_t *r = (s7_big_rng_t *)val;
  gmp_randclear(r->state);
  free(r);
}


static bool equal_big_rng(void *val1, void *val2)
{
  return(val1 == val2);
  /* I don't think the state is accessible, so we can't mimic the normal rng_t case */
}

  
static s7_pointer make_big_random_state(s7_scheme *sc, s7_pointer args)
{
#ifndef H_make_random_state
  #define H_make_random_state "(make-random-state seed) 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 (make-random-state 1234))) (random 1.0 seed))"
#endif

  s7_big_rng_t *r;
  s7_pointer seed;

  seed = car(args);
  if (!s7_is_integer(seed))
    {
      CHECK_METHOD(sc, seed, sc->MAKE_RANDOM_STATE, args);
      return(simple_wrong_type_argument(sc, sc->MAKE_RANDOM_STATE, seed, T_INTEGER));
    }
  if (is_big_number(seed))
    {
      r = (s7_big_rng_t *)calloc(1, sizeof(s7_big_rng_t));
      gmp_randinit_default(r->state);
      gmp_randseed(r->state, big_integer(seed));
      return(s7_make_object(sc, big_rng_tag, (void *)r));
    }

  return(s7_make_random_state(sc, args));
}


static s7_pointer big_random(s7_scheme *sc, s7_pointer args)
{
  s7_pointer num, state, x;
  state = sc->NIL;

  num = car(args); 
  if (!s7_is_number(num))
    {
      CHECK_METHOD(sc, num, sc->RANDOM, args);
      return(simple_wrong_type_argument_with_type(sc, sc->RANDOM, num, A_NUMBER));
    }
  if (is_not_null(cdr(args)))
    {
      state = cadr(args);
      if ((!is_c_object(state)) ||
	  ((c_object_type(state) != big_rng_tag) &&
	   (c_object_type(state) != rng_tag)))
	return(s7_wrong_type_arg_error(sc, "random state", 2, state, "a random-state object"));
    }

  if (s7_is_zero(num))
    return(num);

  if ((is_big_number(num)) ||
      ((is_c_object(state)) &&
       (c_object_type(state) == big_rng_tag)))
    {
      /* bignum case -- provide a state if none was passed,
       *   promote num if bignum state was passed but num is not a bignum
       *   if num==0, just return 0 (above) since gmp otherwise throws an arithmetic exception
       */
      s7_big_rng_t *r = NULL;

      if (is_null(state))
	{
	  /* no state passed, so make one */

	  if (!sc->default_big_rng)
	    {
	      mpz_t seed;
	      r = (s7_big_rng_t *)calloc(1, sizeof(s7_big_rng_t));
	      mpz_init_set_ui(seed, (unsigned int)time(NULL));
	      gmp_randinit_default(r->state);
	      gmp_randseed(r->state, seed);
	      mpz_clear(seed);
	      sc->default_big_rng = (void *)r;
	    }
	  else r = (s7_big_rng_t *)(sc->default_big_rng);
	}
      else
	{
	  /* state was passed, check its type */

	  if (c_object_type(state) == rng_tag)
	    {
	      /* here "num" is a bignum, the state was passed, but it is intended for non-bignums */
	      if (type(num) == T_BIG_REAL)
		num = make_real(sc, (s7_Double)mpfr_get_d(big_real(num), GMP_RNDN));
	      else
		{
		  if (type(num) == T_BIG_INTEGER)
		    num = make_integer(sc, big_integer_to_s7_Int(big_integer(num)));
		  else
		    {
		      if (type(num) == T_BIG_RATIO)
			num = s7_make_ratio(sc, 
					    big_integer_to_s7_Int(mpq_numref(big_ratio(num))), 
					    big_integer_to_s7_Int(mpq_denref(big_ratio(num))));
		    }
		}
	      return(g_random(sc, list_2(sc, num, state)));
	    }
	  r = (s7_big_rng_t *)s7_object_value(state);
	}

      if (!is_big_number(num))
	{
	  switch (type(num))
	    {
	    case T_INTEGER:
	      num = promote_number(sc, T_BIG_INTEGER, num);
	      break;

	    case T_RATIO:
	      num = promote_number(sc, T_BIG_RATIO, num);
	      break;

	    case T_REAL:
	      num = promote_number(sc, T_BIG_REAL, num);
	      break;

	    default:
	      num = promote_number(sc, T_BIG_COMPLEX, num);
	      break;
	    }
	}

      /* finally both the state and the number are big */
	    
      switch (type(num))
	{
	case T_BIG_INTEGER:
	  {
	    mpz_t n;
	    mpz_init(n);
	    mpz_urandomm(n, r->state, 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(n, n);
	    
	    x = mpz_to_big_integer(sc, n);
	    mpz_clear(n);
	    return(x);
	  }
      
	case T_BIG_RATIO:
	  {
	    mpfr_t n, e;
	    mpfr_t rat;
	    
	    mpfr_init_set_ui(n, 1, GMP_RNDN);
	    mpfr_urandomb(n, r->state);
	    mpfr_init_set_q(rat, big_ratio(num), GMP_RNDN);
	    mpfr_mul(n, n, rat, GMP_RNDN);
	    
	    mpfr_init_set_str(e, "0.0000001", 10, GMP_RNDN);
	    mpfr_mul(e, e, rat, GMP_RNDN);
	    mpfr_clear(rat);
	    /* as in g_random, small ratios are a problem because the error term (default_rationalize_error = 1e-12 here)
	     *   clobbers everything to 0.
	     */
	    x = big_rationalize(sc, list_2(sc, mpfr_to_big_real(sc, n), mpfr_to_big_real(sc, e)));
	    mpfr_clear(n);
	    mpfr_clear(e);
	    return(x);
	  }
      
	case T_BIG_REAL:
	  {
	    mpfr_t n;
	    mpfr_init_set_ui(n, 1, GMP_RNDN);
	    mpfr_urandomb(n, r->state);
	    mpfr_mul(n, n, big_real(num), GMP_RNDN);
	    x = mpfr_to_big_real(sc, n);
	    mpfr_clear(n);
	    return(x);
	  }
	  
	case T_BIG_COMPLEX:
	  {
	    mpc_t n;
	    mpc_init(n);
	    mpc_urandom(n, r->state);
	    mpfr_mul(mpc_realref(n), mpc_realref(n), mpc_realref(big_complex(num)), GMP_RNDN);
	    mpfr_mul(mpc_imagref(n), mpc_imagref(n), mpc_imagref(big_complex(num)), GMP_RNDN);
	    x = mpc_to_big_complex(sc, n);
	    mpc_clear(n);
	    return(x);
	  }
	}
    }

  return(g_random(sc, args));
}


static void s7_gmp_init(s7_scheme *sc)
{
  /* if these are defined as "safe", the optimizer needs to be smarter about things like (/ 1 ...)
   */
  sc->ADD =              s7_define_function(sc, "+",                   big_add,              0, 0, true,  H_add);
  sc->MINUS =            s7_define_function(sc, "-",                   big_subtract,         1, 0, true,  H_subtract);
  sc->MULTIPLY =         s7_define_function(sc, "*",                   big_multiply,         0, 0, true,  H_multiply);
  sc->DIVIDE =           s7_define_function(sc, "/",                   big_divide,           1, 0, true,  H_divide);

  sc->MAX =              s7_define_function(sc, "max",                 big_max,              1, 0, true,  H_max);
  sc->MIN =              s7_define_function(sc, "min",                 big_min,              1, 0, true,  H_min);
  sc->LT =               s7_define_function(sc, "<",                   big_less,             2, 0, true,  H_less);
  sc->LEQ =              s7_define_function(sc, "<=",                  big_less_or_equal,    2, 0, true,  H_less_or_equal);
  sc->GT =               s7_define_function(sc, ">",                   big_greater,          2, 0, true,  H_greater);
  sc->GEQ =              s7_define_function(sc, ">=",                  big_greater_or_equal, 2, 0, true,  H_greater_or_equal);
  sc->EQ =               s7_define_function(sc, "=",                   big_equal,            2, 0, true,  H_equal);

  sc->RATIONALIZE =      s7_define_function(sc, "rationalize",         big_rationalize,      1, 1, false, H_rationalize);
  sc->EXACT_TO_INEXACT = s7_define_function(sc, "exact->inexact",      big_exact_to_inexact, 1, 0, false, H_exact_to_inexact);
  sc->INEXACT_TO_EXACT = s7_define_function(sc, "inexact->exact",      big_inexact_to_exact, 1, 0, false, H_inexact_to_exact);
  sc->FLOOR =            s7_define_function(sc, "floor",               big_floor,            1, 0, false, H_floor);
  sc->CEILING =          s7_define_function(sc, "ceiling",             big_ceiling,          1, 0, false, H_ceiling);
  sc->TRUNCATE =         s7_define_function(sc, "truncate",            big_truncate,         1, 0, false, H_truncate);
  sc->ROUND =            s7_define_function(sc, "round",               big_round,            1, 0, false, H_round);
  sc->QUOTIENT =         s7_define_function(sc, "quotient",            big_quotient,         2, 0, false, H_quotient);
  sc->REMAINDER =        s7_define_function(sc, "remainder",           big_remainder,        2, 0, false, H_remainder);
  sc->MODULO =           s7_define_function(sc, "modulo",              big_modulo,           2, 0, false, H_modulo);
  sc->GCD =              s7_define_function(sc, "gcd",                 big_gcd,              0, 0, true,  H_gcd);
  sc->LCM =              s7_define_function(sc, "lcm",                 big_lcm,              0, 0, true,  H_lcm);

  sc->MAKE_RECTANGULAR = s7_define_function(sc, "make-rectangular",    big_make_rectangular, 2, 0, false, H_make_rectangular);
  sc->MAKE_POLAR =       s7_define_function(sc, "make-polar",          big_make_polar,       2, 0, false, H_make_polar);
  sc->ANGLE =            s7_define_function(sc, "angle",               big_angle,            1, 0, false, H_angle);
  sc->MAGNITUDE =        s7_define_function(sc, "magnitude",           big_magnitude,        1, 0, false, H_magnitude);
  sc->ABS =              s7_define_function(sc, "abs",                 big_abs,              1, 0, false, H_abs);

  sc->LOGNOT =           s7_define_function(sc, "lognot",              big_lognot,           1, 0, false, H_lognot);
  sc->LOGIOR =           s7_define_function(sc, "logior",              big_logior,           0, 0, true,  H_logior);
  sc->LOGXOR =           s7_define_function(sc, "logxor",              big_logxor,           0, 0, true,  H_logxor);
  sc->LOGAND =           s7_define_function(sc, "logand",              big_logand,           0, 0, true,  H_logand);
  sc->ASH =              s7_define_function(sc, "ash",                 big_ash,              2, 0, false, H_ash);
  sc->INTEGER_LENGTH =   s7_define_function(sc, "integer-length",      big_integer_length,   1, 0, false, H_integer_length);
  
  sc->EXP =              s7_define_function(sc, "exp",                 big_exp,              1, 0, false, H_exp);
  sc->EXPT =             s7_define_function(sc, "expt",                big_expt,             2, 0, false, H_expt);
  sc->LOG =              s7_define_function(sc, "log",                 big_log,              1, 1, false, H_log);
  sc->SQRT =             s7_define_function(sc, "sqrt",                big_sqrt,             1, 0, false, H_sqrt);
  sc->SIN =              s7_define_function(sc, "sin",                 big_sin,              1, 0, false, H_sin);
  sc->COS =              s7_define_function(sc, "cos",                 big_cos,              1, 0, false, H_cos);
  sc->TAN =              s7_define_function(sc, "tan",                 big_tan,              1, 0, false, H_tan);
  sc->ASIN =             s7_define_function(sc, "asin",                big_asin,             1, 0, false, H_asin);
  sc->ACOS =             s7_define_function(sc, "acos",                big_acos,             1, 0, false, H_acos);
  sc->ATAN =             s7_define_function(sc, "atan",                big_atan,             1, 1, false, H_atan);
  sc->SINH =             s7_define_function(sc, "sinh",                big_sinh,             1, 0, false, H_sinh);
  sc->COSH =             s7_define_function(sc, "cosh",                big_cosh,             1, 0, false, H_cosh);
  sc->TANH =             s7_define_function(sc, "tanh",                big_tanh,             1, 0, false, H_tanh);
  sc->ASINH =            s7_define_function(sc, "asinh",               big_asinh,            1, 0, false, H_asinh);
  sc->ACOSH =            s7_define_function(sc, "acosh",               big_acosh,            1, 0, false, H_acosh);
  sc->ATANH =            s7_define_function(sc, "atanh",               big_atanh,            1, 0, false, H_atanh);

  big_rng_tag = s7_new_type("<big-random-number-generator>", print_big_rng, free_big_rng, equal_big_rng, NULL, NULL, NULL);
  sc->RANDOM =          s7_define_function(sc,  "random",              big_random,           1, 1, false, H_random);
  sc->MAKE_RANDOM_STATE = s7_define_function(sc,"make-random-state",  make_big_random_state,1, 1, false, H_make_random_state);

  sc->BIGNUM =          s7_define_function(sc, "bignum",              g_bignum,             1, 1, false, H_bignum);
  s7_define_function(sc,                       "bignum?",             g_is_bignum,          1, 0, false, H_is_bignum);
  s7_define_function_with_setter(sc,           "bignum-precision",    g_bignum_precision, g_set_bignum_precision, 0, 0, H_bignum_precision);

  sc->BIGNUM_PRECISION = make_symbol(sc, "set-bignum-precision");
  add_max = (1 << (s7_int_bits - 1));
  mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION); 
  mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION);

  s7_symbol_set_value(sc, sc->PI, big_pi(sc));

  /* if these fixnum limits were read as strings, they'd be bignums in the gmp case, 
   *   so for consistency make the symbolic versions bignums as well.
   */
  s7_symbol_set_value(sc, make_symbol(sc, "most-positive-fixnum"), s7_Int_to_big_integer(sc, s7_integer(s7_name_to_value(sc, "most-positive-fixnum"))));
  s7_symbol_set_value(sc, make_symbol(sc, "most-negative-fixnum"), s7_Int_to_big_integer(sc, s7_integer(s7_name_to_value(sc, "most-negative-fixnum"))));

  s7_provide(sc, "gmp");
}

#endif
/* WITH_GMP */



/* -------------------------------- initialization -------------------------------- */

static s7_pointer make_unique_object(const char* name, int typ)
{
  s7_pointer p;
  p = alloc_pointer();
  set_type(p, typ | T_GC_MARK | T_IMMUTABLE);
  unique_name_length(p) = safe_strlen(name);
  unique_name(p) = copy_string_with_len(name, unique_name_length(p));
  heap_location(p) = NOT_IN_HEAP;
  return(p);
}


s7_scheme *s7_init(void) 
{
  int i;
  s7_scheme *sc;

  finder = find_symbol_or_bust;

  init_types();
  init_ctables();
  init_mark_functions();
  init_pows();
  init_uppers();

  sc = (s7_scheme *)calloc(1, sizeof(s7_scheme)); /* malloc is not recommended here */
  
  sc->gc_off = true;                         /* sc->args and so on are not set yet, so a gc during init -> segfault */
  sc->gc_stats = false;
  init_gc_caches(sc);

  sc->longjmp_ok = false;
  sc->symbol_table_is_locked = false;

  sc->strbuf_size = INITIAL_STRBUF_SIZE;
  sc->strbuf = (char *)calloc(sc->strbuf_size, sizeof(char));
  sc->print_width = MAX_STRING_LENGTH;

  sc->format_depth = -1;
  sc->slash_str_size = 0;
  sc->slash_str = NULL;
  
  sc->read_line_buf = NULL;
  sc->read_line_buf_size = 0;

  sc->NIL =         make_unique_object("()",             T_NIL);
  sc->GC_NIL =      make_unique_object("gc-nil",         T_UNIQUE);
  sc->T =           make_unique_object("#t",             T_BOOLEAN);
  sc->F =           make_unique_object("#f",             T_BOOLEAN);
  sc->EOF_OBJECT =  make_unique_object("#<eof>",         T_UNIQUE);
  sc->UNSPECIFIED = make_unique_object("#<unspecified>", T_UNIQUE | T_NO_VALUE);
  sc->UNDEFINED =   make_unique_object("#<undefined>",   T_UNIQUE);
  sc->NO_VALUE =    make_unique_object("#<unspecified>", T_UNIQUE | T_NO_VALUE);
  sc->ELSE =        make_unique_object("else",           T_UNIQUE);
  /* "else" is added to the global environment below -- can't do it here
   *    because the symbol table and environment don't exist yet.
   */

  car(sc->NIL) = cdr(sc->NIL) = sc->UNSPECIFIED;
  /* this is mixing two different s7_cell structs, cons and envr, but luckily
   *    envr has two initial s7_pointer fields, equivalent to car and cdr, so
   *    environment_id which is the same as ecdr is unaffected.  To get the names
   *    built-in, I'll append unique_name and unique_name_length fields to
   *    the envr struct.
   */
  environment_id(sc->NIL) = -1;
  cdr(sc->UNSPECIFIED) = sc->UNSPECIFIED; 

  cdr(sc->UNDEFINED) = sc->UNDEFINED;
  /* an experiment -- this way find_symbol of an undefined symbol returns #<undefined> not #<unspecified>
   */

  sc->temp_cell = alloc_pointer();
  set_type(sc->temp_cell, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  cdr(sc->temp_cell) = sc->NIL;
  heap_location(sc->temp_cell) = NOT_IN_HEAP;

  sc->temp_cell_1 = alloc_pointer();
  set_type(sc->temp_cell_1, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->temp_cell_1) = cdr(sc->temp_cell_1) = sc->NIL;
  car(sc->temp_cell) = sc->temp_cell_1;
  heap_location(sc->temp_cell_1) = NOT_IN_HEAP;

  sc->temp_cell_2 = alloc_pointer();  
  set_type(sc->temp_cell_2, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->temp_cell_2) = cdr(sc->temp_cell_2) = sc->NIL;
  heap_location(sc->temp_cell_2) = NOT_IN_HEAP;

  sc->temp_cell_3 = alloc_pointer();
  set_type(sc->temp_cell_3, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->temp_cell_3) = cdr(sc->temp_cell_3) = sc->NIL;
  heap_location(sc->temp_cell_3) = NOT_IN_HEAP;

  sc->temp_cell_4 = alloc_pointer();
  set_type(sc->temp_cell_4, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->temp_cell_4) = cdr(sc->temp_cell_4) = sc->NIL;
  heap_location(sc->temp_cell_4) = NOT_IN_HEAP;


  sc->T1_1 = alloc_pointer();
  set_type(sc->T1_1, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T1_1) = sc->NIL;
  cdr(sc->T1_1) = sc->NIL;
  heap_location(sc->T1_1) = NOT_IN_HEAP;

  sc->T2_1 = alloc_pointer();
  sc->T2_2 = alloc_pointer();

  set_type(sc->T2_1, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T2_1) = sc->NIL;
  cdr(sc->T2_1) = sc->T2_2;
  heap_location(sc->T2_1) = NOT_IN_HEAP;
  set_type(sc->T2_2, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T2_2) = sc->NIL;
  cdr(sc->T2_2) = sc->NIL;
  heap_location(sc->T2_2) = NOT_IN_HEAP;

  sc->T3_1 = alloc_pointer();
  sc->T3_2 = alloc_pointer();
  sc->T3_3 = alloc_pointer();

  set_type(sc->T3_1, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T3_1) = sc->NIL;
  cdr(sc->T3_1) = sc->T3_2;
  heap_location(sc->T3_1) = NOT_IN_HEAP;
  set_type(sc->T3_2, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T3_2) = sc->NIL;
  cdr(sc->T3_2) = sc->T3_3;
  heap_location(sc->T3_2) = NOT_IN_HEAP;
  set_type(sc->T3_3, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->T3_3) = sc->NIL;
  cdr(sc->T3_3) = sc->NIL;
  heap_location(sc->T3_3) = NOT_IN_HEAP;


  sc->A4_1 = alloc_pointer();
  sc->A4_2 = alloc_pointer();
  sc->A4_3 = alloc_pointer();
  sc->A4_4 = alloc_pointer();

  set_type(sc->A4_1, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->A4_1) = sc->NIL;
  cdr(sc->A4_1) = sc->A4_2;
  heap_location(sc->A4_1) = NOT_IN_HEAP;
  set_type(sc->A4_2, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->A4_2) = sc->NIL;
  cdr(sc->A4_2) = sc->A4_3;
  heap_location(sc->A4_2) = NOT_IN_HEAP;
  set_type(sc->A4_3, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->A4_3) = sc->NIL;
  cdr(sc->A4_3) = sc->A4_4;
  heap_location(sc->A4_3) = NOT_IN_HEAP;
  set_type(sc->A4_4, T_PAIR | T_GC_MARK | T_IMMUTABLE);
  car(sc->A4_4) = sc->NIL;
  cdr(sc->A4_4) = sc->NIL;
  heap_location(sc->A4_4) = NOT_IN_HEAP;

  sc->A1_1 = sc->A4_4;
  sc->A2_1 = sc->A4_3;
  sc->A2_2 = sc->A4_4;
  sc->A3_1 = sc->A4_2;
  sc->A3_2 = sc->A4_3;
  sc->A3_3 = sc->A4_4;


  sc->safe_lists = (s7_pointer *)calloc(NUM_SAFE_LISTS, sizeof(s7_pointer));
  for (i = 1; i < NUM_SAFE_LISTS; i++)
    {
      int j;
      s7_pointer p;
      p = sc->NIL;
      for (j = 0; j < i; j++)
	p = permanent_cons(sc->NIL, p, T_PAIR);
      sc->safe_lists[i] = p;
    }


  sc->input_port_stack = sc->NIL;
  sc->code = sc->NIL;
  sc->cur_code = sc->F;
  sc->args = sc->NIL;
  sc->value = sc->NIL;
  sc->v = sc->NIL;
  sc->w = sc->NIL;
  sc->x = sc->NIL;
  sc->y = sc->NIL;
  sc->z = sc->NIL;

  sc->temp1 = sc->NIL;
  sc->temp2 = sc->NIL;
  sc->temp3 = sc->NIL;
  sc->temp4 = sc->NIL;

  sc->begin_hook = NULL;
  sc->default_rng = NULL;

  sc->autoload_table = sc->NIL;
  sc->autoload_names = NULL;
  sc->autoload_names_sizes = NULL;
  sc->autoload_names_loc = 0;

  sc->port_heap_size = 0;
  sc->port_heap_loc = 0;
  sc->port_heap = NULL;
  
  sc->heap_size = INITIAL_HEAP_SIZE;
  if ((sc->heap_size % 32) != 0)
    sc->heap_size = 32 * (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 + INITIAL_HEAP_SIZE);
  sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE);
  sc->previous_free_heap_top = sc->free_heap_top;

  {
    s7_cell *cells;
    cells = (s7_cell *)calloc(INITIAL_HEAP_SIZE, sizeof(s7_cell));
    for (i = 0; i < INITIAL_HEAP_SIZE; i++)
      {
	sc->heap[i] = &cells[i];
 	sc->free_heap[i] = sc->heap[i];
 	heap_location(sc->heap[i]) = i;
      }
  }

  /* this has to precede s7_make_* allocations */
  sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE;
  sc->protected_objects_loc = 0;
  sc->protected_objects = s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE);
  for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++)
    vector_element(sc->protected_objects, i) = sc->GC_NIL;
  set_immutable(sc->protected_objects);
  
  sc->stack = s7_make_vector(sc, INITIAL_STACK_SIZE);
  sc->stack_start = vector_elements(sc->stack);
  sc->stack_end = sc->stack_start;
  sc->stack_size = INITIAL_STACK_SIZE;
  sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + sc->stack_size / 2);
  set_type(sc->stack, T_STACK);

  initialize_op_stack(sc);
  
  /* keep the symbol table out of the heap */
  sc->symbol_table = (s7_pointer)calloc(1, sizeof(s7_cell));
  set_type(sc->symbol_table, T_VECTOR);
  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) = default_vector_getter;
  vector_setter(sc->symbol_table) = default_vector_setter;
  s7_vector_fill(sc, sc->symbol_table, sc->NIL);
  heap_location(sc->symbol_table) = NOT_IN_HEAP;
  
  sc->gensym_counter = 0;
  sc->capture_env_counter = 0;
  sc->no_values = 0;
  sc->s7_call_line = 0;
  sc->s7_call_file = NULL;
  sc->s7_call_name = NULL;
  sc->safety = 0;

  sc->class_name_location = symbol_table_hash("class-name"); 

  sc->circle_info = NULL;
  sc->fdats = (format_data **)calloc(8, sizeof(format_data *));
  sc->num_fdats = 8;
  sc->direct_str = s7_make_permanent_string(NULL);

  sc->global_env = s7_make_vector(sc, 512);
  type(sc->global_env) = T_ENVIRONMENT;
  sc->global_env_entries = 0;
  for (i = 0; i < 512; i++)
    vector_element(sc->global_env, i) = sc->NIL;
  sc->envir = sc->NIL;
  
  /* keep the small_ints out of the heap */
  small_ints = (s7_pointer *)malloc((NUM_SMALL_INTS + 1) * sizeof(s7_pointer));
  {
    s7_cell *cells;
    cells = (s7_cell *)calloc((NUM_SMALL_INTS + 1), sizeof(s7_cell));
    for (i = 0; i <= NUM_SMALL_INTS; i++) 
      {
	s7_pointer p;
	small_ints[i] = &cells[i];
	p = small_ints[i];
	typeflag(p) = T_IMMUTABLE | T_INTEGER;
	heap_location(p) = NOT_IN_HEAP;
	integer(p) = i;
      }
  }

  real_zero = make_permanent_real(0.0);
  real_one = make_permanent_real(1.0);
  real_NaN = make_permanent_real(NAN);
  real_pi = make_permanent_real(3.1415926535897932384626433832795029L); /* M_PI is not good enough for s7_Double = long double */

  /* keep the characters out of the heap */
  chars = (s7_pointer *)malloc((NUM_CHARS + 1) * sizeof(s7_pointer));
  chars[0] = sc->EOF_OBJECT;
  chars++;                    /* now chars[EOF] == chars[-1] == sc->EOF_OBJECT */
  {
    s7_cell *cells;
    cells = (s7_cell *)calloc(NUM_CHARS, sizeof(s7_cell));
    for (i = 0; i < NUM_CHARS; i++) 
      {
	s7_pointer cp;
	unsigned char c;

	c = (unsigned char)i;
	cp = &cells[i];
	typeflag(cp) = T_IMMUTABLE | T_CHARACTER;
	heap_location(cp) = NOT_IN_HEAP;
	character(cp) = c;
	upper_character(cp) = (unsigned char)toupper(i);
	lower_character(cp) = (unsigned char)tolower(i);
	alphabetic_p(cp) = (bool)isalpha(i);
	numeric_p(cp) = (bool)isdigit(i);
	whitespace_p(cp) = white_space[i];
	upper_p(cp) = (bool)isupper(i);
	lower_p(cp) = (bool)islower(i);
	chars[i] = cp;
	  
	switch (c) 
	  {
	  case ' ':
	    character_name(cp) = copy_string("#\\space"); 
	    break;
	    
	  case '\n':
	    character_name(cp) = copy_string("#\\newline"); 
	    break;
	    
	  case '\r':
	    character_name(cp) = copy_string("#\\return"); 
	    break;
	    
	  case '\t':
	    character_name(cp) = copy_string("#\\tab"); 
	    break;
	    
	  case '\0':
	    character_name(cp) = copy_string("#\\null");
	    break;

	  case (char)0x1b:
	    character_name(cp) = copy_string("#\\escape");
	    break;

	  case (char)0x7f:
	    character_name(cp) = copy_string("#\\delete");
	    break;

	  case (char)7:
	    character_name(cp) = copy_string("#\\alarm");
	    break;
	    
	  case (char)8:
	    character_name(cp) = copy_string("#\\backspace");
	    break;
	    
	  default:
	    {
              #define P_SIZE 16
	      char *p;
	      p = (char *)malloc(P_SIZE * sizeof(char));
	      if ((c < 32) || (c >= 127))
		snprintf(p, P_SIZE, "#\\x%x", c);
	      else snprintf(p, P_SIZE, "#\\%c", c); 
	      character_name(cp) = p;
	      break;
	    }
	  }
	character_name_length(cp) = safe_strlen(character_name(cp));
      }
  }

#if WITH_COUNTS
  init_hashes(sc); 
#endif

  make_standard_ports(sc);

  assign_syntax(sc, "quote",             OP_QUOTE);
  assign_syntax(sc, "if",                OP_IF);
  assign_syntax(sc, "begin",             OP_BEGIN);
  assign_syntax(sc, "set!",              OP_SET);
  assign_syntax(sc, "let",               OP_LET);
  assign_syntax(sc, "let*",              OP_LET_STAR);
  assign_syntax(sc, "letrec",            OP_LETREC);
  assign_syntax(sc, "cond",              OP_COND);
  assign_syntax(sc, "and",               OP_AND);
  assign_syntax(sc, "or",                OP_OR);
  assign_syntax(sc, "case",              OP_CASE);
  assign_syntax(sc, "do",                OP_DO);

  set_immutable(assign_syntax(sc, "with-environment",  OP_WITH_ENV));

  assign_syntax(sc, "lambda",            OP_LAMBDA);
  assign_syntax(sc, "lambda*",           OP_LAMBDA_STAR);      /* optional, key, rest args */
  assign_syntax(sc, "define",            OP_DEFINE);
  assign_syntax(sc, "define*",           OP_DEFINE_STAR);
  assign_syntax(sc, "define-constant",   OP_DEFINE_CONSTANT);  /* unsetabble and unrebindable */

  assign_syntax(sc, "defmacro",          OP_DEFMACRO);         /* CL-style macro syntax */
  assign_syntax(sc, "defmacro*",         OP_DEFMACRO_STAR);
  assign_syntax(sc, "define-macro",      OP_DEFINE_MACRO);     /* Scheme-style macro syntax */
  assign_syntax(sc, "define-macro*",     OP_DEFINE_MACRO_STAR); 
  assign_syntax(sc, "define-expansion",  OP_DEFINE_EXPANSION); /* read-time (immediate) macro expansion */
  assign_syntax(sc, "define-bacro",      OP_DEFINE_BACRO);     /* macro expansion in calling environment */
  assign_syntax(sc, "define-bacro*",     OP_DEFINE_BACRO_STAR);
  assign_syntax(sc, "with-baffle",       OP_WITH_BAFFLE);

  sc->QUOTE_UNCHECKED =       assign_internal_syntax(sc, "quote",   OP_QUOTE_UNCHECKED);  
  sc->LET_UNCHECKED =         assign_internal_syntax(sc, "let",     OP_LET_UNCHECKED);  
  sc->LET_STAR_UNCHECKED =    assign_internal_syntax(sc, "let*",    OP_LET_STAR_UNCHECKED);  
  sc->LETREC_UNCHECKED =      assign_internal_syntax(sc, "letrec",  OP_LETREC_UNCHECKED);  
  sc->LET_NO_VARS =           assign_internal_syntax(sc, "let",     OP_LET_NO_VARS);  
  sc->LET_C =                 assign_internal_syntax(sc, "let",     OP_LET_C);  
  sc->LET_C_P =               assign_internal_syntax(sc, "let",     OP_LET_C_P);  
  sc->LET_S =                 assign_internal_syntax(sc, "let",     OP_LET_S);  
  sc->LET_S_P =               assign_internal_syntax(sc, "let",     OP_LET_S_P);  
  sc->LET_Q =                 assign_internal_syntax(sc, "let",     OP_LET_Q);  
  sc->LET_ALL_C =             assign_internal_syntax(sc, "let",     OP_LET_ALL_C);  
  sc->LET_ALL_S =             assign_internal_syntax(sc, "let",     OP_LET_ALL_S);  
  sc->LET_ALL_X =             assign_internal_syntax(sc, "let",     OP_LET_ALL_X);  
  sc->LET_STAR_ALL_X =        assign_internal_syntax(sc, "let",     OP_LET_STAR_ALL_X);  
  sc->LET_opCq =              assign_internal_syntax(sc, "let",     OP_LET_opCq);  
  sc->LET_opSSq =             assign_internal_syntax(sc, "let",     OP_LET_opSSq);  
  sc->NAMED_LET_NO_VARS =     assign_internal_syntax(sc, "let",     OP_NAMED_LET_NO_VARS); 
  sc->NAMED_LET =             assign_internal_syntax(sc, "let",     OP_NAMED_LET);  
  sc->NAMED_LET_STAR =        assign_internal_syntax(sc, "let*",    OP_NAMED_LET_STAR);  
  sc->LET_STAR2 =             assign_internal_syntax(sc, "let*",    OP_LET_STAR2);  
  sc->WITH_ENV_UNCHECKED =    assign_internal_syntax(sc, "with-environment",  OP_WITH_ENV_UNCHECKED);   
  sc->WITH_ENV_S =            assign_internal_syntax(sc, "with-environment",  OP_WITH_ENV_S);   
  sc->SET_UNCHECKED =         assign_internal_syntax(sc, "set!",    OP_SET_UNCHECKED);  
  sc->SET_SYMBOL_C =          assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_C);  
  sc->SET_SYMBOL_S =          assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_S);  
  sc->SET_SYMBOL_Q =          assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_Q);  
  sc->SET_SYMBOL_SAFE_S =     assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_SAFE_S);  
  sc->SET_SYMBOL_SAFE_SS =    assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_SAFE_SS);  
  sc->SET_SYMBOL_SAFE_SSS =   assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_SAFE_SSS);  
  sc->SET_SYMBOL_SAFE_opSSq_S = assign_internal_syntax(sc, "set!",  OP_SET_SYMBOL_SAFE_opSSq_S);  
  sc->SET_SYMBOL_SAFE_C =     assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_SAFE_C);  
  sc->SET_SYMBOL_P =          assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_P);  
  sc->SET_SYMBOL_Z =          assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_Z);  
  sc->SET_SYMBOL_ALL_X =      assign_internal_syntax(sc, "set!",    OP_SET_SYMBOL_ALL_X);  
  sc->CASE_UNCHECKED =        assign_internal_syntax(sc, "case",    OP_CASE_UNCHECKED);  
  sc->CASE_SIMPLE =           assign_internal_syntax(sc, "case",    OP_CASE_SIMPLE);  
  sc->CASE_SIMPLER =          assign_internal_syntax(sc, "case",    OP_CASE_SIMPLER);  
  sc->CASE_SIMPLER_1 =        assign_internal_syntax(sc, "case",    OP_CASE_SIMPLER_1);  
  sc->CASE_SIMPLER_SS =       assign_internal_syntax(sc, "case",    OP_CASE_SIMPLER_SS);  
  sc->CASE_SIMPLEST =         assign_internal_syntax(sc, "case",    OP_CASE_SIMPLEST);  
  sc->CASE_SIMPLEST_SS =      assign_internal_syntax(sc, "case",    OP_CASE_SIMPLEST_SS);  
  sc->CASE_SIMPLEST_ELSE =    assign_internal_syntax(sc, "case",    OP_CASE_SIMPLEST_ELSE);  
  sc->CASE_SIMPLEST_ELSE_C =  assign_internal_syntax(sc, "case",    OP_CASE_SIMPLEST_ELSE_C);  
  sc->COND_UNCHECKED =        assign_internal_syntax(sc, "cond",    OP_COND_UNCHECKED);  
  sc->COND_SIMPLE =           assign_internal_syntax(sc, "cond",    OP_COND_SIMPLE);  
  sc->DO_UNCHECKED =          assign_internal_syntax(sc, "do",      OP_DO_UNCHECKED);  
  sc->LAMBDA_UNCHECKED =      assign_internal_syntax(sc, "lambda",  OP_LAMBDA_UNCHECKED);  
  sc->LAMBDA_STAR_UNCHECKED = assign_internal_syntax(sc, "lambda*", OP_LAMBDA_STAR_UNCHECKED);  
  sc->DEFINE_UNCHECKED =      assign_internal_syntax(sc, "define",  OP_DEFINE_UNCHECKED);  
  sc->DEFINE_FUNCHECKED =     assign_internal_syntax(sc, "define",  OP_DEFINE_FUNCHECKED);  
  sc->DEFINE_STAR_UNCHECKED = assign_internal_syntax(sc, "define*", OP_DEFINE_STAR_UNCHECKED);  
  sc->SET_NORMAL =            assign_internal_syntax(sc, "set!",    OP_SET_NORMAL);
  sc->SET_PWS =               assign_internal_syntax(sc, "set!",    OP_SET_PWS);
  sc->SET_PAIR =              assign_internal_syntax(sc, "set!",    OP_SET_PAIR);
  sc->SET_PAIR_P =            assign_internal_syntax(sc, "set!",    OP_SET_PAIR_P);
  sc->SET_PAIR_Z =            assign_internal_syntax(sc, "set!",    OP_SET_PAIR_Z);
  sc->SET_PAIR_A =            assign_internal_syntax(sc, "set!",    OP_SET_PAIR_A);
  sc->SET_ENV_S =             assign_internal_syntax(sc, "set!",    OP_SET_ENV_S);
  sc->SET_ENV_ALL_X =         assign_internal_syntax(sc, "set!",    OP_SET_ENV_ALL_X);
  sc->SET_PAIR_C =            assign_internal_syntax(sc, "set!",    OP_SET_PAIR_C);
  sc->SET_PAIR_C_P =          assign_internal_syntax(sc, "set!",    OP_SET_PAIR_C_P);
  sc->AND_UNCHECKED =         assign_internal_syntax(sc, "and",     OP_AND_UNCHECKED);
  sc->AND_P =                 assign_internal_syntax(sc, "and",     OP_AND_P);
  sc->OR_UNCHECKED =          assign_internal_syntax(sc, "or",      OP_OR_UNCHECKED);
  sc->OR_P =                  assign_internal_syntax(sc, "or",      OP_OR_P);

  sc->IF_P_P_P =              assign_internal_syntax(sc, "if",      OP_IF_P_P_P);
  sc->IF_P_P =                assign_internal_syntax(sc, "if",      OP_IF_P_P);
  sc->IF_ANDP_P =             assign_internal_syntax(sc, "if",      OP_IF_ANDP_P);
  sc->IF_ANDP_P_P =           assign_internal_syntax(sc, "if",      OP_IF_ANDP_P_P);
  sc->IF_ORP_P =              assign_internal_syntax(sc, "if",      OP_IF_ORP_P);
  sc->IF_ORP_P_P =            assign_internal_syntax(sc, "if",      OP_IF_ORP_P_P);
  sc->IF_B_P =                assign_internal_syntax(sc, "if",      OP_IF_B_P);
  sc->IF_B_P_P =              assign_internal_syntax(sc, "if",      OP_IF_B_P_P);
  sc->IF_P_P_X =              assign_internal_syntax(sc, "if",      OP_IF_P_P_X);
  sc->IF_P_X_P =              assign_internal_syntax(sc, "if",      OP_IF_P_X_P);
  sc->IF_P_X_X =              assign_internal_syntax(sc, "if",      OP_IF_P_X_X);
  sc->IF_S_P_P =              assign_internal_syntax(sc, "if",      OP_IF_S_P_P);
  sc->IF_S_P =                assign_internal_syntax(sc, "if",      OP_IF_S_P);
  sc->IF_S_P_X =              assign_internal_syntax(sc, "if",      OP_IF_S_P_X);
  sc->IF_S_X_P =              assign_internal_syntax(sc, "if",      OP_IF_S_X_P);

  sc->COND_ALL_X =            assign_internal_syntax(sc, "cond",    OP_COND_ALL_X);  
  sc->SAFE_IF_Z_Z =           assign_internal_syntax(sc, "if",      OP_SAFE_IF_Z_Z);  
  sc->IF_Z_P_P =              assign_internal_syntax(sc, "if",      OP_IF_Z_P_P);
  sc->IF_Z_P =                assign_internal_syntax(sc, "if",      OP_IF_Z_P);
  sc->IF_GT_P =               assign_internal_syntax(sc, "if",      OP_IF_GT_P);
  sc->IF_A_P_P =              assign_internal_syntax(sc, "if",      OP_IF_A_P_P);
  sc->IF_A_P =                assign_internal_syntax(sc, "if",      OP_IF_A_P);
  sc->SAFE_IF_CC_X_P =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_CC_X_P);  
  sc->SAFE_IF_CC_P =          assign_internal_syntax(sc, "if",      OP_SAFE_IF_CC_P);  
  sc->SAFE_IF_CC_P_P =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_CC_P_P);  
  sc->SAFE_IF_CS_P =          assign_internal_syntax(sc, "if",      OP_SAFE_IF_CS_P);  
  sc->SAFE_IF_CS_P_P =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_CS_P_P);  
  sc->SAFE_IF_CS_P_X =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_CS_P_X);  
  sc->SAFE_IF_CS_X_P =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_CS_X_P);
  sc->SAFE_IF_CSS_X_P =       assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSS_X_P);
  sc->SAFE_IF_CSC_X_O_A =     assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSC_X_O_A);
  sc->SAFE_IF_CSC_X_P =       assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSC_X_P);
  sc->SAFE_IF_CSQ_P =         assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSQ_P);    
  sc->SAFE_IF_CSQ_P_P =       assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSQ_P_P);    
  sc->SAFE_IF_CSS_P =         assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSS_P);    
  sc->SAFE_IF_CSS_P_P =       assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSS_P_P);    
  sc->SAFE_IF_CSC_P =         assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSC_P);    
  sc->SAFE_IF_CSC_P_P =       assign_internal_syntax(sc, "if",      OP_SAFE_IF_CSC_P_P);    
  sc->SAFE_IF_C_SS_P =        assign_internal_syntax(sc, "if",      OP_SAFE_IF_C_SS_P);    
  sc->SAFE_IF_IS_NULL_Q_P =   assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_NULL_Q_P);  
  sc->SAFE_IF_IS_NULL_S_P =   assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_NULL_S_P);  
  sc->SAFE_IF_IS_PAIR_P =     assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_PAIR_P);  
  sc->SAFE_IF_IS_PAIR_P_X =   assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_PAIR_P_X);  
  sc->SAFE_IF_IS_PAIR_P_P =   assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_PAIR_P_P);  
  sc->SAFE_IF_IS_SYMBOL_P =   assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_SYMBOL_P);  
  sc->SAFE_IF_IS_SYMBOL_P_P = assign_internal_syntax(sc, "if",      OP_SAFE_IF_IS_SYMBOL_P_P);  
  sc->LET_R =                 assign_internal_syntax(sc, "let",     OP_LET_R);  
  sc->LET_R_P =               assign_internal_syntax(sc, "let",     OP_LET_R_P);  
  sc->LET_CAR_P =             assign_internal_syntax(sc, "let",     OP_LET_CAR_P);  
  sc->LET_ALL_R =             assign_internal_syntax(sc, "let",     OP_LET_ALL_R);  
  sc->LET_O =                 assign_internal_syntax(sc, "let",     OP_LET_O);  
  sc->LET_O_P =               assign_internal_syntax(sc, "let",     OP_LET_O_P);  
  sc->LET_Z_P =               assign_internal_syntax(sc, "let",     OP_LET_Z_P);  
  sc->LET_O_O =               assign_internal_syntax(sc, "let",     OP_LET_O_O);  
  sc->LET_Z_O =               assign_internal_syntax(sc, "let",     OP_LET_Z_O);  
  sc->LET_C_D =               assign_internal_syntax(sc, "let",     OP_LET_C_D);  
  sc->INCREMENT_1 =           assign_internal_syntax(sc, "set!",    OP_INCREMENT_1);  
  sc->INCREMENT_SS =          assign_internal_syntax(sc, "set!",    OP_INCREMENT_SS);  
  sc->INCREMENT_SSS =         assign_internal_syntax(sc, "set!",    OP_INCREMENT_SSS);  
  sc->INCREMENT_S_opCq =      assign_internal_syntax(sc, "set!",    OP_INCREMENT_S_opCq);  
  sc->INCREMENT_SZ =          assign_internal_syntax(sc, "set!",    OP_INCREMENT_SZ);  
  sc->INCREMENT_C_TEMP =      assign_internal_syntax(sc, "set!",    OP_INCREMENT_C_TEMP);  
  sc->DECREMENT_1 =           assign_internal_syntax(sc, "set!",    OP_DECREMENT_1);  
  sc->SET_CDR =               assign_internal_syntax(sc, "set!",    OP_SET_CDR);
  sc->SET_CONS =              assign_internal_syntax(sc, "set!",    OP_SET_CONS);
  sc->DOTIMES_P =             assign_internal_syntax(sc, "do",      OP_DOTIMES_P);
  sc->SIMPLE_DO =             assign_internal_syntax(sc, "do",      OP_SIMPLE_DO);
  sc->SIMPLE_DO_P =           assign_internal_syntax(sc, "do",      OP_SIMPLE_DO_P);
  sc->SIMPLE_DO_A =           assign_internal_syntax(sc, "do",      OP_SIMPLE_DO_A);
  sc->SIMPLE_DO_FOREVER =     assign_internal_syntax(sc, "do",      OP_SIMPLE_DO_FOREVER);
  sc->SAFE_DOTIMES =          assign_internal_syntax(sc, "do",      OP_SAFE_DOTIMES);
  sc->SAFE_DOTIMES_C_C =      assign_internal_syntax(sc, "do",      OP_SAFE_DOTIMES_C_C);
  sc->SAFE_DOTIMES_C_A =      assign_internal_syntax(sc, "do",      OP_SAFE_DOTIMES_C_A);
  sc->SIMPLE_SAFE_DOTIMES =   assign_internal_syntax(sc, "do",      OP_SIMPLE_SAFE_DOTIMES);
  sc->SAFE_DO =               assign_internal_syntax(sc, "do",      OP_SAFE_DO);
  sc->DOX =                   assign_internal_syntax(sc, "do",      OP_DOX);

  sc->LAMBDA =      make_symbol(sc, "lambda");
  sc->LAMBDA_STAR = make_symbol(sc, "lambda*");
  sc->QUOTE =       make_symbol(sc, "quote");

#if WITH_IMMUTABLE_UNQUOTE
  /* unquote has no value, so it has to be the symbol for quasiquote */
  /* this code solves the various unquote redefinition troubles
   *
   * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,1) -> 5
   *   in s7, this requires a quote: (let (, (lambda (x) (+ x 1))) ,,,,'1)
   */
  sc->UNQUOTE =     make_symbol(sc, ","); 
  set_immutable(sc->UNQUOTE);
#else
  sc->UNQUOTE =     make_symbol(sc, "unquote");
#endif

  sc->MACROEXPAND = make_symbol(sc, "macroexpand");
  sc->FEED_TO =     make_symbol(sc, "=>");
  sc->SET =         make_symbol(sc, "set!");
  sc->BAFFLE =      make_symbol(sc, "(baffle)");
  sc->BODY =        make_symbol(sc, "body");

  sc->KEY_KEY =              s7_make_keyword(sc, "key");
  sc->KEY_OPTIONAL =         s7_make_keyword(sc, "optional");
  sc->KEY_ALLOW_OTHER_KEYS = s7_make_keyword(sc, "allow-other-keys");
  sc->KEY_REST =             s7_make_keyword(sc, "rest");
  sc->KEY_READABLE =         s7_make_keyword(sc, "readable");

  sc->__FUNC__ = make_symbol(sc, "__func__");

  s7_make_slot(sc, sc->NIL, make_symbol(sc, "else"), sc->ELSE);

  sc->ERROR =          make_symbol(sc, "error");
  sc->READ_ERROR =     make_symbol(sc, "read-error");
  sc->SYNTAX_ERROR =   make_symbol(sc, "syntax-error");
  sc->WRONG_TYPE_ARG = make_symbol(sc, "wrong-type-arg");
  sc->WRONG_NUMBER_OF_ARGS = make_symbol(sc, "wrong-number-of-args");
  sc->FORMAT_ERROR =   make_symbol(sc, "format-error");
  sc->OUT_OF_RANGE =   make_symbol(sc, "out-of-range");

  sc->error_env = init_error_env(sc);

  sc->WRONG_TYPE_ARG_INFO = sc->NIL;
  for (i = 0; i < 6; i++)
    {
      sc->WRONG_TYPE_ARG_INFO = permanent_cons(sc->F, sc->WRONG_TYPE_ARG_INFO, T_PAIR);
      switch (5 - i)
	{
	case 1: sc->WTA1 = sc->WRONG_TYPE_ARG_INFO; break;
	case 2: sc->WTA2 = sc->WRONG_TYPE_ARG_INFO; break;
	case 3: sc->WTA3 = sc->WRONG_TYPE_ARG_INFO; break;
	case 4: sc->WTA4 = sc->WRONG_TYPE_ARG_INFO; break;
	case 5: sc->WTA5 = sc->WRONG_TYPE_ARG_INFO; break;
	}
    }
  car(sc->WRONG_TYPE_ARG_INFO) = s7_make_permanent_string("~A argument ~D, ~S, is ~A but should be ~A");


  sc->SIMPLE_WRONG_TYPE_ARG_INFO = sc->NIL;
  for (i = 0; i < 5; i++)
    sc->SIMPLE_WRONG_TYPE_ARG_INFO = permanent_cons(sc->F, sc->SIMPLE_WRONG_TYPE_ARG_INFO, T_PAIR);
  car(sc->SIMPLE_WRONG_TYPE_ARG_INFO) = s7_make_permanent_string("~A argument, ~S, is ~A but should be ~A");

  sc->OUT_OF_RANGE_INFO = sc->NIL;
  for (i = 0; i < 5; i++)
    sc->OUT_OF_RANGE_INFO = permanent_cons(sc->F, sc->OUT_OF_RANGE_INFO, T_PAIR);
  car(sc->OUT_OF_RANGE_INFO) = s7_make_permanent_string("~A argument ~D, ~S, is out of range (~A)");

  sc->SIMPLE_OUT_OF_RANGE_INFO = sc->NIL;
  for (i = 0; i < 4; i++)
    sc->SIMPLE_OUT_OF_RANGE_INFO = permanent_cons(sc->F, sc->SIMPLE_OUT_OF_RANGE_INFO, T_PAIR);
  car(sc->SIMPLE_OUT_OF_RANGE_INFO) = s7_make_permanent_string("~A argument, ~S, is out of range (~A)");

  sc->TOO_MANY_ARGUMENTS = s7_make_permanent_string("~A: too many arguments: ~A");
  sc->NOT_ENOUGH_ARGUMENTS = s7_make_permanent_string("~A: not enough arguments: ~A");
  sc->DIVISION_BY_ZERO_ERROR = s7_make_permanent_string("~A: division by zero, ~S");
  sc->DIVISION_BY_ZERO = make_symbol(sc, "division-by-zero");
  init_car_a_list();

  for (i = 0; i < NUM_TYPES; i++)
    {
      const char *str;
      str = type_name_from_type(sc, i, INDEFINITE_ARTICLE);
      if (str)
	prepackaged_type_names[i] = s7_make_permanent_string(str);
      else prepackaged_type_names[i] = sc->F;
    }

  sc->gc_off = false;

  sc->GENSYM =                s7_define_safe_function(sc, "gensym",                  g_gensym,                 0, 1, false, H_gensym);
                              s7_define_safe_function(sc, "symbol-table",            g_symbol_table,           0, 0, false, H_symbol_table);
  sc->SYMBOLP =               s7_define_safe_function(sc, "symbol?",                 g_is_symbol,              1, 0, false, H_is_symbol);
  sc->SYMBOL_TO_STRING =      s7_define_safe_function(sc, "symbol->string",          g_symbol_to_string,       1, 0, false, H_symbol_to_string);
  sc->STRING_TO_SYMBOL =      s7_define_safe_function(sc, "string->symbol",          g_string_to_symbol,       1, 0, false, H_string_to_symbol);
  sc->SYMBOL =                s7_define_safe_function(sc, "symbol",                  g_symbol,                 1, 0, false, H_symbol);
  sc->SYMBOL_TO_VALUE =       s7_define_safe_function(sc, "symbol->value",           g_symbol_to_value,        1, 1, false, H_symbol_to_value);
  sc->SYMBOL_TO_DYNAMIC_VALUE = s7_define_safe_function(sc, "symbol->dynamic-value", g_symbol_to_dynamic_value,1, 0, false, H_symbol_to_dynamic_value);
  s7_define_function_with_setter(sc,                      "symbol-access",           g_symbol_get_access, g_symbol_set_access, 1, 0, H_symbol_access);
  sc->SYMBOL_ACCESS = make_symbol(sc, "symbol-access");
  
  sc->OUTER_ENVIRONMENT =     s7_define_safe_function(sc, "outer-environment",       g_outer_environment,      1, 0, false, H_outer_environment);
                              s7_define_safe_function(sc, "global-environment",      g_global_environment,     0, 0, false, H_global_environment);
                              s7_define_function(sc,      "current-environment",     g_current_environment,    0, 0, false, H_current_environment);
                              s7_define_constant_function(sc, "initial-environment", g_initial_environment,    0, 0, false, H_initial_environment);
  sc->AUGMENT_ENVIRONMENT =   s7_define_function(sc,      "augment-environment",     g_augment_environment,    1, 0, true,  H_augment_environment);
  sc->AUGMENT_ENVIRONMENTB =  s7_define_function(sc,      "augment-environment!",    g_augment_environment_direct, 1, 0, true, H_augment_environment_direct);
  sc->ENVIRONMENT =           s7_define_safe_function(sc, "environment",             g_environment,            0, 0, true,  H_environment);
  sc->ENVIRONMENTP =          s7_define_safe_function(sc, "environment?",            g_is_environment,         1, 0, false, H_is_environment);
  sc->ENVIRONMENT_TO_LIST =   s7_define_safe_function(sc, "environment->list",       g_environment_to_list,    1, 0, false, H_environment_to_list);
                              s7_define_safe_function(sc, "error-environment",       g_error_environment,      0, 0, false, H_error_environment);
  sc->OPEN_ENVIRONMENT =      s7_define_safe_function(sc, "open-environment",        g_open_environment,       1, 0, false, H_open_environment);
  sc->OPEN_ENVIRONMENTP =     s7_define_safe_function(sc, "open-environment?",       g_is_open_environment,    1, 0, false, H_is_open_environment);
  sc->OBJECT_ENVIRONMENT =    s7_define_safe_function(sc, "object-environment",      g_object_environment,     1, 0, false, H_object_environment);
  sc->ENVIRONMENT_REF =       s7_define_safe_function(sc, "environment-ref",         g_environment_ref,        2, 0, false, H_environment_ref);
  sc->ENVIRONMENT_SET =       s7_define_safe_function(sc, "environment-set!",        g_environment_set,        3, 0, false, H_environment_set);

  sc->PROVIDEDP =             s7_define_safe_function(sc, "provided?",               g_is_provided,            1, 0, false, H_is_provided);
  sc->PROVIDE =               s7_define_safe_function(sc, "provide",                 g_provide,                1, 0, false, H_provide);
  sc->DEFINEDP =              s7_define_safe_function(sc, "defined?",                g_is_defined,             1, 1, false, H_is_defined);
  sc->CONSTANTP =             s7_define_safe_function(sc, "constant?",               g_is_constant,            1, 0, false, H_is_constant);
  sc->MACROP =                s7_define_safe_function(sc, "macro?",                  g_is_macro,               1, 0, false, H_is_macro);
                              s7_define_safe_function(sc, "bacro?",                  g_is_bacro,               1, 0, false, H_is_bacro);

  sc->KEYWORDP =              s7_define_safe_function(sc, "keyword?",                g_is_keyword,             1, 0, false, H_is_keyword);
  sc->MAKE_KEYWORD =          s7_define_safe_function(sc, "make-keyword",            g_make_keyword,           1, 0, false, H_make_keyword);
  sc->SYMBOL_TO_KEYWORD =     s7_define_safe_function(sc, "symbol->keyword",         g_symbol_to_keyword,      1, 0, false, H_symbol_to_keyword);
  sc->KEYWORD_TO_SYMBOL =     s7_define_safe_function(sc, "keyword->symbol",         g_keyword_to_symbol,      1, 0, false, H_keyword_to_symbol);

  sc->C_POINTERP =            s7_define_safe_function(sc, "c-pointer?",              g_is_c_pointer,           1, 0, false, H_is_c_pointer);
  sc->C_POINTER =             s7_define_safe_function(sc, "c-pointer",               g_c_pointer,              1, 0, false, H_c_pointer);  

  sc->PORT_LINE_NUMBER =      s7_define_safe_function(sc, "port-line-number",        g_port_line_number,       0, 1, false, H_port_line_number);
  sc->PORT_FILENAME =         s7_define_safe_function(sc, "port-filename",           g_port_filename,          0, 1, false, H_port_filename);
  sc->PAIR_LINE_NUMBER =      s7_define_safe_function(sc, "pair-line-number",        g_pair_line_number,       1, 0, false, H_pair_line_number);
  
  sc->INPUT_PORTP =           s7_define_safe_function(sc, "input-port?",             g_is_input_port,          1, 0, false, H_is_input_port);
  sc->OUTPUT_PORTP =          s7_define_safe_function(sc, "output-port?",            g_is_output_port,         1, 0, false, H_is_output_port);
  sc->PORT_CLOSEDP =          s7_define_safe_function(sc, "port-closed?",            g_is_port_closed,         1, 0, false, H_is_port_closed);
  sc->CHAR_READYP =           s7_define_safe_function(sc, "char-ready?",             g_is_char_ready,          0, 1, false, H_is_char_ready);
  sc->EOF_OBJECTP =           s7_define_safe_function(sc, "eof-object?",             g_is_eof_object,          1, 0, false, H_is_eof_object);
  /* this should be named eof? (what isn't an object?) */
  
                              s7_define_safe_function(sc, "current-input-port",      g_current_input_port,     0, 0, false, H_current_input_port);
                              s7_define_safe_function(sc, "set-current-input-port",  g_set_current_input_port, 1, 0, false, H_set_current_input_port);
                              s7_define_safe_function(sc, "current-output-port",     g_current_output_port,    0, 0, false, H_current_output_port);
                              s7_define_safe_function(sc, "set-current-output-port", g_set_current_output_port,1, 0, false, H_set_current_output_port);
                              s7_define_safe_function(sc, "current-error-port",      g_current_error_port,     0, 0, false, H_current_error_port);
                              s7_define_safe_function(sc, "set-current-error-port",  g_set_current_error_port, 1, 0, false, H_set_current_error_port);
  sc->CLOSE_INPUT_PORT =      s7_define_safe_function(sc, "close-input-port",        g_close_input_port,       1, 0, false, H_close_input_port);
  sc->CLOSE_OUTPUT_PORT =     s7_define_safe_function(sc, "close-output-port",       g_close_output_port,      1, 0, false, H_close_output_port);
  sc->FLUSH_OUTPUT_PORT =     s7_define_safe_function(sc, "flush-output-port",       g_flush_output_port,      0, 1, false, H_flush_output_port);
  sc->OPEN_INPUT_FILE =       s7_define_safe_function(sc, "open-input-file",         g_open_input_file,        1, 1, false, H_open_input_file);
  sc->OPEN_OUTPUT_FILE =      s7_define_safe_function(sc, "open-output-file",        g_open_output_file,       1, 1, false, H_open_output_file);
  sc->OPEN_INPUT_STRING =     s7_define_safe_function(sc, "open-input-string",       g_open_input_string,      1, 0, false, H_open_input_string);
                              s7_define_safe_function(sc, "open-output-string",      g_open_output_string,     0, 0, false, H_open_output_string);
  sc->GET_OUTPUT_STRING =     s7_define_safe_function(sc, "get-output-string",       g_get_output_string,      1, 0, false, H_get_output_string);
  
  sc->NEWLINE =               s7_define_safe_function(sc, "newline",                 g_newline,                0, 1, false, H_newline);
  sc->WRITE =                 s7_define_safe_function(sc, "write",                   g_write,                  1, 1, false, H_write);
  sc->DISPLAY =               s7_define_safe_function(sc, "display",                 g_display,                1, 1, false, H_display);
  sc->READ_CHAR =             s7_define_safe_function(sc, "read-char",               g_read_char,              0, 1, false, H_read_char);
  sc->PEEK_CHAR =             s7_define_safe_function(sc, "peek-char",               g_peek_char,              0, 1, false, H_peek_char);
  sc->WRITE_CHAR =            s7_define_safe_function(sc, "write-char",              g_write_char,             1, 1, false, H_write_char);
  sc->WRITE_STRING =          s7_define_safe_function(sc, "write-string",            g_write_string,           1, 3, false, H_write_string);
  sc->READ_BYTE =             s7_define_safe_function(sc, "read-byte",               g_read_byte,              0, 1, false, H_read_byte);
  sc->WRITE_BYTE =            s7_define_safe_function(sc, "write-byte",              g_write_byte,             1, 1, false, H_write_byte);
  sc->READ_LINE =             s7_define_safe_function(sc, "read-line",               g_read_line,              0, 2, false, H_read_line);
  sc->READ_STRING =           s7_define_safe_function(sc, "read-string",             g_read_string,            1, 1, false, H_read_string);
  sc->READ =                  s7_define_function(sc,      "read",                    g_read,                   0, 1, false, H_read);
  /* 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)
   */
  
  sc->CALL_WITH_INPUT_STRING = s7_define_function(sc,     "call-with-input-string",  g_call_with_input_string, 2, 0, false, H_call_with_input_string);
  sc->CALL_WITH_INPUT_FILE =  s7_define_function(sc,      "call-with-input-file",    g_call_with_input_file,   2, 0, false, H_call_with_input_file);
  sc->WITH_INPUT_FROM_STRING = s7_define_function(sc,     "with-input-from-string",  g_with_input_from_string, 2, 0, false, H_with_input_from_string);
  sc->WITH_INPUT_FROM_FILE =  s7_define_function(sc,      "with-input-from-file",    g_with_input_from_file,   2, 0, false, H_with_input_from_file);
  
  sc->CALL_WITH_OUTPUT_STRING = s7_define_function(sc,    "call-with-output-string", g_call_with_output_string,1, 0, false, H_call_with_output_string);
  sc->CALL_WITH_OUTPUT_FILE = s7_define_function(sc,      "call-with-output-file",   g_call_with_output_file,  2, 0, false, H_call_with_output_file);
  sc->WITH_OUTPUT_TO_STRING = s7_define_function(sc,      "with-output-to-string",   g_with_output_to_string,  1, 0, false, H_with_output_to_string);
  sc->WITH_OUTPUT_TO_FILE =   s7_define_function(sc,      "with-output-to-file",     g_with_output_to_file,    2, 0, false, H_with_output_to_file);
  
#if WITH_SYSTEM_EXTRAS
  sc->DIRECTORYP =            s7_define_safe_function(sc, "directory?",              g_is_directory,           1, 0, false, H_is_directory);
  sc->FILE_EXISTSP =          s7_define_safe_function(sc, "file-exists?",            g_file_exists,            1, 0, false, H_file_exists);
  sc->DELETE_FILE =           s7_define_safe_function(sc, "delete-file",             g_delete_file,            1, 0, false, H_delete_file);
  sc->GETENV =                s7_define_safe_function(sc, "getenv",                  g_getenv_1,               1, 0, false, H_getenv);
  sc->SYSTEM =                s7_define_safe_function(sc, "system",                  g_system,                 1, 0, false, H_system);
#ifndef _MSC_VER
  sc->DIRECTORY_TO_LIST =     s7_define_safe_function(sc, "directory->list",         g_directory_to_list,      1, 0, false, H_directory_to_list);
  sc->FILE_MTIME =            s7_define_safe_function(sc, "file-mtime",              g_file_mtime,             1, 0, false, H_file_mtime);
#endif
#endif
  
  sc->REAL_PART =             s7_define_safe_function(sc, "real-part",               g_real_part,              1, 0, false, H_real_part);
  sc->IMAG_PART =             s7_define_safe_function(sc, "imag-part",               g_imag_part,              1, 0, false, H_imag_part);
  sc->NUMERATOR =             s7_define_safe_function(sc, "numerator",               g_numerator,              1, 0, false, H_numerator);
  sc->DENOMINATOR =           s7_define_safe_function(sc, "denominator",             g_denominator,            1, 0, false, H_denominator);
  sc->EVENP =                 s7_define_safe_function(sc, "even?",                   g_is_even,                1, 0, false, H_is_even);
  sc->ODDP =                  s7_define_safe_function(sc, "odd?",                    g_is_odd,                 1, 0, false, H_is_odd);
  sc->ZEROP =                 s7_define_safe_function(sc, "zero?",                   g_is_zero,                1, 0, false, H_is_zero);
  sc->POSITIVEP =             s7_define_safe_function(sc, "positive?",               g_is_positive,            1, 0, false, H_is_positive);
  sc->NEGATIVEP =             s7_define_safe_function(sc, "negative?",               g_is_negative,            1, 0, false, H_is_negative);
  sc->INFINITEP =             s7_define_safe_function(sc, "infinite?",               g_is_infinite,            1, 0, false, H_is_infinite);
  sc->NANP =                  s7_define_safe_function(sc, "nan?",                    g_is_nan,                 1, 0, false, H_is_nan);

#if (!WITH_GMP)
  sc->MAKE_POLAR =            s7_define_safe_function(sc, "make-polar",              g_make_polar,             2, 0, false, H_make_polar);
  sc->MAKE_RECTANGULAR =      s7_define_safe_function(sc, "make-rectangular",        g_make_rectangular,       2, 0, false, H_make_rectangular);
  sc->MAGNITUDE =             s7_define_safe_function(sc, "magnitude",               g_magnitude,              1, 0, false, H_magnitude);
  sc->ANGLE =                 s7_define_safe_function(sc, "angle",                   g_angle,                  1, 0, false, H_angle);
  sc->RATIONALIZE =           s7_define_safe_function(sc, "rationalize",             g_rationalize,            1, 1, false, H_rationalize);
  sc->ABS =                   s7_define_safe_function(sc, "abs",                     g_abs,                    1, 0, false, H_abs);
  sc->EXP =                   s7_define_safe_function(sc, "exp",                     g_exp,                    1, 0, false, H_exp);
  sc->LOG =                   s7_define_safe_function(sc, "log",                     g_log,                    1, 1, false, H_log);
  sc->SIN =                   s7_define_safe_function(sc, "sin",                     g_sin,                    1, 0, false, H_sin);
  sc->COS =                   s7_define_safe_function(sc, "cos",                     g_cos,                    1, 0, false, H_cos);
  sc->TAN =                   s7_define_safe_function(sc, "tan",                     g_tan,                    1, 0, false, H_tan);
  sc->ASIN =                  s7_define_safe_function(sc, "asin",                    g_asin,                   1, 0, false, H_asin);
  sc->ACOS =                  s7_define_safe_function(sc, "acos",                    g_acos,                   1, 0, false, H_acos);
  sc->ATAN =                  s7_define_safe_function(sc, "atan",                    g_atan,                   1, 1, false, H_atan);
  sc->SINH =                  s7_define_safe_function(sc, "sinh",                    g_sinh,                   1, 0, false, H_sinh);
  sc->COSH =                  s7_define_safe_function(sc, "cosh",                    g_cosh,                   1, 0, false, H_cosh);
  sc->TANH =                  s7_define_safe_function(sc, "tanh",                    g_tanh,                   1, 0, false, H_tanh);
  sc->ASINH =                 s7_define_safe_function(sc, "asinh",                   g_asinh,                  1, 0, false, H_asinh);
  sc->ACOSH =                 s7_define_safe_function(sc, "acosh",                   g_acosh,                  1, 0, false, H_acosh);
  sc->ATANH =                 s7_define_safe_function(sc, "atanh",                   g_atanh,                  1, 0, false, H_atanh);
  sc->SQRT =                  s7_define_safe_function(sc, "sqrt",                    g_sqrt,                   1, 0, false, H_sqrt);
  sc->EXPT =                  s7_define_safe_function(sc, "expt",                    g_expt,                   2, 0, false, H_expt);
  sc->FLOOR =                 s7_define_safe_function(sc, "floor",                   g_floor,                  1, 0, false, H_floor);
  sc->CEILING =               s7_define_safe_function(sc, "ceiling",                 g_ceiling,                1, 0, false, H_ceiling);
  sc->TRUNCATE =              s7_define_safe_function(sc, "truncate",                g_truncate,               1, 0, false, H_truncate);
  sc->ROUND =                 s7_define_safe_function(sc, "round",                   g_round,                  1, 0, false, H_round);
  sc->LCM =                   s7_define_safe_function(sc, "lcm",                     g_lcm,                    0, 0, true,  H_lcm);
  sc->GCD =                   s7_define_safe_function(sc, "gcd",                     g_gcd,                    0, 0, true,  H_gcd);
  sc->ADD =                   s7_define_safe_function(sc, "+",                       g_add,                    0, 0, true,  H_add);
  sc->MINUS =                 s7_define_safe_function(sc, "-",                       g_subtract,               1, 0, true,  H_subtract);
  sc->MULTIPLY =              s7_define_safe_function(sc, "*",                       g_multiply,               0, 0, true,  H_multiply);
  sc->DIVIDE =                s7_define_safe_function(sc, "/",                       g_divide,                 1, 0, true,  H_divide);
  sc->MAX =                   s7_define_safe_function(sc, "max",                     g_max,                    1, 0, true,  H_max);
  sc->MIN =                   s7_define_safe_function(sc, "min",                     g_min,                    1, 0, true,  H_min);
  sc->QUOTIENT =              s7_define_safe_function(sc, "quotient",                g_quotient,               2, 0, false, H_quotient);
  sc->REMAINDER =             s7_define_safe_function(sc, "remainder",               g_remainder,              2, 0, false, H_remainder);
  sc->MODULO =                s7_define_safe_function(sc, "modulo",                  g_modulo,                 2, 0, false, H_modulo);
  sc->EQ =                    s7_define_safe_function(sc, "=",                       g_equal,                  2, 0, true,  H_equal);
  sc->LT =                    s7_define_safe_function(sc, "<",                       g_less,                   2, 0, true,  H_less);
  sc->GT =                    s7_define_safe_function(sc, ">",                       g_greater,                2, 0, true,  H_greater);
  sc->LEQ =                   s7_define_safe_function(sc, "<=",                      g_less_or_equal,          2, 0, true,  H_less_or_equal);
  sc->GEQ =                   s7_define_safe_function(sc, ">=",                      g_greater_or_equal,       2, 0, true,  H_greater_or_equal);

  sc->INEXACT_TO_EXACT =      s7_define_safe_function(sc, "inexact->exact",          g_inexact_to_exact,       1, 0, false, H_inexact_to_exact);
  sc->EXACT_TO_INEXACT =      s7_define_safe_function(sc, "exact->inexact",          g_exact_to_inexact,       1, 0, false, H_exact_to_inexact);

  sc->RANDOM =                s7_define_safe_function(sc, "random",                  g_random,                 1, 1, false, H_random);
  sc->MAKE_RANDOM_STATE =     s7_define_safe_function(sc, "make-random-state",       s7_make_random_state,     1, 1, false, H_make_random_state);

  sc->INTEGER_LENGTH =        s7_define_safe_function(sc, "integer-length",          g_integer_length,         1, 0, false, H_integer_length);
  sc->LOGIOR =                s7_define_safe_function(sc, "logior",                  g_logior,                 0, 0, true,  H_logior);
  sc->LOGXOR =                s7_define_safe_function(sc, "logxor",                  g_logxor,                 0, 0, true,  H_logxor);
  sc->LOGAND =                s7_define_safe_function(sc, "logand",                  g_logand,                 0, 0, true,  H_logand);
  sc->LOGNOT =                s7_define_safe_function(sc, "lognot",                  g_lognot,                 1, 0, false, H_lognot);
  sc->ASH =                   s7_define_safe_function(sc, "ash",                     g_ash,                    2, 0, false, H_ash);
#endif
  sc->LOGBITP =               s7_define_safe_function(sc, "logbit?",                 g_logbit,                 2, 0, false, H_logbit);
  sc->INTEGER_DECODE_FLOAT =  s7_define_safe_function(sc, "integer-decode-float",    g_integer_decode_float,   1, 0, false, H_integer_decode_float);

  rng_tag = s7_new_type_x("<random-number-generator>", print_rng, free_rng, equal_rng, NULL, NULL, NULL, NULL, copy_random_state, NULL, NULL);
  s7_set_object_print_readably(rng_tag, print_rng_readably);
  sc->RANDOM_STATEP =         s7_define_safe_function(sc, "random-state?",           g_is_random_state,        1, 0, false, H_is_random_state);
  sc->RANDOM_STATE_TO_LIST =  s7_define_safe_function(sc, "random-state->list",      s7_random_state_to_list,  0, 1, false, H_random_state_to_list);

  sc->NUMBERP =               s7_define_safe_function(sc, "number?",                 g_is_number,              1, 0, false, H_is_number);
  sc->INTEGERP =              s7_define_safe_function(sc, "integer?",                g_is_integer,             1, 0, false, H_is_integer);
  sc->REALP =                 s7_define_safe_function(sc, "real?",                   g_is_real,                1, 0, false, H_is_real);
  sc->COMPLEXP =              s7_define_safe_function(sc, "complex?",                g_is_complex,             1, 0, false, H_is_complex);
  sc->RATIONALP =             s7_define_safe_function(sc, "rational?",               g_is_rational,            1, 0, false, H_is_rational);
  sc->EXACTP =                s7_define_safe_function(sc, "exact?",                  g_is_exact,               1, 0, false, H_is_exact);
  sc->INEXACTP =              s7_define_safe_function(sc, "inexact?",                g_is_inexact,             1, 0, false, H_is_inexact);

  sc->NUMBER_TO_STRING =      s7_define_safe_function(sc, "number->string",          g_number_to_string,       1, 1, false, H_number_to_string);
  sc->STRING_TO_NUMBER =      s7_define_safe_function(sc, "string->number",          g_string_to_number,       1, 1, false, H_string_to_number);

  
  sc->CHAR_UPCASE =           s7_define_safe_function(sc, "char-upcase",             g_char_upcase,            1, 0, false, H_char_upcase);
  sc->CHAR_DOWNCASE =         s7_define_safe_function(sc, "char-downcase",           g_char_downcase,          1, 0, false, H_char_downcase);
  sc->CHAR_TO_INTEGER =       s7_define_safe_function(sc, "char->integer",           g_char_to_integer,        1, 0, false, H_char_to_integer);
  sc->INTEGER_TO_CHAR =       s7_define_safe_function(sc, "integer->char",           g_integer_to_char,        1, 0, false, H_integer_to_char);
  
  sc->CHAR_UPPER_CASEP =      s7_define_safe_function(sc, "char-upper-case?",        g_is_char_upper_case,     1, 0, false, H_is_char_upper_case);
  sc->CHAR_LOWER_CASEP =      s7_define_safe_function(sc, "char-lower-case?",        g_is_char_lower_case,     1, 0, false, H_is_char_lower_case);
  sc->CHAR_ALPHABETICP =      s7_define_safe_function(sc, "char-alphabetic?",        g_is_char_alphabetic,     1, 0, false, H_is_char_alphabetic);
  sc->CHAR_NUMERICP =         s7_define_safe_function(sc, "char-numeric?",           g_is_char_numeric,        1, 0, false, H_is_char_numeric);
  sc->CHAR_WHITESPACEP =      s7_define_safe_function(sc, "char-whitespace?",        g_is_char_whitespace,     1, 0, false, H_is_char_whitespace);
  sc->CHARP =                 s7_define_safe_function(sc, "char?",                   g_is_char,                1, 0, false, H_is_char);
  
  sc->CHAR_EQ =               s7_define_safe_function(sc, "char=?",                  g_chars_are_equal,        2, 0, true,  H_chars_are_equal);
  sc->CHAR_LT =               s7_define_safe_function(sc, "char<?",                  g_chars_are_less,         2, 0, true,  H_chars_are_less);
  sc->CHAR_GT =               s7_define_safe_function(sc, "char>?",                  g_chars_are_greater,      2, 0, true,  H_chars_are_greater);
  sc->CHAR_LEQ =              s7_define_safe_function(sc, "char<=?",                 g_chars_are_leq,          2, 0, true,  H_chars_are_leq);
  sc->CHAR_GEQ =              s7_define_safe_function(sc, "char>=?",                 g_chars_are_geq,          2, 0, true,  H_chars_are_geq);
  sc->CHAR_CI_EQ =            s7_define_safe_function(sc, "char-ci=?",               g_chars_are_ci_equal,     2, 0, true,  H_chars_are_ci_equal);
  sc->CHAR_CI_LT =            s7_define_safe_function(sc, "char-ci<?",               g_chars_are_ci_less,      2, 0, true,  H_chars_are_ci_less);
  sc->CHAR_CI_GT =            s7_define_safe_function(sc, "char-ci>?",               g_chars_are_ci_greater,   2, 0, true,  H_chars_are_ci_greater);
  sc->CHAR_CI_LEQ =           s7_define_safe_function(sc, "char-ci<=?",              g_chars_are_ci_leq,       2, 0, true,  H_chars_are_ci_leq);
  sc->CHAR_CI_GEQ =           s7_define_safe_function(sc, "char-ci>=?",              g_chars_are_ci_geq,       2, 0, true,  H_chars_are_ci_geq);
  
  sc->CHAR_POSITION =         s7_define_safe_function(sc, "char-position",           g_char_position,          2, 1, false,  H_char_position);
  sc->STRING_POSITION =       s7_define_safe_function(sc, "string-position",         g_string_position,        2, 1, false,  H_string_position);
  
  sc->STRINGP =               s7_define_safe_function(sc, "string?",                 g_is_string,              1, 0, false, H_is_string);
  sc->MAKE_STRING =           s7_define_safe_function(sc, "make-string",             g_make_string,            1, 1, false, H_make_string);
  sc->STRING_LENGTH =         s7_define_safe_function(sc, "string-length",           g_string_length,          1, 0, false, H_string_length);
  sc->STRING_REF =            s7_define_safe_function(sc, "string-ref",              g_string_ref,             2, 0, false, H_string_ref);
  sc->STRING_SET =            s7_define_safe_function(sc, "string-set!",             g_string_set,             3, 0, false, H_string_set);
  sc->STRING_EQ =             s7_define_safe_function(sc, "string=?",                g_strings_are_equal,      2, 0, true,  H_strings_are_equal);
  sc->STRING_LT =             s7_define_safe_function(sc, "string<?",                g_strings_are_less,       2, 0, true,  H_strings_are_less);
  sc->STRING_GT =             s7_define_safe_function(sc, "string>?",                g_strings_are_greater,    2, 0, true,  H_strings_are_greater);
  sc->STRING_LEQ =            s7_define_safe_function(sc, "string<=?",               g_strings_are_leq,        2, 0, true,  H_strings_are_leq);
  sc->STRING_GEQ =            s7_define_safe_function(sc, "string>=?",               g_strings_are_geq,        2, 0, true,  H_strings_are_geq);
  sc->STRING_CI_EQ =          s7_define_safe_function(sc, "string-ci=?",             g_strings_are_ci_equal,   2, 0, true,  H_strings_are_ci_equal);
  sc->STRING_CI_LT =          s7_define_safe_function(sc, "string-ci<?",             g_strings_are_ci_less,    2, 0, true,  H_strings_are_ci_less);
  sc->STRING_CI_GT =          s7_define_safe_function(sc, "string-ci>?",             g_strings_are_ci_greater, 2, 0, true,  H_strings_are_ci_greater);
  sc->STRING_CI_LEQ =         s7_define_safe_function(sc, "string-ci<=?",            g_strings_are_ci_leq,     2, 0, true,  H_strings_are_ci_leq);
  sc->STRING_CI_GEQ =         s7_define_safe_function(sc, "string-ci>=?",            g_strings_are_ci_geq,     2, 0, true,  H_strings_are_ci_geq);
  
  sc->STRING_APPEND =         s7_define_safe_function(sc, "string-append",           g_string_append,          0, 0, true,  H_string_append);
  sc->STRING_FILL =           s7_define_safe_function(sc, "string-fill!",            g_string_fill,            2, 2, false, H_string_fill);
  sc->STRING_COPY =           s7_define_safe_function(sc, "string-copy",             g_string_copy,            1, 0, false, H_string_copy);
  sc->SUBSTRING =             s7_define_safe_function(sc, "substring",               g_substring,              2, 1, false, H_substring);
  sc->STRING =                s7_define_safe_function(sc, "string",                  g_string,                 0, 0, true,  H_string);
  sc->LIST_TO_STRING =        s7_define_safe_function(sc, "list->string",            g_list_to_string,         1, 0, false, H_list_to_string);
  sc->STRING_TO_LIST =        s7_define_safe_function(sc, "string->list",            g_string_to_list,         1, 2, false, H_string_to_list);
  sc->OBJECT_TO_STRING =      s7_define_safe_function(sc, "object->string",          g_object_to_string,       1, 1, false, H_object_to_string);
  sc->FORMAT =                s7_define_safe_function(sc, "format",                  g_format,                 1, 0, true,  H_format);

  /* as format runs through the saved args, "~A" can call object->string; it can call format, and 
   *    sc->temp_cell_2 can be stepped on in the arg evaluation of the recursive format call,
   *    so format isn't safe if we've seen open_env + object->string.  This isn't called
   *    millions of times, normally, so I think I'll just leave it "unsafe" (rather than
   *    clearing that flag in open_environment).  Any other function that keeps sc->args
   *    in play long enough for s7_call should also be unsafe.
   *
   * Would it fix this to save/restore the temp cells across the object->string method application? -- this experiment is running...
   *   By changing to safe function, don't we use either the T|An series or the prebuilt (in-use flag) set? Perhaps temp_cell_2
   *   is not enough.
   *
   * Another gotcha with format declared safe: (format #f ...) can occur where main_stack_op is OP_BEGIN1 and yet
   *   it needs to return its value -- it might now be embedded!
   */


  sc->NULLP =                 s7_define_safe_function(sc, "null?",                   g_is_null,                1, 0, false, H_is_null);
  sc->LISTP =                 s7_define_safe_function(sc, "list?",                   g_is_list,                1, 0, false, H_is_list);
  sc->PAIRP =                 s7_define_safe_function(sc, "pair?",                   g_is_pair,                1, 0, false, H_is_pair);
  sc->CONS =                  s7_define_safe_function(sc, "cons",                    g_cons,                   2, 0, false, H_cons);

  sc->CAR =                   s7_define_safe_function(sc, "car",                     g_car,                    1, 0, false, H_car);
  sc->CDR =                   s7_define_safe_function(sc, "cdr",                     g_cdr,                    1, 0, false, H_cdr);
  sc->SET_CARB =              s7_define_safe_function(sc, "set-car!",                g_set_car,                2, 0, false, H_set_car); /* ?: list-set! is safe */
  sc->SET_CDRB =              s7_define_function(sc,      "set-cdr!",                g_set_cdr,                2, 0, false, H_set_cdr);
  sc->CAAR =                  s7_define_safe_function(sc, "caar",                    g_caar,                   1, 0, false, H_caar);
  sc->CADR =                  s7_define_safe_function(sc, "cadr",                    g_cadr,                   1, 0, false, H_cadr);
  sc->CDAR =                  s7_define_safe_function(sc, "cdar",                    g_cdar,                   1, 0, false, H_cdar);
  sc->CDDR =                  s7_define_safe_function(sc, "cddr",                    g_cddr,                   1, 0, false, H_cddr);
  sc->CAAAR =                 s7_define_safe_function(sc, "caaar",                   g_caaar,                  1, 0, false, H_caaar);
  sc->CAADR =                 s7_define_safe_function(sc, "caadr",                   g_caadr,                  1, 0, false, H_caadr);
  sc->CADAR =                 s7_define_safe_function(sc, "cadar",                   g_cadar,                  1, 0, false, H_cadar);
  sc->CDAAR =                 s7_define_safe_function(sc, "cdaar",                   g_cdaar,                  1, 0, false, H_cdaar);
  sc->CADDR =                 s7_define_safe_function(sc, "caddr",                   g_caddr,                  1, 0, false, H_caddr);
  sc->CDDDR =                 s7_define_safe_function(sc, "cdddr",                   g_cdddr,                  1, 0, false, H_cdddr);
  sc->CDADR =                 s7_define_safe_function(sc, "cdadr",                   g_cdadr,                  1, 0, false, H_cdadr);
  sc->CDDAR =                 s7_define_safe_function(sc, "cddar",                   g_cddar,                  1, 0, false, H_cddar);
  sc->CAAAAR =                s7_define_safe_function(sc, "caaaar",                  g_caaaar,                 1, 0, false, H_caaaar);
  sc->CAAADR =                s7_define_safe_function(sc, "caaadr",                  g_caaadr,                 1, 0, false, H_caaadr);
  sc->CAADAR =                s7_define_safe_function(sc, "caadar",                  g_caadar,                 1, 0, false, H_caadar);
  sc->CADAAR =                s7_define_safe_function(sc, "cadaar",                  g_cadaar,                 1, 0, false, H_cadaar);
  sc->CAADDR =                s7_define_safe_function(sc, "caaddr",                  g_caaddr,                 1, 0, false, H_caaddr);
  sc->CADDDR =                s7_define_safe_function(sc, "cadddr",                  g_cadddr,                 1, 0, false, H_cadddr);
  sc->CADADR =                s7_define_safe_function(sc, "cadadr",                  g_cadadr,                 1, 0, false, H_cadadr);
  sc->CADDAR =                s7_define_safe_function(sc, "caddar",                  g_caddar,                 1, 0, false, H_caddar);
  sc->CDAAAR =                s7_define_safe_function(sc, "cdaaar",                  g_cdaaar,                 1, 0, false, H_cdaaar);
  sc->CDAADR =                s7_define_safe_function(sc, "cdaadr",                  g_cdaadr,                 1, 0, false, H_cdaadr);
  sc->CDADAR =                s7_define_safe_function(sc, "cdadar",                  g_cdadar,                 1, 0, false, H_cdadar);
  sc->CDDAAR =                s7_define_safe_function(sc, "cddaar",                  g_cddaar,                 1, 0, false, H_cddaar);
  sc->CDADDR =                s7_define_safe_function(sc, "cdaddr",                  g_cdaddr,                 1, 0, false, H_cdaddr);
  sc->CDDDDR =                s7_define_safe_function(sc, "cddddr",                  g_cddddr,                 1, 0, false, H_cddddr);
  sc->CDDADR =                s7_define_safe_function(sc, "cddadr",                  g_cddadr,                 1, 0, false, H_cddadr);
  sc->CDDDAR =                s7_define_safe_function(sc, "cdddar",                  g_cdddar,                 1, 0, false, H_cdddar);

  sc->ASSQ =                  s7_define_safe_function(sc, "assq",                    g_assq,                   2, 0, false, H_assq);
  sc->ASSV =                  s7_define_safe_function(sc, "assv",                    g_assv,                   2, 0, false, H_assv);
  sc->ASSOC =                 s7_define_function(sc,      "assoc",                   g_assoc,                  2, 1, false, H_assoc);
  sc->MEMQ =                  s7_define_safe_function(sc, "memq",                    g_memq,                   2, 0, false, H_memq);
  sc->MEMV =                  s7_define_safe_function(sc, "memv",                    g_memv,                   2, 0, false, H_memv);
  sc->MEMBER =                s7_define_function(sc,      "member",                  g_member,                 2, 1, false, H_member);

  sc->APPEND =                s7_define_safe_function(sc, "append",                  g_append,                 0, 0, true,  H_append);
  sc->LIST =                  s7_define_function(sc,      "list",                    g_list,                   0, 0, true,  H_list);
  {
    s7_pointer p;
    p = s7_symbol_value(sc, sc->LIST);
    set_copy_args(p);
    /* currently list is not safe because this copy_args bit is being ignored in the safe func case? 
     *  (i.e. OP_C_... as opposed to OP_SAFE_C...)
     */
  }
  sc->LIST_REF =              s7_define_safe_function(sc, "list-ref",                g_list_ref,               2, 0, true,  H_list_ref);
  sc->LIST_SET =              s7_define_safe_function(sc, "list-set!",               g_list_set,               3, 0, true,  H_list_set);
  sc->LIST_TAIL =             s7_define_safe_function(sc, "list-tail",               g_list_tail,              2, 0, false, H_list_tail);
  sc->MAKE_LIST =             s7_define_safe_function(sc, "make-list",               g_make_list,              1, 1, false, H_make_list);


  sc->LENGTH =                s7_define_safe_function(sc, "length",                  g_length,                 1, 0, false, H_length);
  sc->COPY =                  s7_define_safe_function(sc, "copy",                    g_copy,                   1, 3, false, H_copy);
  sc->FILL =                  s7_define_function(sc,      "fill!",                   g_fill,                   2, 0, false, H_fill);
  sc->REVERSE =               s7_define_safe_function(sc, "reverse",                 g_reverse,                1, 0, false, H_reverse);
  sc->REVERSEB =              s7_define_function(sc,      "reverse!",                g_reverse_in_place,       1, 0, false, H_reverse_in_place); /* used by Snd code */
  sc->SORT =                  s7_define_function(sc,      "sort!",                   g_sort,                   2, 0, false, H_sort);

  sc->LIST_TO_VECTOR =        s7_define_safe_function(sc, "list->vector",            g_list_to_vector,         1, 0, false, H_list_to_vector);
  sc->VECTOR_TO_LIST =        s7_define_safe_function(sc, "vector->list",            g_vector_to_list,         1, 2, false, H_vector_to_list);
  sc->VECTORP =               s7_define_safe_function(sc, "vector?",                 g_is_vector,              1, 0, false, H_is_vector);
  sc->VECTOR_APPEND =         s7_define_safe_function(sc, "vector-append",           g_vector_append,          0, 0, true,  H_vector_append);
  sc->VECTOR_FILL =           s7_define_safe_function(sc, "vector-fill!",            g_vector_fill,            2, 2, false, H_vector_fill);
  sc->VECTOR_LENGTH =         s7_define_safe_function(sc, "vector-length",           g_vector_length,          1, 0, false, H_vector_length);
  sc->VECTOR_REF =            s7_define_safe_function(sc, "vector-ref",              g_vector_ref,             2, 0, true,  H_vector_ref);
  sc->VECTOR_SET =            s7_define_safe_function(sc, "vector-set!",             g_vector_set,             3, 0, true,  H_vector_set);
  sc->VECTOR_DIMENSIONS =     s7_define_safe_function(sc, "vector-dimensions",       g_vector_dimensions,      1, 0, false, H_vector_dimensions);
  sc->MAKE_VECTOR =           s7_define_safe_function(sc, "make-vector",             g_make_vector,            1, 2, false, H_make_vector);
  sc->MAKE_SHARED_VECTOR =    s7_define_safe_function(sc, "make-shared-vector",      g_make_shared_vector,     2, 0, false, H_make_shared_vector);
  sc->VECTOR =                s7_define_safe_function(sc, "vector",                  g_vector,                 0, 0, true,  H_vector);
  set_setter(sc->VECTOR); /* ?? */
  sc->Vector = s7_symbol_value(sc, sc->VECTOR);
  set_setter(sc->Vector);


                              s7_define_safe_function(sc, "bytevector?",             g_is_bytevector,          1, 0, false, H_is_bytevector);
  sc->TO_BYTEVECTOR =         s7_define_safe_function(sc, "->bytevector",            g_to_bytevector,          1, 0, false, H_to_bytevector);
  sc->BYTEVECTOR =            s7_define_safe_function(sc, "bytevector",              g_bytevector,             0, 0, true,  H_bytevector);
  sc->MAKE_BYTEVECTOR =       s7_define_safe_function(sc, "make-bytevector",         g_make_bytevector,        1, 1, false, H_make_bytevector);

  sc->HASH_TABLE =            s7_define_safe_function(sc, "hash-table",              g_hash_table,             0, 0, true,  H_hash_table);
  sc->HASH_TABLEP =           s7_define_safe_function(sc, "hash-table?",             g_is_hash_table,          1, 0, false, H_is_hash_table);
  sc->MAKE_HASH_TABLE =       s7_define_safe_function(sc, "make-hash-table",         g_make_hash_table,        0, 2, false, H_make_hash_table);
  sc->HASH_TABLE_REF =        s7_define_safe_function(sc, "hash-table-ref",          g_hash_table_ref,         2, 0, true,  H_hash_table_ref);
  sc->HASH_TABLE_SET =        s7_define_safe_function(sc, "hash-table-set!",         g_hash_table_set,         3, 0, false, H_hash_table_set);
  sc->HASH_TABLE_SIZE =       s7_define_safe_function(sc, "hash-table-size",         g_hash_table_size,        1, 0, false, H_hash_table_size);
  
  s7_define_safe_function(sc, "hash-table-index", g_hash_table_index, 1, 0, false, "an experiment");

  ht_iter_tag = s7_new_type_x("<hash-table-iterator>", print_ht_iter, free_ht_iter, equal_ht_iter, mark_ht_iter, ref_ht_iter, NULL, NULL, copy_ht_iter, NULL, NULL);
  sc->MAKE_HASH_TABLE_ITERATOR = s7_define_safe_function(sc, "make-hash-table-iterator", g_make_hash_table_iterator, 1, 0, false, H_make_hash_table_iterator);
  sc->HASH_TABLE_ITERATORP =    s7_define_safe_function(sc, "hash-table-iterator?",  g_is_hash_table_iterator, 1, 0, false, H_is_hash_table_iterator);
  s7_set_object_print_readably(ht_iter_tag, write_ht_iter_readably);


  sc->CALL_CC =               s7_define_function(sc,      "call/cc",                 g_call_cc,                1, 0, false, H_call_cc);
                              s7_define_function(sc,      "call-with-current-continuation", g_call_cc,         1, 0, false, H_call_cc);
  sc->CONTINUATIONP =         s7_define_safe_function(sc, "continuation?",           g_is_continuation,        1, 0, false, H_is_continuation);
  sc->CALL_WITH_EXIT =        s7_define_function(sc,      "call-with-exit",          g_call_with_exit,         1, 0, false, H_call_with_exit);

  sc->LOAD =                  s7_define_function(sc,      "load",                    g_load,                   1, 1, false, H_load);
  sc->AUTOLOAD =              s7_define_function(sc,      "autoload",                g_autoload,               2, 0, false, H_autoload);
  sc->EVAL =                  s7_define_function(sc,      "eval",                    g_eval,                   1, 1, false, H_eval);
  sc->EVAL_STRING =           s7_define_function(sc,      "eval-string",             g_eval_string,            1, 1, false, H_eval_string);
  sc->APPLY =                 s7_define_function(sc,      "apply",                   g_apply,                  1, 0, true,  H_apply);
  sc->Apply = s7_symbol_value(sc, sc->APPLY);
  set_type(sc->Apply, type(sc->Apply) | T_COPY_ARGS);
  /* (let ((x '((1 2) 3 4))) 
   *   (catch #t (lambda () (apply apply apply x)) (lambda args 'error)) 
   *   x)
   * should not mess up x!
   */

  sc->FOR_EACH =              s7_define_function(sc,      "for-each",                g_for_each,               2, 0, true,  H_for_each);
  sc->MAP =                   s7_define_function(sc,      "map",                     g_map,                    2, 0, true,  H_map);

  sc->VALUES =                s7_define_function(sc,      "values",                  g_values,                 0, 0, true,  H_values);
  sc->DYNAMIC_WIND =          s7_define_function(sc,      "dynamic-wind",            g_dynamic_wind,           3, 0, false, H_dynamic_wind);
  sc->CATCH =                 s7_define_function(sc,      "catch",                   g_catch,                  3, 0, false, H_catch);
  sc->THROW =                 s7_define_function(sc,      "throw",                   g_throw,                  1, 0, true,  H_throw);
  sc->ERROR =                 s7_define_function(sc,      "error",                   g_error,                  0, 0, true,  H_error);

  /* these are internal for quasiquote's use -- they are values, not symbols */
  sc->QQ_Apply_Values =       s7_define_constant_function(sc, "{apply_values}",      g_apply_values,           0, 0, true,  H_apply_values);
  sc->QQ_Append =             s7_define_constant_function(sc, "{append}",            g_append,                 0, 0, true,  H_append);
  sc->Multivector =           s7_define_constant_function(sc, "{multivector}",       g_qq_multivector,         1, 0, true,  H_qq_multivector);
  sc->QQ_List =               s7_define_constant_function(sc, "{list}",              g_qq_list,                0, 0, true,  H_qq_list);
  set_type(sc->QQ_List, (T_C_LST_ARGS_FUNCTION | T_PROCEDURE | T_COPY_ARGS));

  sc->GC =                    s7_define_safe_function(sc, "gc",                      g_gc,                     0, 1, false, H_gc);

  sc->PROCEDUREP =            s7_define_safe_function(sc, "procedure?",              g_is_procedure,           1, 0, false, H_is_procedure);
  sc->PROCEDURE_DOCUMENTATION = s7_define_safe_function(sc, "procedure-documentation", g_procedure_documentation, 1, 0, false, H_procedure_documentation);
  sc->HELP =                  s7_define_safe_function(sc, "help",                    g_help,                   1, 0, false, H_help);
  sc->PROCEDURE_ARITY =       s7_define_safe_function(sc, "procedure-arity",         g_procedure_arity,        1, 0, false, H_procedure_arity);
  sc->PROCEDURE_SOURCE =      s7_define_safe_function(sc, "procedure-source",        g_procedure_source,       1, 0, false, H_procedure_source);
  sc->PROCEDURE_ENVIRONMENT = s7_define_safe_function(sc, "procedure-environment",   g_procedure_environment,  1, 0, false, H_procedure_environment);
  sc->UNOPTIMIZE =            s7_define_safe_function(sc, "unoptimize",              g_unoptimize,             1, 0, false, H_unoptimize);
  sc->PROCEDURE_NAME =        s7_define_safe_function(sc, "procedure-name",          g_procedure_name,         1, 0, false, H_procedure_name);
  s7_make_procedure_with_setter(sc,                       "procedure-setter",   
				g_procedure_setter, 1, 0,
				g_procedure_set_setter, 2, 0,
				H_procedure_setter);

  sc->ARITY =                 s7_define_safe_function(sc, "arity",                   g_arity,                  1, 0, false, H_arity);
  sc->ARITABLEP =             s7_define_safe_function(sc, "aritable?",               g_is_aritable,            2, 0, false, H_is_aritable);
  
  sc->NOT =                   s7_define_safe_function(sc, "not",                     g_not,                    1, 0, false, H_not);
  sc->BOOLEANP =              s7_define_safe_function(sc, "boolean?",                g_is_boolean,             1, 0, false, H_is_boolean);
                              s7_define_safe_function(sc, "boolean=?",               g_booleans_are_eq,        2, 0, true,  H_booleans_are_eq);
                              s7_define_safe_function(sc, "symbol=?",                g_symbols_are_eq,         2, 0, true,  H_symbols_are_eq);
  sc->EQP =                   s7_define_safe_function(sc, "eq?",                     g_is_eq,                  2, 0, false, H_is_eq);
  sc->EQVP =                  s7_define_safe_function(sc, "eqv?",                    g_is_eqv,                 2, 0, false, H_is_eqv);
  sc->EQUALP =                s7_define_safe_function(sc, "equal?",                  g_is_equal,               2, 0, false, H_is_equal);
  sc->MORALLY_EQUALP =        s7_define_safe_function(sc, "morally-equal?",          g_is_morally_equal,       2, 0, false, H_is_morally_equal);
  
  s7_define_safe_function(sc,                             "s7-version",              g_s7_version,             0, 0, false, H_s7_version);
  s7_define_safe_function(sc,                             "emergency-exit",          g_emergency_exit,         0, 1, false, H_emergency_exit);
  s7_define_safe_function(sc,                             "exit",                    g_exit,                   0, 1, false, H_exit);
#if DEBUGGING
  s7_define_function(sc,                                  "abort",                   g_abort,                  0, 0, false, "drop into gdb I hope");
#endif

  {
    s7_pointer sym;
    sym = s7_define_function(sc,                      "(c-object set)",            g_internal_object_set,      1, 0, true,  "internal object setter redirection");
    sc->Object_Set = s7_symbol_value(sc, sym);
    sym = s7_define_function(sc,                      "(c-object set-3)",          g_internal_object_set_3,    1, 0, true,  "internal object setter redirection");
    sc->Object_Set_3 = s7_symbol_value(sc, sym);
  }


  /* -------- *gc-stats* -------- */
  s7_define_variable(sc, "*gc-stats*", sc->F);
  sc->GC_STATS = s7_make_symbol(sc, "*gc-stats*");
  s7_symbol_set_access(sc, sc->GC_STATS,
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *gc-stats*)", g_gc_stats_set, 2, 0, false, "called if *gc-stats* is set"), 
			      s7_make_function(sc, "(bind *gc-stats*)", g_gc_stats_set, 2, 0, false, "called if *gc-stats* is bound")));

  /* -------- *features* -------- */
  s7_define_variable(sc, "*features*", sc->NIL);
  sc->S7_FEATURES = s7_make_symbol(sc, "*features*");
  s7_symbol_set_access(sc, sc->S7_FEATURES,
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *features*)", g_features_set, 2, 0, false, "called if *features* is set"), 
			      s7_make_function(sc, "(bind *features*)", g_features_set, 2, 0, false, "called if *features* is bound")));

  /* -------- *vector-print-length* -------- */
  s7_define_variable(sc, "*vector-print-length*", small_int(8));
  sc->vector_print_length = global_slot(make_symbol(sc, "*vector-print-length*"));
  s7_symbol_set_access(sc, s7_make_symbol(sc, "*vector-print-length*"), 
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *vector-print-length*)", g_vector_print_length_set, 2, 0, false, 
					       "called if *vector-print-length* is set"), 
			      sc->F));

  /* -------- *safety* -------- */
  s7_define_variable(sc, "*safety*", small_int(sc->safety));
  s7_symbol_set_access(sc, s7_make_symbol(sc, "*safety*"), 
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *safety*)", g_safety_set, 2, 0, false, "called if *safety* is set"), 
			      s7_make_function(sc, "(bind *safety*)", g_safety_bind, 2, 0, false, "called if *safety* is bound")));


  /* -------- *load-path* -------- */
  s7_define_variable(sc, "*load-path*", sc->NIL);
  sc->LOAD_PATH = s7_make_symbol(sc, "*load-path*");
  s7_symbol_set_access(sc, sc->LOAD_PATH,
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *load-path*)", g_load_path_set, 2, 0, false, "called if *load-path* is set"), 
			      s7_make_function(sc, "(bind *load-path*)", g_load_path_set, 2, 0, false, "called if *load-path* is bound")));

  /* -------- *autoload* -------- 
   * this pretends to be a hash-table or environment, but it's actually a function
   */
  sc->AUTOLOADER = s7_define_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader);
  s7_define_variable(sc, "*libraries*", sc->NIL);
  sc->libraries = global_slot(make_symbol(sc, "*libraries*"));
  

  /* -------- *#readers* -------- */
  s7_define_variable(sc, "*#readers*", sc->NIL);
  sc->sharp_readers = global_slot(make_symbol(sc, "*#readers*"));
  s7_symbol_set_access(sc, s7_make_symbol(sc, "*#readers*"), 
		       list_3(sc, 
			      sc->F, 
			      s7_make_function(sc, "(set *#readers*)", g_sharp_readers_set, 2, 0, false, "called if *#readers* is set"), 
			      s7_make_function(sc, "(bind *#readers*)", g_sharp_readers_set, 2, 0, false, "called if *#readers* is bound")));


  /* the next two are for the test suite */
  s7_make_procedure_with_setter(sc, "-s7-symbol-table-locked?", 
				g_symbol_table_is_locked, 0, 0, 
				g_set_symbol_table_is_locked, 1, 0, 
				H_symbol_table_is_locked);

  s7_define_safe_function(sc, "*stack-top*", g_stack_top, 0, 0, false, "current stack top");
  sc->STACKTRACE = s7_define_safe_function(sc, "stacktrace", g_stacktrace, 0, 5, false, H_stacktrace);
  sc->stacktrace_env = s7_augment_environment(sc, sc->global_env, 
					      s7_list(sc, 5, 
						      cons(sc, s7_make_symbol(sc, "max-frames"), small_int(3)),
						      cons(sc, s7_make_symbol(sc, "code-cols"), small_int(45)),
						      cons(sc, s7_make_symbol(sc, "total-cols"), small_int(80)),
						      cons(sc, s7_make_symbol(sc, "notes-start-col"), small_int(45)),
						      cons(sc, s7_make_symbol(sc, "as-comment"), sc->T)));
  s7_define_constant(sc, "*stacktrace*", sc->stacktrace_env);

  /* sigh... I don't like these! */
  s7_define_variable(sc, "nan.0", real_NaN);
  s7_define_variable(sc, "-nan.0", real_NaN);
  s7_define_variable(sc, "inf.0", make_permanent_real(INFINITY));
  s7_define_variable(sc, "-inf.0", make_permanent_real(-INFINITY));

				
  /* *features* */
  s7_provide(sc, "s7");
  s7_provide(sc, "s7-" S7_VERSION);
  s7_provide(sc, "ratio");

#if WITH_EXTRA_EXPONENT_MARKERS
  s7_provide(sc, "dfls-exponents");
#endif
#if WITH_AT_SIGN_AS_EXPONENT
  s7_provide(sc, "@-exponent");
#endif
#if WITH_SYSTEM_EXTRAS
  s7_provide(sc, "system-extras");
#endif
#if WITH_IMMUTABLE_UNQUOTE
  s7_provide(sc, "immutable-unquote");
#endif
#if DEBUGGING
  s7_provide(sc, "debugging");
#endif
#if HAVE_COMPLEX_NUMBERS
  s7_provide(sc, "complex-numbers");
#endif
#if WITH_C_LOADER
  s7_provide(sc, "dlopen");
#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 __CYGWIN__
  s7_provide(sc, "cygwin");
#endif
#ifdef __hpux
  s7_provide(sc, "hpux");
#endif
#if defined(__sun) && defined(__SVR4)
  s7_provide(sc, "solaris");
#endif


  sc->Vector_Set = s7_symbol_value(sc, sc->VECTOR_SET);
  set_setter(sc->Vector_Set);
  set_setter(sc->VECTOR_SET);
  
  sc->List_Set = s7_symbol_value(sc, sc->LIST_SET);
  set_setter(sc->List_Set);
  set_setter(sc->LIST_SET);
  
  sc->Hash_Table_Set = s7_symbol_value(sc, sc->HASH_TABLE_SET);
  set_setter(sc->Hash_Table_Set);
  set_setter(sc->HASH_TABLE_SET);
  
  sc->Environment_Set = s7_symbol_value(sc, sc->ENVIRONMENT_SET);
  set_setter(sc->Environment_Set);
  set_setter(sc->ENVIRONMENT_SET);
  
  set_setter(sc->CONS); /* ?? */
  sc->Cons = s7_symbol_value(sc, sc->CONS);
  set_setter(sc->Cons); 
  /* if cons is a setter, what about append? */
  
  sc->String_Set = s7_symbol_value(sc, sc->STRING_SET);
  set_setter(sc->String_Set);
  set_setter(sc->STRING_SET);

  set_setter(sc->SET_CARB);
  set_setter(s7_symbol_value(sc, sc->SET_CARB));
  set_setter(sc->SET_CDRB);
  set_setter(s7_symbol_value(sc, sc->SET_CDRB));

  set_setter(s7_make_symbol(sc, "set-current-input-port"));
  set_setter(s7_make_symbol(sc, "set-current-output-port"));
  set_setter(s7_make_symbol(sc, "set-current-error-port"));

  s7_function_set_setter(sc, "car",                 "set-car!");
  s7_function_set_setter(sc, "cdr",                 "set-cdr!");
  s7_function_set_setter(sc, "hash-table-ref",      "hash-table-set!");
  s7_function_set_setter(sc, "vector-ref",          "vector-set!");
  s7_function_set_setter(sc, "list-ref",            "list-set!");
  s7_function_set_setter(sc, "string-ref",          "string-set!");
  s7_function_set_setter(sc, "current-input-port",  "set-current-input-port");
  s7_function_set_setter(sc, "current-output-port", "set-current-output-port");
  s7_function_set_setter(sc, "current-error-port",  "set-current-error-port");

  {
    int i, top;
#if WITH_GMP
    #define S7_LOG_LLONG_MAX 36.736800
    #define S7_LOG_LONG_MAX  16.6355322
#else
    /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) 
     *   (using 63 and 31 bits)
     */
    #define S7_LOG_LLONG_MAX 43.668274
    #define S7_LOG_LONG_MAX  21.487562
#endif

    top = sizeof(s7_Int);
    s7_int_max = (top == 8) ? S7_LONG_MAX : S7_SHORT_MAX;
    s7_int_min = (top == 8) ? S7_LONG_MIN : S7_SHORT_MIN;
    s7_int_bits = (top == 8) ? 63 : 31;
    s7_int_digits = (top == 8) ? 18 : 8;

    s7_Int_max = (top == 8) ? S7_LLONG_MAX : S7_LONG_MAX;
    s7_Int_min = (top == 8) ? S7_LLONG_MIN : S7_LONG_MIN;

    s7_int_digits_by_radix[0] = 0;
    s7_int_digits_by_radix[1] = 0;

    for (i = 2; i < 17; i++)
      s7_int_digits_by_radix[i] = (int)(floor(((top == 8) ? S7_LOG_LLONG_MAX : S7_LOG_LONG_MAX) / log((double)i)));

    s7_define_constant(sc, "most-positive-fixnum", make_permanent_integer((top == 8) ? S7_LLONG_MAX : ((top == 4) ? S7_LONG_MAX : S7_SHORT_MAX)));
    s7_define_constant(sc, "most-negative-fixnum", make_permanent_integer((top == 8) ? S7_LLONG_MIN : ((top == 4) ? S7_LONG_MIN : S7_SHORT_MIN)));
    
    if (top == 4) default_rationalize_error = 1.0e-6;
    s7_define_constant(sc, "pi", real_pi);
    sc->PI = s7_make_symbol(sc, "pi");

    sc->default_rng = (s7_rng_t *)calloc(1, sizeof(s7_rng_t));
    sc->default_rng->ran_seed = (unsigned int)time(NULL);
    sc->default_rng->ran_carry = 1675393560;

    /* for s7_Double, float gives about 9 digits, double 18, long Double claims 28 but I don't see more than about 22? */
  }

#if WITH_GMP
  s7_gmp_init(sc);
#endif

#if WITH_DUMP_HEAP  
  s7_define_function(sc, "dump-heap", g_dump_heap, 0, 0, false, "write heap contents to heap.data"); 
#endif

  init_choosers(sc);

  /* macroexpand 
   *   needs to be a bacro so locally defined macros are expanded:
   *   (let () (define-macro (hi a) `(+ ,a 1)) (macroexpand (hi 2)))
   */
  s7_eval_c_string(sc, "(define-bacro (macroexpand __mac__) `(,(procedure-source (car __mac__)) ',__mac__))");
  /*
   * it's possible to clobber this definition via (for example):
   *   (set-car! (cddr (procedure-source macroexpand)) '(0))
   */
  
  /* quasiquote
   */
  s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote);

  /* letrec* -- the less said the better...
   */
  s7_eval_c_string(sc, "(define-macro (letrec* bindings . body)                             \n\
                          (if (null? body)                                                  \n\
                              (error 'syntax-error \"letrec* has no body\")                 \n\
                              (if (not (list? bindings))                                    \n\
                                  (error 'syntax-error \"letrec* variables are messed up\") \n\
                                  `(let (,@(map (lambda (var&init)                          \n\
                                                  (list (car var&init) #<undefined>))       \n\
                                                bindings))                                  \n\
                                     ,@(map (lambda (var&init)                              \n\
                                              (if (not (null? (cddr var&init)))             \n\
                                                  (error 'syntax-error \"letrec* variable has more than one value\")) \n\
                                              (list 'set! (car var&init) (cadr var&init)))  \n\
                                             bindings)                                      \n\
                                     ,@body))))");

  /* minor bug here: (letrec* ((x 1) (x 2)) ...) complains: duplicate identifier in let, but it should say letrec*, might use:
   *   (define (duplicate-car-memq lst) 
   *      (and (not (null? lst))
   *           (or (member (caar lst) (cdr lst) (lambda (x y) (eq? x (car y)))) 
   *               (duplicate-car-memq (cdr lst)))))
   */


  /* call-with-values is almost a no-op in this context 
   */
  s7_eval_c_string(sc, "(define-macro (call-with-values producer consumer) `(,consumer (,producer)))"); 
  /* (call-with-values (lambda () (values 1 2 3)) +) */

  s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) `((lambda ,vars ,@body) ,expression))");
  /* (multiple-value-bind (a b) (values 1 2) (+ a b)) */
  /*   named "receive" in srfi-8 which strikes me as perverse */

  s7_eval_c_string(sc, "(define-macro (multiple-value-set! vars expr . body)                                  \n\
                          (let ((local-vars (map (lambda (n) (gensym)) vars)))                                \n\
                            `((lambda ,local-vars                                                             \n\
                                ,@(map (lambda (n ln)                                                         \n\
                                         `(set! ,n ,ln))                                                      \n\
                                       vars local-vars)                                                       \n\
                                ,@body)                                                                       \n\
                              ,expr)))");


  /* ---------------- make-procedure-with-setter ---------------- */

  s7_eval_c_string(sc, "(define (make-procedure-with-setter g s)                                              \n\
                          \"(make-procedure-with-setter g s) returns a function (g) whose setter is s.\"      \n\
                          (if (or (not (procedure? g)) (not (procedure? s)))                                  \n\
                              (error 'wrong-type-arg \"procedure-with-setter takes 2 procedures: ~A ~A\" g s) \n\
                              (set! (procedure-setter g) s))                                                  \n\
                          g)");

  s7_eval_c_string(sc, "(define (procedure-with-setter? obj)                                                  \n\
                          \"(procedure-with-setter? obj) returns #t if obj is a procedure with setter.\"      \n\
                          (and (procedure? obj) (procedure? (procedure-setter obj))))");


  /* ---------------- cond-expand ---------------- */

  /* cond-expand (uses *features*) 
   */
  s7_eval_c_string(sc, "(define-macro (cond-expand . clauses)                                                 \n\
                          (letrec ((traverse (lambda (tree)                                                   \n\
		                               (if (pair? tree)                                               \n\
			                            (cons (traverse (car tree))                               \n\
				                          (if (null? (cdr tree)) () (traverse (cdr tree))))   \n\
			                            (if (memq tree '(and or not else)) tree                   \n\
			                                (and (symbol? tree) (provided? tree)))))))            \n\
                            `(cond ,@(map (lambda (clause)                                                    \n\
		                             (cons (traverse (car clause))                                    \n\
			                           (if (null? (cdr clause)) '(#f) (cdr clause))))             \n\
		                          clauses))))");

  s7_eval_c_string(sc, "(define-expansion (reader-expand . clauses)                                           \n\
                          (letrec ((traverse (lambda (tree)                                                   \n\
		                               (if (pair? tree)                                               \n\
			                           (cons (traverse (car tree))                                \n\
				                         (if (null? (cdr tree)) () (traverse (cdr tree))))    \n\
			                           (if (memq tree '(and or not else)) tree                    \n\
			                               (and (symbol? tree) (provided? tree)))))))             \n\
                            (call-with-exit                                                                   \n\
                              (lambda (return)                                                                \n\
                                (for-each                                                                     \n\
	                          (lambda (clause)                                                            \n\
	                            (if (eval (traverse (car clause)))                                        \n\
	                                (if (null? (cddr clause))                                             \n\
                                            (return (cadr clause))                                            \n\
                                            (return `(begin ,@(cdr clause))))))                               \n\
	                          clauses)                                                                    \n\
                                (values)))))");

  s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses)                                             \n\
                          (call-with-exit                                                                     \n\
                            (lambda (return)                                                                  \n\
                              (for-each                                                                       \n\
                                (lambda (clause)                                                              \n\
	                          (if (eval (car clause))                                                     \n\
	                              (if (null? (cddr clause))                                               \n\
                                          (return (cadr clause))                                              \n\
                                          (return `(begin ,@(cdr clause))))))                                 \n\
                                clauses)                                                                      \n\
                              (values))))");
  /* TODO: doc/test reader-cond and reader-expand
   *   (what happens if the read-time eval hits an error?)
   */


  /* ---------------- hooks ---------------- */

  s7_eval_c_string(sc, "(define (make-hook . args)                                                            \n\
                          (let ((init ())                                                                     \n\
	                        (body ())                                                                     \n\
	                        (end ()))                                                                     \n\
                            (apply lambda* args                                                               \n\
                              '(let ((result #<unspecified>))                                                 \n\
                                 (let ((e (current-environment)))                                             \n\
                                   (dynamic-wind                                                              \n\
	                             (lambda () (for-each (lambda (f) (f e)) init))                           \n\
	                             (lambda () (for-each (lambda (f) (f e)) body) result)                    \n\
	                             (lambda () (for-each (lambda (f) (f e)) end)))))                         \n\
                              ())))");

  s7_eval_c_string(sc, "(define hook-functions                                                                \n\
                          (make-procedure-with-setter                                                         \n\
                            (lambda (hook)                                                                    \n\
                              ((procedure-environment hook) 'body))                                           \n\
                            (lambda (hook lst)                                                                \n\
                              (if (or (null? lst)                                                             \n\
                                      (and (pair? lst)                                                        \n\
                                           (apply and (map (lambda (f)                                        \n\
                                                             (and (procedure? f)                              \n\
                                                                  (aritable? f 1)))                           \n\
                                                           lst))))                                            \n\
                                  (set! ((procedure-environment hook) 'body) lst)                             \n\
                                  (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst)))))");

  /* if the error checks are removed, s7test will be very unhappy 
   */
  
  /* -------- *unbound-variable-hook* -------- */
  sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)");
  s7_define_constant(sc, "*unbound-variable-hook*", sc->unbound_variable_hook); 
  
  /* -------- *load-hook* -------- */
  sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)");
  s7_define_constant(sc, "*load-hook*", sc->load_hook);

  /* -------- *error-hook* -------- */
  sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  s7_define_constant(sc, "*error-hook*", sc->error_hook);
  
  /* fprintf(stderr, "size: %d, max op: %d\n", (int)sizeof(s7_cell), OP_MAX_DEFINED); */
  /* 64 bit machine: size: 48, max op: 320 [size 72 if gmp] */

#if DEBUGGING
  if (strcmp(op_names[OP_DEFINE_BACRO_STAR], "define-bacro*") != 0)
    fprintf(stderr, "define-bacro* op: %s\n", op_names[OP_DEFINE_BACRO_STAR]);
  if (strcmp(real_op_names[OP_DEFINE_BACRO_STAR], "OP_DEFINE_BACRO_STAR") != 0)
    fprintf(stderr, "define-bacro* real op: %s\n", op_names[OP_DEFINE_BACRO_STAR]);

  if (strcmp(op_names[OP_SAFE_C_opSq_P_1], "c_opsq_p_1") != 0)
    fprintf(stderr, "safe_c_opsq_p_1 op_names: %s\n", op_names[OP_SAFE_C_opSq_P_1]);
  if (strcmp(real_op_names[OP_SAFE_C_opSq_P_1], "OP_SAFE_C_opSq_P_1") != 0)
    fprintf(stderr, "safe_c_opsq_p_1 real_op_names: %s\n", real_op_names[OP_SAFE_C_opSq_P_1]);

  if (strcmp(opt_names[OPT_MAX_DEFINED], "opt_max_defined") != 0)
    fprintf(stderr, "opt_max_defined opt_names: %s\n", opt_names[OPT_MAX_DEFINED]);
#if 0
  {
    int k;
    for (k = 0; k < OP_MAX_DEFINED; k++)
      fprintf(stderr, "%s: %s\n", op_names[k], real_op_names[k]);
  }
#endif
#else
  if ((!opt_names[0]) || (!real_op_names[0])) fprintf(stderr, "right"); /* this is just to make a compiler warning go away */
#endif

  save_initial_environment(sc);
#if WITH_COUNTS
  clear_counts();
#endif
  return(sc);
}


/* -------------------------------- repl -------------------------------- */

#if WITH_MAIN
/* this code extracted from xen.c in sndlib
 */
#include <readline/readline.h>
#include <curses.h> 

static s7_scheme *s7;

typedef struct {int loc, size, len; const char *text; const char **matches;} completions;

static bool find_match(const char *symbol_name, void *udata)
{
  completions *data = (completions *)udata;
  if (strncmp(data->text, symbol_name, data->len) == 0)
    {
      if (data->matches == NULL)
	{
	  data->matches = (const char **)calloc(8, sizeof(char *));
	  data->size = 8;
	  data->loc = 0;
	}
      else
	{
	  if (data->loc >= data->size)
	    {
	      int i;
	      data->size *= 2;
	      data->matches = (const char **)realloc(data->matches, data->size * sizeof(char *));
	      for (i = data->loc; i < data->size; i++) data->matches[i] = NULL;
	    }
	}
      data->matches[data->loc] = symbol_name;
      data->loc++;
    }
  return(false);
}

static int complete_loc = 0;
static completions *complete_data = NULL;
static char *copy_match(const char *text, int state)
{
  if (complete_loc < complete_data->loc)
    {
      char *result;
      int len;
      len = strlen(complete_data->matches[complete_loc]);
      result = calloc(len + 1, sizeof(char));
      memcpy((void *)result, (void *)complete_data->matches[complete_loc], len);
      complete_loc++;
      return(result);
    }
  return(NULL);
}

static char **completion(const char *text, int start, int end)
{
  completions *data; 
  char **matches = NULL;
  /* start and end are indices into the original line buffer, we just want text here */

  if (!text) return(NULL);

  data = (completions *)calloc(1, sizeof(completions));
  data->len = strlen(text);
  data->text = text;
		
  s7_for_each_symbol_name(s7, find_match, (void *)data);
  
  /* now to make readline happy, we apparently have to give it copies of everything! */
  if (data->matches)
    {
      complete_data = data;
      complete_loc = 0;
      matches = rl_completion_matches(text, copy_match);
      free(data->matches);
    }

  free(data);
  complete_data = NULL;
  return(matches);
}


int main(int argc, char **argv)
{
  s7 = s7_init();  

  rl_readline_name = "s7";
  rl_attempted_completion_function = completion;
  rl_initialize(); /* get the current COLS value */
  if (COLS > 80)
    {
      char *str;
      str = (char *)calloc(128, sizeof(char));
      snprintf(str, 128, "(with-environment *stacktrace* (set! code-cols %d) (set! total-cols %d) (set! notes-start-col %d))",
	       COLS - 45, COLS, COLS - 45);
      s7_eval_c_string(s7, str);
      free(str);
    }

  while (true)
    {
      char *line_read = NULL, *temp;

      line_read = readline("s7> ");
      if (line_read)
	{
	  char *str;
	  str = line_read;
	  while ((str) && (isspace(str[0]))) str++;
	  if (*str)
	    {
	      int len;
	      s7_pointer result;
	      len = strlen(str);
	      add_history(str);
	      result = s7_eval_c_string(s7, str);
	      s7_write(s7, result, s7_current_output_port(s7));   /* use write, not display so that strings are in double quotes */
	      s7_newline(s7, s7_current_output_port(s7));
	    }
	  free(line_read);
	}
    }
}

/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g3 -lreadline -lncurses -ldl -lm
 */
#endif


/* -------------------------------------------------------------------------------- */

/*
 * timing    12.x 13.0 13.1 13.2 13.3 13.4 13.5 13.6 13.7 14.0
 * bench    42736 8752 8051 7725 6515 5194 4364 3989 3997
 * lint           9328 8140 7887 7736 7300 7180 7051 7078
 * index    44300 3291 3005 2742 2078 1643 1435 1363 1365
 * s7test    1721 1358 1297 1244  977  961  957  960  943
 * t455|6     265   89   55   31   14   14    9 9155 8998
 * lat        229   63   52   47   42   40   34   31   29
 * t502        90   43   39   36   29   23   20   14   14
 * calls           275  207  175  115   89   71   53   53
 */

/* use new generic_ff in methods opt case 
 * we need integer_length everywhere! These fixups are ignored by the optimized cases.
 * currently I think the unsafe closure* ops are hardly ever called (~0 for thunk/s/sx, a few all_x and goto*
 * add empty? (or nil? or generic null? or zero-length? typeq? (null? c-pointer) -- C null?
 * other often-used libraries: glib/gio/gobject/gmodule ncurses? GL/GLU? pcre? tecla? readline? asound? sndlib-for-s7?
 *    SOMEDAY: libgdbm tests and setopt support, libdl tests and autoload in Snd
 *    there are about 2000 entities in SDL
 *    posix lib -> enhance in scheme for the gdb fix?
 * TODO: (env env) in clm should be an error
 * possible autoload additions: sndlib? xm? libX* fftw? gmp/mpfr/mpc? 
 * gdb-s7 might check for 0xnnnn "asdf" to avoid strings
 * checkpoint?
 * cload: settable C variables (via symbol_access as here?)
 * doc/test the lib*.scm files.
 * truncated format? or object->string?
 * the default object print_readable function should give an error, not mimic write
 * direct access to FILE* in s7 port (for libc)? (port-file) 
 * do we need a finalization or gc-time function for c-pointers?
 *   what about a type-name field for c-pointers (better debugging output)
 *   (make-c-pointer val "char**" free) s7_make_c_pointer_with_free?
 * could we use glob or equivalent in the glistener filename completer?
 * #[...] for int/float vectors?  or (float-vector ...), or perhaps #nf() #1f() and same for #ni? #float()? #int()?
 *   (float-vector '(a b c) '(d e f)) is not ambiguous -- this would be '(2 3) dims (or an error)
 *   better: (float-vector (float-vector ...) (float-vector ...))?
 * 2-stage load in cload for gslbug (fc19)?
 * TODO: change docs for sound-data/vct, change to vector wherever possible, remove more from scheme sndlib2xen/vct (synonyms) [frame.scm?]
 *   also same replacement process for frame, mixer? 
 */
