tonalisa/lib/sndlib/s7.c

/* 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, bil@ccrma.stanford.edu
 *
 * Mike Scholz provided the FreeBSD support (complex trig funcs, etc)
 * Rick Taube, Andrew Burnson, Donny Ward, and Greg Santucci provided the MS Visual C++ support
 *
 * Documentation is in s7.h and s7.html.
 * s7test.scm is a regression test.
 * glistener.c is a gtk-based listener.
 * repl.scm is a vt100-based listener.
 * cload.scm and lib*.scm tie in various C libraries.
 * lint.scm checks Scheme code for infelicities.
 * r7rs.scm implements some of r7rs (small).
 * write.scm currrently has pretty-print.
 * mockery.scm has the mock-data definitions.
 * stuff.scm has some stuff.
 *
 * s7.c is organized as follows:
 *
 *    structs and type flags
 *    constants
 *    GC
 *    stacks
 *    symbols and keywords
 *    environments
 *    continuations
 *    numbers
 *    characters
 *    strings
 *    ports
 *    format
 *    lists
 *    vectors
 *    hash-tables
 *    c-objects
 *    functions
 *    equal?
 *    generic length, copy, reverse, fill!, append
 *    error handlers
 *    sundry leftovers
 *    multiple-values, quasiquote
 *    eval
 *    multiprecision arithmetic
 *    *s7* environment
 *    initialization
 *    repl
 *
 * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible (FFI), 
 *   H_* are documentation strings, Q_* are procedure signatures,
 *   *_1 are auxilliary functions, big_* refer to gmp, 
 *   scheme "?" corresponds to C "is_", scheme "->" to C "_to_".
 *
 * ---------------- 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. In OSX or Linux, if you're not using C++,
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 1
 *
 *   In C++ I use:
 *
 *   #define HAVE_COMPLEX_NUMBERS 1
 *   #define HAVE_COMPLEX_TRIG 0
 *
 *   In windows, both are 0.
 *
 *   Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so
 *   HAVE_COMPLEX_NUMBERS means we can find
 *      cimag creal cabs csqrt carg conj
 *   and HAVE_COMPLEX_TRIG means we have
 *      cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh
 *
 * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their
 *   argument -- this will be very confusing for the s7 user because, for example, (sqrt -2)
 *   will return something bogus (it will not signal an error).
 *
 * so the incoming (non-s7-specific) compile-time switches are
 *     HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P
 * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead
 *   the default is to assume that we're running on a 64-bit machine.
 *
 * To get multiprecision arithmetic, set WITH_GMP to 1.
 *   You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later)
 *   In highly numerical contexts, the gmp version of s7 is about 50(!) times slower than the non-gmp version.
 *
 * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__
 *
 * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included.
 * 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
 *
 * -O3 is sometimes slower, sometimes faster
 * -march=native -fomit-frame-pointer -m64 -funroll-loops gains about .1%
 * -ffast-math makes a mess of NaNs, and does not appear to be faster
 * for timing tests, I use: -O2 -DINITIAL_HEAP_SIZE=1024000 -march=native -fomit-frame-pointer -funroll-loops
 */


/* ---------------- 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 about 2.5 Mbytes of memory. There are (many) cases where a bigger heap is faster.
 * The heap size must be a multiple of 32.  Each object takes about 50 bytes.
 *
 * repl runs in    4Mb (18v) (64bit) if heap is 8192
 *                11Mb (25v)         if 128k heap
 *  snd (no gui)  15Mb (151v)
 *  snd (motif)   12Mb (285v)
 *  snd (gtk)     32Mb (515v!)
 */
#endif

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

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


/* ---------------- 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 50 times slower than using C doubles and long long ints.
   */
#endif

#if WITH_GMP
  #define DEFAULT_BIGNUM_PRECISION 128
#endif

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

#ifndef WITH_EXTRA_EXPONENT_MARKERS
  #define WITH_EXTRA_EXPONENT_MARKERS 0
  /* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */
#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_IMMUTABLE_UNQUOTE
  #define WITH_IMMUTABLE_UNQUOTE 0
  /* this removes the name "unquote" */
#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_HISTORY
  #define WITH_HISTORY 0
  /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */
#endif

#ifndef DEFAULT_HISTORY_SIZE
  #define DEFAULT_HISTORY_SIZE 8
  /* this is the default length of the eval history buffer */
#endif

#ifndef WITH_PROFILE
  #define WITH_PROFILE 0
  /* this includes profiling data collection accessible from scheme via the hash-table (*s7* 'profile-info) */
#endif


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

/* in case mus-config.h forgets these */
#ifdef _MSC_VER
  #ifndef HAVE_COMPLEX_NUMBERS
    #define HAVE_COMPLEX_NUMBERS 0
  #endif
  #ifndef HAVE_COMPLEX_TRIG
    #define HAVE_COMPLEX_TRIG 0
  #endif
#else
  #ifndef HAVE_COMPLEX_NUMBERS
    #define HAVE_COMPLEX_NUMBERS 1
  #endif
  #if __cplusplus
    #ifndef HAVE_COMPLEX_TRIG
      #define HAVE_COMPLEX_TRIG 0
    #endif
  #else
    #ifndef HAVE_COMPLEX_TRIG
      #define HAVE_COMPLEX_TRIG 1
    #endif
  #endif
#endif

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

#ifndef DEBUGGING
  #define DEBUGGING 0
#endif
#ifndef OP_NAMES
  #define OP_NAMES 0
#endif

#define WITH_ADD_PF 0

#ifndef _MSC_VER
  #include <unistd.h>
  #include <sys/param.h>
  #include <strings.h>
  #include <errno.h>
  #include <locale.h>
#else
  /* in Snd these are in mus-config.h */
  #ifndef MUS_CONFIG_H_LOADED
    #define snprintf _snprintf 
    #if _MSC_VER > 1200
      #define _CRT_SECURE_NO_DEPRECATE 1
      #define _CRT_NONSTDC_NO_DEPRECATE 1
      #define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1
    #endif
  #endif
  #include <io.h>
  #pragma warning(disable: 4244)
#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>
    #ifndef __SUNPRO_C
      #if defined(__sun) && defined(__SVR4)
        #undef _Complex_I
        #define _Complex_I 1.0fi
      #endif
    #endif
  #endif
#ifndef CMPLX
  /* c11 addition? */
  #define CMPLX(r, i) ((r) + ((i) * _Complex_I))
#endif
#endif

#include <setjmp.h>

#include "s7.h"

enum {NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, ERROR_QUIT_JUMP};
enum {NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, S7_CALL_SET_JUMP, EVAL_SET_JUMP};


#ifndef M_PI
  #define M_PI 3.1415926535897932384626433832795029L
#endif

#ifndef INFINITY
  #define INFINITY (-log(0.0))
  /* 1.0 / 0.0 is also used, there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF */
#endif

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

#define BOLD_TEXT "\033[1m"
#define UNBOLD_TEXT "\033[22m"

#define WRITE_REAL_PRECISION 16
static int float_format_precision = WRITE_REAL_PRECISION;

#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)

#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)
  #define ptr_int unsigned int
  #define INT_FORMAT "%u"
  #ifndef WITH_OPTIMIZATION
    #define WITH_OPTIMIZATION 0
    /* 32-bit optimized case gets inexplicable NaNs in float-vector ops.
     *   only the rf cases are faulty, so it is possible to set this flag to 1, then make s7_rf_set_function a no-op,
     *   and comment out the 2 syntax_rp cases. 
     * In standard scheme code, this flag does not matter much, but it makes CLM run about 3 times as fast.
     */
  #endif
#else
  #define opcode_t unsigned long long int
  #define ptr_int unsigned long long int
  #define INT_FORMAT "%llu"
  #define PRINT_NAME_PADDING 16
  #define PRINT_NAME_SIZE (40 - PRINT_NAME_PADDING - 2)
  #ifndef WITH_OPTIMIZATION
    #define WITH_OPTIMIZATION 1
  #endif
#endif


/* types */
#define T_FREE                 0
#define T_PAIR                 1
#define T_NIL                  2
#define T_UNIQUE               3
#define T_UNSPECIFIED          4
#define T_BOOLEAN              5
#define T_CHARACTER            6
#define T_SYMBOL               7
#define T_SYNTAX               8

#define T_INTEGER              9
#define T_RATIO               10
#define T_REAL                11
#define T_COMPLEX             12

#define T_BIG_INTEGER         13 /* these four used only if WITH_GMP -- order matters */
#define T_BIG_RATIO           14
#define T_BIG_REAL            15
#define T_BIG_COMPLEX         16  

#define T_STRING              17
#define T_C_OBJECT            18
#define T_VECTOR              19
#define T_INT_VECTOR          20
#define T_FLOAT_VECTOR        21

#define T_CATCH               22
#define T_DYNAMIC_WIND        23
#define T_HASH_TABLE          24
#define T_LET                 25
#define T_ITERATOR            26
#define T_STACK               27
#define T_COUNTER             28
#define T_SLOT                29
#define T_C_POINTER           30
#define T_OUTPUT_PORT         31
#define T_INPUT_PORT          32
#define T_BAFFLE              33
#define T_RANDOM_STATE        34

#define T_GOTO                35
#define T_CONTINUATION        36
#define T_CLOSURE             37
#define T_CLOSURE_STAR        38
#define T_C_MACRO             39
#define T_MACRO               40
#define T_MACRO_STAR          41
#define T_BACRO               42
#define T_BACRO_STAR          43
#define T_C_FUNCTION_STAR     44
#define T_C_FUNCTION          45
#define T_C_ANY_ARGS_FUNCTION 46
#define T_C_OPT_ARGS_FUNCTION 47
#define T_C_RST_ARGS_FUNCTION 48

#define NUM_TYPES        49

/* T_STACK, T_SLOT, T_BAFFLE, T_DYNAMIC_WIND, and T_COUNTER are internal
 * I tried T_CASE_SELECTOR that turned a case statement into an array, but it was slower!
 */

typedef enum {TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT, TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE,
	      TOKEN_BACK_QUOTE, TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST,
	      TOKEN_VECTOR, TOKEN_BYTE_VECTOR} token_t;

typedef enum {FILE_PORT, STRING_PORT, FUNCTION_PORT} port_type_t;

typedef struct {
  bool needs_free;
  FILE *file;
  char *filename;
  int filename_length, gc_loc;
  void *next;
  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);                 /* internal get-next-name reader */
  s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt);                /* internal get-next-sharp-constant reader */
  s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case, bool copied);  /* function to read a string up to \n */
  void (*display)(s7_scheme *sc, const char *s, s7_pointer pt);
} port_t;


typedef struct {
  const char *name;
  int name_length;
  unsigned int id;
  char *doc;
  s7_pointer generic_ff;
  s7_pointer signature;
  s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr);
  s7_pointer *arg_defaults, *arg_names;
  s7_pointer call_args;
  s7_rp_t rp;
  s7_ip_t ip;
  s7_pp_t pp, gp;
} c_proc_t;


typedef struct {               /* call/cc */
  unsigned int stack_size, op_stack_loc, op_stack_size;
  int local_key;   /* for with-baffle */
} continuation_t;


typedef struct vdims_t {
  unsigned int ndims;
  bool elements_allocated, dimensions_allocated; /* these are allocated as bytes, not ints, so the struct size is 32 */
  s7_int *dims, *offsets;
  s7_pointer original;
} vdims_t;


typedef struct {
  int type;
  unsigned int outer_type;
  const char *name;
  s7_pointer scheme_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 args);
  s7_pointer (*reverse)(s7_scheme *sc, s7_pointer obj);
  s7_pointer (*fill)(s7_scheme *sc, s7_pointer args);
  char *(*print_readably)(s7_scheme *sc, void *value);
  s7_pointer (*direct_ref)(s7_scheme *sc, s7_pointer obj, s7_int index);
  s7_pointer (*direct_set)(s7_scheme *sc, s7_pointer obj, s7_int index, s7_pointer val);
  s7_ip_t ip, set_ip;
  s7_rp_t rp, set_rp;
} c_object_t;


typedef struct hash_entry_t {
  s7_pointer key, value;
  struct hash_entry_t *next;
  unsigned int raw_hash;
} hash_entry_t;

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


/* 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;
      /* using free_lists here was not faster, and avoiding the extra init/clear too tricky.  These make up
       *   no more than ca. 5% of the gmp computation -- it is totally dominated by stuff like __gmpz_mul,
       *   so I can't see much point in optimizing the background noise.  In a very numerical context,
       *   gmp slows us down by a factor of 50.
       */
#endif
    } number;

    struct {
      port_t *port;
      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;
      bool is_closed;
      port_type_t ptype;
    } prt;

    struct{
      unsigned char c, up_c;
      int length;
      bool alpha_c, digit_c, space_c, upper_c, lower_c;
      char c_name[12];
    } chr;

    void *c_pointer;

    int baffle_key;

    struct {
      s7_int length;
      union {
	s7_pointer *objects;
	s7_int *ints;
	s7_double *floats;
      } elements;
      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 *objects;
      vdims_t *dim_info;
      int top;
    } stk;

    struct {
      unsigned int mask, entries;
      hash_entry_t **elements;
      hash_check_t hash_func;
      hash_map_t *loc;
      s7_pointer dproc;
    } hasher;

    struct {
      s7_pointer obj, cur;
      union {
	s7_int loc;
	s7_pointer lcur;
      } lc;
      union {
	s7_int len;
	s7_pointer slow;
	hash_entry_t *hcur;
      } lw;
      s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator);
    } iter;

    struct {
      c_proc_t *c_proc;                /* C functions, macros */
      s7_function ff;
      s7_pointer setter;
      unsigned int required_args, optional_args, all_args;
      bool rest_arg;
    } fnc;

    struct {                           /* pairs */
      s7_pointer car, cdr, opt1, opt2, opt3;
    } cons;

    struct {
      s7_pointer sym_car, sym_cdr;
      unsigned long long int hash;
      const char *fstr;
      unsigned int op, line;
    } sym_cons;

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

    struct {
      unsigned int length;
      union {
	bool needs_free;
	int accessor;
      } str_ext;
      char *svalue;
      unsigned long long int hash;          /* string hash-index */
      s7_pointer initial_slot;
      union {
	char *documentation;
	s7_pointer ksym;
      } doc;
    } string;

    struct {                       /* symbols */
      s7_pointer name, global_slot, local_slot;
      long long int id;
      unsigned int op, tag;
    } sym;

    struct {                       /* syntax */
      s7_pointer symbol;
      int op;
      short min_args, max_args;
      s7_rp_t rp;
      s7_ip_t ip;
      s7_pp_t pp;
    } syn;

    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 rootlet is -1 */
      union {
	struct {
	  s7_pointer function;     /* __func__ (code) if this is a funclet */
	  unsigned int line, file; /* __func__ location if it is known */
	} efnc;
	struct {
	  s7_pointer dox1, dox2;   /* do loop variables */
	} dox;
	struct {                   /* (catch #t ...) opts */
	  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, slots; /* env = counter_let (curlet after map/for-each frame created) */
      unsigned long long int cap;   /* sc->capture_let_counter for frame reuse */
    } ctr;

    struct {
#if WITH_GMP
      gmp_randstate_t state;
#else
      unsigned long long int seed, carry;
#endif
    } rng;

    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 (openlet) */
      s7_pointer (*ref)(s7_scheme *sc, s7_pointer obj, s7_int pos);
    } c_obj;

    struct {
      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, gc_line, clear_line, alloc_line, uses;
  const char *current_alloc_func, *previous_alloc_func, *gc_func, *alloc_func;
#endif

} s7_cell;


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


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


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


typedef struct xf_t {
  s7_pointer *data, *cur, *end;
  s7_pointer e;
  int size;
  gc_obj *gc_list;
  struct xf_t *next;
} xf_t;


static s7_pointer *small_ints, *chars;
static s7_pointer real_zero, real_NaN, real_pi, real_one, arity_not_set, max_arity, real_infinity, real_minus_infinity, minus_one, minus_two;


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;                   /* curlet */
  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, max_stack_size;

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

#if WITH_HISTORY
  s7_pointer eval_history1, eval_history2, error_history;
  bool using_history1;
#endif
  /* "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).
   */

  gc_obj *permanent_objects;

  s7_pointer protected_objects, protected_accessors;       /* a vector of gc-protected objects */
  unsigned int *gpofl;
  unsigned int protected_objects_size, protected_accessors_size, protected_accessors_loc;
  int gpofl_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_object;             /* else */
  s7_pointer gc_nil;                  /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */

  s7_pointer symbol_table;            /* symbol table */
  s7_pointer rootlet, shadow_rootlet; /* rootlet */
  s7_int rootlet_entries;
  s7_pointer unlet;                   /* 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 owlet;                   /* owlet */
  s7_pointer error_type, error_data, error_code, error_line, error_file; /* owlet slots */
  s7_pointer standard_input, standard_output, standard_error;

  s7_pointer sharp_readers;           /* the binding pair for the global *#readers* list */
  s7_pointer load_hook;               /* *load-hook* hook object */
  s7_pointer unbound_variable_hook;   /* *unbound-variable-hook* hook object */
  s7_pointer missing_close_paren_hook;
  s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */
  s7_pointer direct_str;

  bool gc_off;                        /* gc_off: if true, the GC won't run */
  unsigned int gc_stats;
  unsigned int gensym_counter, cycle_counter, f_class, add_class, multiply_class, subtract_class, equal_class;
  int format_column;
  unsigned long long int capture_let_counter;
  bool symbol_table_is_locked, short_print;
  long long int let_number;
  double default_rationalize_error, morally_equal_float_epsilon, hash_table_float_epsilon;
  s7_int default_hash_table_length, initial_string_port_length, print_length, history_size, true_history_size;
  s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions;
  s7_pointer stacktrace_defaults;
  vdims_t *wrap_only;

  char *typnam;
  int typnam_len;
  char *help_arglist;
  int print_width;
  s7_pointer *singletons;

  #define INITIAL_TMP_STR_SIZE 16
  s7_pointer *tmp_strs;

  #define INITIAL_FILE_NAMES_SIZE 8
  s7_pointer *file_names;
  int file_names_size, file_names_top;

  #define INITIAL_STRBUF_SIZE 1024
  unsigned int strbuf_size;
  #define TMPBUF_SIZE 1024
  char *strbuf, *tmpbuf;

  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, temp5, temp6, temp7, temp8, temp9, temp10;
  s7_pointer temp_cell, temp_cell_1, temp_cell_2;
  s7_pointer d1, d2, d3, d4;
  s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2;
  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;
  int setjmp_loc;

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

  int no_values, current_line, s7_call_line, safety;
  const char *current_file, *s7_call_file, *s7_call_name;

  shared_info *circle_info;
  format_data **fdats;
  int num_fdats;
  s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, plist_1, plist_2, plist_3;

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

  unsigned int syms_tag;
  int ht_iter_tag, baffle_ctr, bignum_precision;
  s7_pointer default_rng;

  /* these symbols are primarily for the generic function search */
  s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, arity_symbol,
             ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol,
             autoload_symbol, autoloader_symbol,
             byte_vector_symbol, 
             c_pointer_symbol, caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol,
             caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol,
             call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol, 
             call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol,
             catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol,
             cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol,
             ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol,
             char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol, 
             close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol, 
             curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol, 
             denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, dynamic_wind_symbol,
             eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exp_symbol, expt_symbol,
             features_symbol, fill_symbol, float_vector_ref_symbol, float_vector_set_symbol, float_vector_symbol, floor_symbol, 
             flush_output_port_symbol, for_each_symbol, format_symbol, funclet_symbol,
             gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol,
             hash_table_entries_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_star_symbol, hash_table_symbol,
             help_symbol, 
             imag_part_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol,
             integer_decode_float_symbol, integer_to_char_symbol, is_aritable_symbol, is_boolean_symbol, is_byte_vector_symbol,
             is_c_object_symbol, is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol,
             is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol,
             is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol,
             is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_gensym_symbol, is_hash_table_symbol,
             is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol,
             is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_morally_equal_symbol, is_nan_symbol, is_negative_symbol,
             is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol, 
             is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol,
             is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_symbol_symbol,
             is_vector_symbol, is_zero_symbol, iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol,
             is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol, 
             keyword_to_symbol_symbol, 
             lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol,
             let_set_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, load_path_symbol,
             load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol,
             magnitude_symbol, make_byte_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, make_int_vector_symbol,
             make_iterator_symbol, make_keyword_symbol, make_list_symbol, make_shared_vector_symbol, make_string_symbol,
             make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol,
             multiply_symbol, 
             newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol, 
             object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_string_symbol, open_output_file_symbol, 
             openlet_symbol, outlet_symbol, owlet_symbol, 
             pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol,
             procedure_documentation_symbol, procedure_signature_symbol, procedure_source_symbol, provide_symbol,
             quotient_symbol, 
             random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol,
             read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol,
             require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol,
             set_car_symbol, set_cdr_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol,
             stacktrace_symbol, string_append_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol,
             string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol,
             string_set_symbol, string_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol,
             sublet_symbol, substring_symbol, subtract_symbol, symbol_access_symbol, symbol_symbol, symbol_to_dynamic_value_symbol,
             symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol, 
             tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol, truncate_symbol,
             unlet_symbol, 
             values_symbol, varlet_symbol, vector_append_symbol, vector_dimensions_symbol, vector_fill_symbol, vector_ref_symbol,
             vector_set_symbol, vector_symbol, 
             with_input_from_file_symbol, with_input_from_string_symbol, with_output_to_file_symbol, with_output_to_string_symbol,
             write_byte_symbol, write_char_symbol, write_string_symbol, write_symbol;
         
#if (!WITH_PURE_S7)
  s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, 
             let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_ci_eq_symbol,
             string_ci_geq_symbol, string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, string_length_symbol, 
             string_copy_symbol, list_to_string_symbol, list_to_vector_symbol, vector_length_symbol, make_polar_symbol, 
             make_rectangular_symbol;
#endif

  /* s7 env symbols */
  s7_pointer stack_top_symbol, symbol_table_is_locked_symbol, heap_size_symbol, gc_freed_symbol, gc_protected_objects_symbol,
             free_heap_size_symbol, file_names_symbol, symbol_table_symbol, cpu_time_symbol, c_objects_symbol, float_format_precision_symbol,
             stack_size_symbol, rootlet_size_symbol, c_types_symbol, safety_symbol, max_stack_size_symbol, gc_stats_symbol,
             strings_symbol, vectors_symbol, input_ports_symbol, output_ports_symbol, continuations_symbol, hash_tables_symbol, gensyms_symbol,
             catches_symbol, exits_symbol, stack_symbol, default_rationalize_error_symbol, max_string_length_symbol, default_random_state_symbol,
             max_list_length_symbol, max_vector_length_symbol, max_vector_dimensions_symbol, default_hash_table_length_symbol, profile_info_symbol,
             hash_table_float_epsilon_symbol, morally_equal_float_epsilon_symbol, initial_string_port_length_symbol, memory_usage_symbol,
             undefined_identifier_warnings_symbol, print_length_symbol, bignum_precision_symbol, stacktrace_defaults_symbol, history_size_symbol;

  /* syntax symbols et al */
  s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, unquote_symbol, macroexpand_symbol, 
             define_expansion_symbol, baffle_symbol, with_let_symbol, documentation_symbol, signature_symbol, if_symbol, 
             when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, 
             define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol, 
             define_macro_star_symbol, define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, letrec_star_symbol, 
             let_star_symbol, key_rest_symbol, key_allow_other_keys_symbol, key_readable_symbol, value_symbol, type_symbol, 
             baffled_symbol, __func___symbol, set_symbol, body_symbol, class_name_symbol, feed_to_symbol, format_error_symbol, 
             wrong_number_of_args_symbol, read_error_symbol, string_read_error_symbol, syntax_error_symbol, division_by_zero_symbol, 
             no_catch_symbol, io_error_symbol, invalid_escape_function_symbol, wrong_type_arg_symbol, out_of_range_symbol;

  /* optimizer symbols */
  s7_pointer and_p2_symbol, and_p_symbol, and_unchecked_symbol, begin_unchecked_symbol, case_simple_symbol, case_simpler_1_symbol,
             case_simpler_ss_symbol, case_simpler_symbol, case_simplest_ss_symbol, case_simplest_symbol, case_unchecked_symbol,
             cond_all_x_2_symbol, cond_all_x_symbol, cond_s_symbol, cond_simple_symbol, cond_unchecked_symbol, decrement_1_symbol,
             define_constant_unchecked_symbol, define_funchecked_symbol, define_star_unchecked_symbol, define_unchecked_symbol,
             do_unchecked_symbol, dotimes_p_symbol, dox_symbol, if_a_p_p_symbol, if_a_p_symbol, if_and2_p_p_symbol, if_and2_p_symbol,
             if_andp_p_p_symbol, if_andp_p_symbol, if_cc_p_p_symbol, if_cc_p_symbol, if_cs_p_p_symbol, if_cs_p_symbol, if_csc_p_p_symbol,
             if_csc_p_symbol, if_csq_p_p_symbol, if_csq_p_symbol, if_css_p_p_symbol, if_css_p_symbol, if_is_pair_p_p_symbol,
             if_is_pair_p_symbol, if_is_symbol_p_p_symbol, if_is_symbol_p_symbol, if_not_s_p_p_symbol, if_not_s_p_symbol,
             if_opssq_p_p_symbol, if_opssq_p_symbol, if_orp_p_p_symbol, if_orp_p_symbol, if_p_feed_symbol, if_p_p_p_symbol,
             if_p_p_symbol, if_s_opcq_p_p_symbol, if_s_opcq_p_symbol, if_s_p_p_symbol, if_s_p_symbol, if_unchecked_symbol,
             if_z_p_p_symbol, if_z_p_symbol, increment_1_symbol, increment_sa_symbol, increment_saa_symbol, increment_ss_symbol,
             increment_sss_symbol, increment_sz_symbol, lambda_star_unchecked_symbol, lambda_unchecked_symbol, let_all_c_symbol,
             let_all_opsq_symbol, let_all_s_symbol, let_all_x_symbol, let_c_symbol, let_no_vars_symbol, let_one_symbol,
             let_opcq_symbol, let_opsq_p_symbol, let_opsq_symbol, let_opssq_symbol, let_s_symbol, let_star2_symbol,
             let_star_all_x_symbol, let_star_unchecked_symbol, let_unchecked_symbol, let_z_symbol, letrec_star_unchecked_symbol,
             letrec_unchecked_symbol, named_let_no_vars_symbol, named_let_star_symbol, named_let_symbol, or_p2_symbol, or_p_symbol,
             or_unchecked_symbol, quote_unchecked_symbol, safe_do_symbol, safe_dotimes_symbol, set_cons_symbol, set_let_all_x_symbol,
             set_let_s_symbol, set_normal_symbol, set_pair_a_symbol, set_pair_c_p_symbol, set_pair_c_symbol, set_pair_p_symbol,
             set_pair_symbol, set_pair_z_symbol, set_pair_za_symbol, set_pws_symbol, set_symbol_a_symbol, set_symbol_c_symbol,
             set_symbol_opcq_symbol, set_symbol_opsq_symbol, set_symbol_opssq_symbol, set_symbol_opsssq_symbol, set_symbol_p_symbol,
             set_symbol_q_symbol, set_symbol_s_symbol, set_symbol_z_symbol, set_unchecked_symbol, simple_do_a_symbol,
             simple_do_e_symbol, simple_do_p_symbol, simple_do_symbol, unless_s_symbol, unless_unchecked_symbol, when_s_symbol,
             when_unchecked_symbol, with_baffle_unchecked_symbol, with_let_s_symbol, with_let_unchecked_symbol, 
             dox_slot_symbol;

#if WITH_GMP
  s7_pointer bignum_symbol, is_bignum_symbol;
  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

#if WITH_SYSTEM_EXTRAS
  s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, getenv_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol;
#endif

  /* setter and quasiquote functions */
  s7_pointer vector_set_function, string_set_function, list_set_function, hash_table_set_function, let_set_function, object_set_function,
             qq_list_function, qq_apply_values_function, qq_append_function, multivector_function, 
             apply_function, vector_function;

  s7_pointer wrong_type_arg_info, out_of_range_info, simple_wrong_type_arg_info, simple_out_of_range_info;
  s7_pointer too_many_arguments_string, not_enough_arguments_string, division_by_zero_error_string;
  s7_pointer *safe_lists, *syn_docs; /* prebuilt evaluator arg lists, syntax doc strings */

  s7_pointer autoload_table, libraries, profile_info;
  const char ***autoload_names;
  int *autoload_names_sizes;
  bool **autoloaded_already;
  int autoload_names_loc, autoload_names_top;
  port_t *port_heap;

  int format_depth;
  int slash_str_size;
  char *slash_str;

  xf_t *cur_rf;
  xf_t *rf_free_list, *rf_stack;
  bool undefined_identifier_warnings;
};

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


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_any_closure_p[NUM_TYPES];
static bool t_has_closure_let[NUM_TYPES];
static bool t_sequence_p[NUM_TYPES];
static bool t_vector_p[NUM_TYPES];
static bool t_applicable_p[NUM_TYPES];

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_any_closure_p[i] = false;
      t_has_closure_let[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_LET] = true;
  t_structure_p[T_ITERATOR] = 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_LET] = 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_ITERATOR] = true;
  t_applicable_p[T_LET] = true;
  t_applicable_p[T_C_OBJECT] = true;
  t_applicable_p[T_C_MACRO] = true;
  t_applicable_p[T_MACRO] = true;
  t_applicable_p[T_BACRO] = true;
  t_applicable_p[T_MACRO_STAR] = true;
  t_applicable_p[T_BACRO_STAR] = true;
  t_applicable_p[T_SYNTAX] = true;
  t_applicable_p[T_C_FUNCTION] = true;
  t_applicable_p[T_C_FUNCTION_STAR] = true;
  t_applicable_p[T_C_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_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_any_macro_p[T_MACRO_STAR] = true;
  t_any_macro_p[T_BACRO_STAR] = true;

  t_any_closure_p[T_CLOSURE] = true;
  t_any_closure_p[T_CLOSURE_STAR] = true;

  t_has_closure_let[T_MACRO] = true;
  t_has_closure_let[T_BACRO] = true;
  t_has_closure_let[T_MACRO_STAR] = true;
  t_has_closure_let[T_BACRO_STAR] = true;
  t_has_closure_let[T_CLOSURE] = true;
  t_has_closure_let[T_CLOSURE_STAR] = true;

  t_simple_p[T_NIL] = true;
  t_simple_p[T_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_FUNCTION_STAR] = 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;
  /* not completely sure about the next ones */
  t_simple_p[T_LET] = true;
  t_simple_p[T_INPUT_PORT] = true;
  t_simple_p[T_OUTPUT_PORT] = true;
}

#if WITH_HISTORY
#define current_code(Sc) car(Sc->cur_code)
#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, Code);} while (0)
#define mark_current_code(Sc) do {int i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < sc->history_size; i++, p = cdr(p)) S7_MARK(car(p));} while (0)
#else
#define current_code(Sc) Sc->cur_code
#define set_current_code(Sc, Code) Sc->cur_code = Code
#define mark_current_code(Sc) S7_MARK(Sc->cur_code)
#endif

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

static s7_scheme *hidden_sc = NULL;

#if DEBUGGING
  static const char *check_name(int typ);
  static s7_pointer check_seti(s7_scheme *sc, s7_pointer x, const char *func, int line);
  static s7_pointer check_ref(s7_pointer p, int expected_type, const char *func, int line, const char *func1, const char *func2);
  static s7_pointer check_ref2(s7_pointer p, int expected_type, int other_type, const char *func, int line, const char *func1, const char *func2);
  static s7_pointer check_ref3(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref4(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref5(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref6(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref7(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref8(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref9(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref10(s7_pointer p, const char *func, int line);
  static s7_pointer check_ref11(s7_pointer p, const char *func, int line);
  static s7_pointer check_nref(s7_pointer p, const char *func, int line);
  static void print_gc_info(s7_pointer obj, int line);

  static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line);
  static s7_pointer set_opt1_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line);
  static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line);
  static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line);
  static s7_pointer opt3_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line);
  static void set_opt3_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line);

  static unsigned long long int s_hash_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_hash_1(s7_scheme *sc, s7_pointer p, unsigned long long int x, const char *func, int line);
  static const char *s_name_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_name_1(s7_scheme *sc, s7_pointer p, const char *str, const char *func, int line);
  static unsigned int s_line_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_line_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line);
  static unsigned int s_len_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_len_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line);
  static unsigned int s_op_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_op_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line);
  static unsigned int s_syn_op_1(s7_scheme *sc, s7_pointer p, const char *func, int line);
  static void set_s_syn_op_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line);

  #define unchecked_type(p)           ((p)->tf.type_field)
  #define type(p) ({unsigned char _t_; _t_ = (p)->tf.type_field; if (((_t_ == T_FREE)) || (_t_ >= NUM_TYPES)) print_gc_info(p, __LINE__); _t_;})

  #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;					\
      p->uses++; p->clear_line = 0;					\
      if ((((f) & 0xff) == T_FREE) || (((f) & 0xff) >= NUM_TYPES))	\
        fprintf(stderr, "%d: set free %p type to %x\n", __LINE__, p, f); \
      else								\
	{								\
	  if (((typeflag(p) & T_IMMUTABLE) != 0) && ((typeflag(p) != (f))))						\
	    fprintf(stderr, "%d: set immutable %p type %x to %x\n", __LINE__, p, unchecked_type(p), f); \
	  if (((typeflag(p) & T_LINE_NUMBER) != 0) && (((typeflag(p)) & 0xff) == T_PAIR) && (((f) & T_LINE_NUMBER) == 0)) \
            fprintf(stderr, "%d unsets line_number\n", __LINE__); \
	}								\
      typeflag(p) = f;							\
    } while (0)

  #define clear_type(p) do {p->clear_line = __LINE__; typeflag(p) = T_FREE;} while (0)

  /* these check most s7cell field references (and many type bits) for consistency */
  #define _TI(P)   check_ref(P, T_INTEGER,           __func__, __LINE__, NULL, NULL)
  #define _TR(P)   check_ref(P, T_REAL,              __func__, __LINE__, NULL, NULL)
  #define _TF(P)   check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL)
  #define _TZ(P)   check_ref(P, T_COMPLEX,           __func__, __LINE__, NULL, NULL)
  #define _TBgi(P) check_ref(P, T_BIG_INTEGER,       __func__, __LINE__, "sweep", NULL)
  #define _TBgr(P) check_ref(P, T_BIG_REAL,          __func__, __LINE__, "sweep", NULL)
  #define _TBgf(P) check_ref(P, T_BIG_RATIO,         __func__, __LINE__, "sweep", NULL)
  #define _TBgz(P) check_ref(P, T_BIG_COMPLEX,       __func__, __LINE__, "sweep", NULL)

  #define _TChr(P) check_ref(P, T_CHARACTER,         __func__, __LINE__, NULL, NULL)
  #define _TCtr(P) check_ref(P, T_COUNTER,           __func__, __LINE__, NULL, NULL)
  #define _TPtr(P) check_ref(P, T_C_POINTER,         __func__, __LINE__, NULL, NULL)
  #define _TBfl(P) check_ref(P, T_BAFFLE,            __func__, __LINE__, NULL, NULL)
  #define _TGot(P) check_ref(P, T_GOTO,              __func__, __LINE__, NULL, NULL)
  #define _TStk(P) check_ref(P, T_STACK,             __func__, __LINE__, NULL, NULL)
  #define _TPair(P) check_ref(P, T_PAIR,             __func__, __LINE__, NULL, NULL)
  #define _TCat(P) check_ref(P, T_CATCH,             __func__, __LINE__, NULL, NULL)
  #define _TDyn(P) check_ref(P, T_DYNAMIC_WIND,      __func__, __LINE__, NULL, NULL)
  #define _TSlt(P) check_ref(P, T_SLOT,              __func__, __LINE__, NULL, NULL)
  #define _TSlp(P) check_ref2(P, T_SLOT, T_PAIR,     __func__, __LINE__, NULL, NULL)
  #define _TSln(P) check_ref2(P, T_SLOT, T_NIL,      __func__, __LINE__, NULL, NULL)
  #define _TSld(P) check_ref2(P, T_SLOT, T_UNIQUE,   __func__, __LINE__, NULL, NULL)
  #define _TSyn(P) check_ref(P, T_SYNTAX,            __func__, __LINE__, NULL, NULL)
  #define _TMac(P) check_ref(P, T_C_MACRO,           __func__, __LINE__, NULL, NULL)
  #define _TLet(P) check_ref(P, T_LET,               __func__, __LINE__, NULL, NULL)
  #define _TLid(P) check_ref2(P, T_LET, T_NIL,       __func__, __LINE__, NULL, NULL)
  #define _TRan(P) check_ref(P, T_RANDOM_STATE,      __func__, __LINE__, NULL, NULL)
  #define _TLst(P) check_ref2(P, T_PAIR, T_NIL,      __func__, __LINE__, "gc", NULL)
  #define _TStr(P) check_ref(P, T_STRING,            __func__, __LINE__, "sweep", NULL)
  #define _TObj(P) check_ref(P, T_C_OBJECT,          __func__, __LINE__, "free_object", NULL)
  #define _THsh(P) check_ref(P, T_HASH_TABLE,        __func__, __LINE__, "sweep", "free_hash_table")
  #define _TItr(P) check_ref(P, T_ITERATOR,          __func__, __LINE__, "sweep", NULL)
  #define _TCon(P) check_ref(P, T_CONTINUATION,      __func__, __LINE__, "sweep", NULL)
  #define _TFvc(P) check_ref(P, T_FLOAT_VECTOR,      __func__, __LINE__, "sweep", NULL)
  #define _TIvc(P) check_ref(P, T_INT_VECTOR,        __func__, __LINE__, "sweep", NULL)
  #define _TSym(P) check_ref(P, T_SYMBOL,            __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table")

  #define _TPrt(P) check_ref3(P,                     __func__, __LINE__) /* input|output_port, or free */
  #define _TVec(P) check_ref4(P,                     __func__, __LINE__) /* any vector or free */
  #define _TClo(P) check_ref5(P,                     __func__, __LINE__) /* has closure let */
  #define _TFnc(P) check_ref6(P,                     __func__, __LINE__) /* any c_function|c_macro */
  #define _TNum(P) check_ref7(P,                     __func__, __LINE__) /* any number (not bignums I think) */
  #define _TSeq(P) check_ref8(P,                     __func__, __LINE__) /* any sequence or structure */
  #define _TMet(P) check_ref9(P,                     __func__, __LINE__) /* anything that might contain a method */
  #define _TArg(P) check_ref10(P,                    __func__, __LINE__) /* closure arg (list, symbol) */
  #define _TApp(P) check_ref11(P,                    __func__, __LINE__) /* setter (any_procedure or #f) */
  #define _NFre(P) check_nref(P,                     __func__, __LINE__) /* not free */
  #define _TSet(P) check_seti(sc, P,                 __func__, __LINE__) /* set of immutable value */

#else
  #define unchecked_type(p)           ((p)->tf.type_field)
  #define type(p)                     ((p)->tf.type_field)
  #define set_type(p, f)              typeflag(p) = f
  #define clear_type(p)               typeflag(p) = T_FREE
  #define _TSet(P)                    P
  #define _TI(P)                      P
  #define _TR(P)                      P
  #define _TF(P)                      P
  #define _TZ(P)                      P
  #define _TBgi(P)                    P
  #define _TBgr(P)                    P
  #define _TBgf(P)                    P
  #define _TBgz(P)                    P
  #define _TStr(P)                    P
  #define _TSyn(P)                    P
  #define _TChr(P)                    P
  #define _TObj(P)                    P
  #define _TCtr(P)                    P
  #define _THsh(P)                    P
  #define _TItr(P)                    P
  #define _TPtr(P)                    P
  #define _TBfl(P)                    P
  #define _TGot(P)                    P
  #define _TCon(P)                    P
  #define _TStk(P)                    P
  #define _TPrt(P)                    P
  #define _TIvc(P)                    P
  #define _TFvc(P)                    P
  #define _TVec(P)                    P
  #define _TPair(P)                   P
  #define _TRan(P)                    P
  #define _TDyn(P)                    P
  #define _TCat(P)                    P
  #define _TClo(P)                    P
  #define _TFnc(P)                    P
  #define _TSlt(P)                    P
  #define _TSln(P)                    P
  #define _TSld(P)                    P
  #define _TSlp(P)                    P
  #define _TSym(P)                    P
  #define _TLet(P)                    P
  #define _TLid(P)                    P
  #define _TLst(P)                    P
  #define _TNum(P)                    P
  #define _TSeq(P)                    P
  #define _TMet(P)                    P
  #define _TMac(P)                    P
  #define _TArg(P)                    P
  #define _TApp(P)                    P
  #define _NFre(P)                    P
#endif

#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_t_integer(p)               (type(p) == T_INTEGER)
#define is_t_ratio(p)                 (type(p) == T_RATIO)
#define is_t_real(p)                  (type(p) == T_REAL)
#define is_t_complex(p)               (type(p) == T_COMPLEX)
#define is_t_big_integer(p)           (type(p) == T_BIG_INTEGER)
#define is_t_big_ratio(p)             (type(p) == T_BIG_RATIO)
#define is_t_big_real(p)              (type(p) == T_BIG_REAL)
#define is_t_big_complex(p)           (type(p) == T_BIG_COMPLEX)

#define is_free(p)                    (type(p) == T_FREE)
#define is_free_and_clear(p)          (typeflag(p) == T_FREE)
#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_any_closure(P)             t_any_closure_p[type(P)]
#define is_procedure_or_macro(P)      ((t_any_macro_p[type(P)]) || ((typeflag(P) & T_PROCEDURE) != 0))
#define is_any_procedure(P)           (type(P) >= T_CLOSURE)
#define has_closure_let(P)            t_has_closure_let[type(P)]

#define is_simple_sequence(P)         (t_sequence_p[type(P)])
#define is_sequence(P)                ((t_sequence_p[type(P)]) || (has_methods(P)))
#define is_applicable(P)              (t_applicable_p[type(P)])
/* this misses #() which actually is not applicable to anything, probably "" also, and inapplicable c-objects like random-state */


/* the layout of these bits does matter in several cases -- in particular, don't use the second byte for anything
 *   that might shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR.
 */
#define TYPE_BITS                     8

#define T_KEYWORD                     (1 << (TYPE_BITS + 0))
#define is_keyword(p)                 ((typesflag(_NFre(p)) & T_KEYWORD) != 0)
/* this bit distinguishes a symbol from a symbol that is also a keyword
 * this should be ok in the second byte because keywords are constants in s7 (never syntax)
 */

#define T_SYNTACTIC                   (1 << (TYPE_BITS + 1))
#define is_syntactic(p)               ((typesflag(_NFre(p)) & T_SYNTACTIC) != 0)
#define is_syntactic_symbol(p)        ((typesflag(_NFre(p)) & (T_SYNTACTIC | 0xff)) == (T_SYMBOL | T_SYNTACTIC))
#define SYNTACTIC_TYPE                (unsigned short)(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 second byte */
#define set_syntactic_pair(p)         typeflag(p) = (SYNTACTIC_PAIR | (typeflag(p) & 0xffff0000))

#define T_PROCEDURE                   (1 << (TYPE_BITS + 2))
#define is_procedure(p)               ((typesflag(_NFre(p)) & T_PROCEDURE) != 0)
/* closure, c_function, applicable object, goto or continuation, should be in second byte */

#define T_OPTIMIZED                   (1 << (TYPE_BITS + 3))
#define set_optimized(p)              typesflag(_TPair(p)) |= T_OPTIMIZED
#define clear_optimized(p)            typesflag(_TPair(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 and the same speed as xor */
/* optimizer flag for an expression that has optimization info, it should be in the second byte
 */

#define T_SAFE_CLOSURE                (1 << (TYPE_BITS + 4))
#define is_safe_closure(p)            ((typesflag(_NFre(p)) & T_SAFE_CLOSURE) != 0)
#define set_safe_closure(p)           typesflag(p) |= T_SAFE_CLOSURE
#define clear_safe_closure(p)         typesflag(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 second byte.
 *   It can be set on either the body (a pair) or the closure itself.
 */

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

#define T_EXPANSION                   (1 << (TYPE_BITS + 6))
#define is_expansion(p)               ((typesflag(_NFre(p)) & T_EXPANSION) != 0)
#define clear_expansion(p)            typesflag(_TSym(p)) &= (~T_EXPANSION)
/* 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)          ((typesflag(_NFre(p)) & T_MULTIPLE_VALUE) != 0)
#define set_multiple_value(p)         typesflag(_TPair(p)) |= T_MULTIPLE_VALUE
#define clear_multiple_value(p)       typesflag(_TPair(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                     T_MULTIPLE_VALUE
#define is_matched_pair(p)            ((typesflag(_TPair(p)) & T_MATCHED) != 0)
#define set_match_pair(p)             typesflag(_TPair(p)) |= T_MATCHED
#define clear_match_pair(p)           typesflag(_TPair(p)) &= (~T_MATCHED)
#define is_matched_symbol(p)          ((typesflag(_TSym(p)) & T_MATCHED) != 0)
#define set_match_symbol(p)           typesflag(_TSym(p)) |= T_MATCHED
#define clear_match_symbol(p)         typesflag(_TSym(p)) &= (~T_MATCHED)

#define T_GLOBAL                      (1 << (TYPE_BITS + 8))
#define is_global(p)                  ((typeflag(_TSym(p)) & T_GLOBAL) != 0)
#define set_global(p)                 typeflag(_TSym(p)) |= T_GLOBAL
#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)) || (is_syntactic(symbol)))
      fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, BOLD_TEXT, DISPLAY(symbol), UNBOLD_TEXT, DISPLAY_80(current_code(sc)));
    typeflag(symbol) = (typeflag(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
  }
  #define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
#else
#define set_local(p)                  typeflag(_TSym(p)) &= ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)
#endif
/* this marks something defined (bound) at the top-level, and never defined locally */

#define T_UNSAFE_DO                   T_GLOBAL
#define is_unsafe_do(p)               ((typeflag(_TPair(p)) & T_UNSAFE_DO) != 0)
#define set_unsafe_do(p)              typeflag(_TPair(p)) |= T_UNSAFE_DO
#define is_unsafe_sort(p)             is_unsafe_do(p)
#define set_unsafe_sort(p)            set_unsafe_do(p)
/* marks do-loops (and sort functions) that resist optimization */

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

#define T_LINE_NUMBER                 (1 << (TYPE_BITS + 10))
#define has_line_number(p)            ((typeflag(_TPair(p)) & T_LINE_NUMBER) != 0)
#define set_has_line_number(p)        typeflag(_TPair(p)) |= T_LINE_NUMBER
/* pair in question has line/file info added during read, or the environment has function placement info 
 *   this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it.
 */

#define T_LOADER_PORT                 T_LINE_NUMBER
#define is_loader_port(p)             ((typeflag(_TPrt(p)) & T_LOADER_PORT) != 0)
#define set_loader_port(p)            typeflag(_TPrt(p)) |= T_LOADER_PORT
#define clear_loader_port(p)          typeflag(_TPrt(p)) &= (~T_LOADER_PORT)
/* to block random load-time reads from screwing up the load process, this bit marks a port used by the loader */

#define T_HAS_ACCESSOR                T_LINE_NUMBER
#define symbol_has_accessor(p)        ((typeflag(_TSym(p)) & T_HAS_ACCESSOR) != 0)
#define symbol_set_has_accessor(p)    typeflag(_TSym(p)) |= T_HAS_ACCESSOR
#define slot_has_accessor(p)          ((typeflag(_TSlt(p)) & T_HAS_ACCESSOR) != 0)
#define slot_set_has_accessor(p)      typeflag(_TSlt(p)) |= T_HAS_ACCESSOR
/* marks a slot or symbol that has a setter */

#define T_WITH_LET_LET                T_LINE_NUMBER
#define is_with_let_let(p)            ((typeflag(_TLet(p)) & T_WITH_LET_LET) != 0)
#define set_with_let_let(p)           typeflag(_TLet(p)) |= T_WITH_LET_LET
/* marks a let that is the argument to with-let */

#define T_SIMPLE_DEFAULTS             T_LINE_NUMBER
#define has_simple_defaults(p)        ((typeflag(_TFnc(p)) & T_SIMPLE_DEFAULTS) != 0)
#define set_simple_defaults(p)        typeflag(_TFnc(p)) |= T_SIMPLE_DEFAULTS
#define clear_simple_defaults(p)      typeflag(_TFnc(p)) &= (~T_SIMPLE_DEFAULTS)
/* flag c_func_star arg defaults that need GC protection */

#define T_SHARED                      (1 << (TYPE_BITS + 11))
#define is_shared(p)                  ((typeflag(_TSeq(p)) & T_SHARED) != 0)
#define set_shared(p)                 typeflag(_TSeq(p)) |= T_SHARED
/* #define clear_shared(p)            typeflag(_TSeq(p)) &= (~T_SHARED) */
#define clear_collected_and_shared(p) typeflag(p) &= (~(T_COLLECTED | T_SHARED)) /* this can clear free cells = calloc */

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

#define T_SAFE_PROCEDURE              (1 << (TYPE_BITS + 13))
#define is_safe_procedure(p)          ((typeflag(_NFre(p)) & T_SAFE_PROCEDURE) != 0)
/* applicable objects that do not return or modify their arg list directly (no :rest arg in particular),
 *    and that can't call apply themselves either directly or via s7_call, and that don't mess with the stack.
 */

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

#define set_checked_slot(p)           typeflag(_TSlt(p)) |= T_CHECKED
#define is_checked_slot(p)            ((typeflag(_TSlt(p)) & T_CHECKED) != 0)
#define is_not_checked_slot(p)        ((typeflag(_TSlt(p)) & T_CHECKED) == 0)


#define T_UNSAFE                      (1 << (TYPE_BITS + 15))
#define set_unsafe(p)                 typeflag(_TPair(p)) |= T_UNSAFE
#define set_unsafely_optimized(p)     typeflag(_TPair(p)) |= (T_UNSAFE | T_OPTIMIZED)
#define is_unsafe(p)                  ((typeflag(_TPair(p)) & T_UNSAFE) != 0)
#define clear_unsafe(p)               typeflag(_TPair(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_CLEAN_SYMBOL                T_UNSAFE
#define is_clean_symbol(p)            ((typeflag(_TSym(p)) & T_CLEAN_SYMBOL) != 0)
#define set_clean_symbol(p)           typeflag(_TSym(p)) |= T_CLEAN_SYMBOL
/* set if we know the symbol name can be printed without quotes (slashification) */

#define T_IMMUTABLE                   (1 << (TYPE_BITS + 16))
#define is_immutable(p)               ((typeflag(_NFre(p)) & T_IMMUTABLE) != 0)
#define is_immutable_port(p)          ((typeflag(_TPrt(p)) & T_IMMUTABLE) != 0)
#define is_immutable_symbol(p)        ((typeflag(_TSym(p)) & T_IMMUTABLE) != 0)
#define is_immutable_integer(p)       ((typeflag(_TI(p)) & T_IMMUTABLE) != 0)
#define is_immutable_real(p)          ((typeflag(_TR(p)) & T_IMMUTABLE) != 0)
#define set_immutable(p)              typeflag(_TSym(p)) |= T_IMMUTABLE
/* immutable means the value can't be changed via set! or bind -- this is separate from the symbol access stuff
 * this bit can't be in the second byte -- with-let, for example, is immutable, but we use SYNTACTIC_TYPE to 
 * recognize syntax in do loop optimizations.
 */

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

#define T_ALLOW_OTHER_KEYS            T_SETTER
#define set_allow_other_keys(p)       typeflag(_TPair(p)) |= T_ALLOW_OTHER_KEYS
#define allows_other_keys(p)          ((typeflag(_TPair(p)) & T_ALLOW_OTHER_KEYS) != 0)
/* marks arglist that allows keyword args other than those in the parameter list; can't allow
 *   (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other".
 */

#define T_MUTABLE                     (1 << (TYPE_BITS + 18))
#define is_mutable(p)                 ((typeflag(_TNum(p)) & T_MUTABLE) != 0)
/* #define set_mutable(p)             typeflag(_TNum(p)) |= T_MUTABLE */
/* used for mutable numbers */

#define T_MARK_SEQ                    T_MUTABLE
#define is_mark_seq(p)                ((typeflag(_TItr(p)) & T_MARK_SEQ) != 0)
#define set_mark_seq(p)               typeflag(_TItr(p)) |= T_MARK_SEQ
/* used in iterators for GC mark of sequence */

#define T_BYTE_VECTOR                 T_MUTABLE
#define is_byte_vector(p)             ((typeflag(_TStr(p)) & T_BYTE_VECTOR) != 0)
#define set_byte_vector(p)            typeflag(_TStr(p)) |= T_BYTE_VECTOR
/* marks a string that the caller considers a byte_vector */

#define T_STEPPER                     T_MUTABLE
#define is_stepper(p)                 ((typeflag(_TSlt(p)) & T_STEPPER) != 0)
#define set_stepper(p)                typeflag(_TSlt(p)) |= T_STEPPER
bool s7_is_stepper(s7_pointer p)      {return(is_stepper(p));}
/* marks a slot that holds a do-loop's step variable (if int, can be numerator=current, denominator=end) */

#define T_SAFE_STEPPER                (1 << (TYPE_BITS + 19))
#define is_safe_stepper(p)            ((typeflag(_TSlp(p)) & T_SAFE_STEPPER) != 0)
#define set_safe_stepper(p)           typeflag(_TSlp(p)) |= T_SAFE_STEPPER
#define is_unsafe_stepper(p)          ((typeflag(_TSlp(p)) & (T_STEPPER | T_SAFE_STEPPER)) == T_STEPPER)
/* an experiment */

#define T_PRINT_NAME                  T_SAFE_STEPPER
#define has_print_name(p)             ((typeflag(_TNum(p)) & T_PRINT_NAME) != 0)
#define set_has_print_name(p)         typeflag(_TNum(p)) |= T_PRINT_NAME
/* marks numbers that have a saved version of their string representation */

#define T_POSSIBLY_SAFE               T_SAFE_STEPPER
#define is_possibly_safe(p)           ((typeflag(_TFnc(p)) & T_POSSIBLY_SAFE) != 0)
#define set_is_possibly_safe(p)       typeflag(_TFnc(p)) |= T_POSSIBLY_SAFE
/* marks c_functions that are not always unsafe -- this bit didn't work out as intended */

#define T_HAS_SET_FALLBACK            T_SAFE_STEPPER
#define T_HAS_REF_FALLBACK            T_MUTABLE
#define has_ref_fallback(p)           ((typeflag(_TLid(p)) & T_HAS_REF_FALLBACK) != 0)
#define has_set_fallback(p)           ((typeflag(_TLid(p)) & T_HAS_SET_FALLBACK) != 0)
#define set_has_ref_fallback(p)       typeflag(_TLet(p)) |= T_HAS_REF_FALLBACK
#define set_has_set_fallback(p)       typeflag(_TLet(p)) |= T_HAS_SET_FALLBACK
#define set_all_methods(p, e)         typeflag(_TLet(p)) |= (typeflag(e) & (T_HAS_METHODS | T_HAS_REF_FALLBACK | T_HAS_SET_FALLBACK))

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

#define T_GENSYM                      (1 << (TYPE_BITS + 21))
#define is_gensym(p)                  ((typeflag(_TSym(p)) & T_GENSYM) != 0)
/* symbol is from gensym (GC-able etc) */

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

#define T_LIST_IN_USE                 T_GENSYM
#define list_is_in_use(p)             ((typeflag(_TPair(p)) & T_LIST_IN_USE) != 0)
#define set_list_in_use(p)            typeflag(_TPair(p)) |= T_LIST_IN_USE
#define clear_list_in_use(p)          typeflag(_TPair(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_FUNCTION_ENV                T_GENSYM
#define is_function_env(p)            ((typeflag(_TLet(p)) & T_FUNCTION_ENV) != 0)
#define set_function_env(p)           typeflag(_TLet(p)) |= T_FUNCTION_ENV
/* this marks a funclet */

#define T_DOCUMENTED                  T_GENSYM
#define is_documented(p)              ((typeflag(_TStr(p)) & T_DOCUMENTED) != 0)
#define set_documented(p)             typeflag(_TStr(p)) |= T_DOCUMENTED
/* this marks a symbol that has documentation (bit is set on name cell) */

#define T_HAS_METHODS                 (1 << (TYPE_BITS + 22))
#define has_methods(p)                ((typeflag(_NFre(p)) & T_HAS_METHODS) != 0)
#define set_has_methods(p)            typeflag(_TMet(p)) |= T_HAS_METHODS
#define clear_has_methods(p)          typeflag(_TMet(p)) &= (~T_HAS_METHODS)
/* this marks an environment or closure that is "opened" up to generic functions etc
 * don't reuse this bit if possible
 */

#define T_GC_MARK                     0x80000000            /* (1 << (TYPE_BITS + 23)) but that makes gcc unhappy */
#define is_marked(p)                  ((typeflag(p) &  T_GC_MARK) != 0)
#define set_mark(p)                   typeflag(_NFre(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 */


static int not_heap = -1;
#define heap_location(p)              (p)->hloc
#define not_in_heap(p)                ((_NFre(p))->hloc < 0)
#define unheap(p)                     (p)->hloc = not_heap--

#define is_eof(p)                     (_NFre(p) == sc->eof_object)
#define is_true(Sc, p)                ((_NFre(p)) != Sc->F)
#define is_false(Sc, p)               ((_NFre(p)) == Sc->F)

#ifdef _MSC_VER
  #define MS_WINDOWS 1
  static s7_pointer make_boolean(s7_scheme *sc, bool val) {if (val) return(sc->T); return(sc->F);}
#else
  #define MS_WINDOWS 0
  #define make_boolean(sc, Val)       ((Val) ? sc->T : sc->F)
#endif

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


#if (!DEBUGGING)

#define opt1(p, r)                    ((p)->object.cons.opt1)
#define set_opt1(p, x, r)             (p)->object.cons.opt1 = x
#define opt2(p, r)                    ((p)->object.cons.opt2)
#define set_opt2(p, x, r)             (p)->object.cons.opt2 = (s7_pointer)(x)
#define opt3(p, r)                    ((p)->object.cons.opt3)
#define set_opt3(p, x, r)             do {(p)->object.cons.opt3 = x; typeflag(p) &= ~(T_OPTIMIZED | T_LINE_NUMBER);} while (0)

#define pair_line(p)                  (p)->object.sym_cons.line
#define pair_set_line(p, X)           (p)->object.sym_cons.line = X
#define pair_raw_hash(p)              (p)->object.sym_cons.hash
#define pair_set_raw_hash(p, X)       (p)->object.sym_cons.hash = X
#define pair_raw_len(p)               (p)->object.sym_cons.op
#define pair_set_raw_len(p, X)        (p)->object.sym_cons.op = X
#define pair_raw_name(p)              (p)->object.sym_cons.fstr
#define pair_set_raw_name(p, X)       (p)->object.sym_cons.fstr = X

/* opt1 == raw_hash, opt2 == raw_name, opt3 == line+op|len, but hash/name/len only apply to the symbol table so there's no collision */

#else

/* these 3 fields (or 8 counting sym_cons) hold most of the varigated optimizer info, so they are used in many conflicting ways.
 * the bits and funcs here try to track each such use, and report any cross-talk or collisions.
 * all of this machinery vanishes if debugging is turned off.
 */
#define S_NAME                        (1 << 26)
#define S_HASH                        (1 << 27)
#define S_OP                          (1 << 28)
#define S_LINE                        (1 << 29)
#define S_LEN                         (1 << 30)
#define S_SYNOP                       0x80000000 /* (1 << 31) */

#define E_SET                         (1 << 0)
#define E_FAST                        (1 << 6)   /* fast list in member/assoc circular list check */
#define E_CFUNC                       (1 << 7)   /* c-function */
#define E_CLAUSE                      (1 << 8)   /* case clause */
#define E_BACK                        (1 << 9)   /* back pointer for doubly-linked list */
#define E_LAMBDA                      (1 << 10)  /* lambda(*) */
#define E_SYM                         (1 << 11)  /* symbol */
#define E_PAIR                        (1 << 12)  /* pair */
#define E_CON                         (1 << 13)  /* constant from eval's point of view */
#define E_GOTO                        (1 << 14)  /* call-with-exit exit func */
#define E_VECTOR                      (1 << 15)  /* vector (any kind) */
#define E_ANY                         (1 << 16)  /* anything -- deliberate unchecked case */
#define E_SLOT                        (1 << 17)  /* slot */
#define E_MASK                        (E_FAST | E_CFUNC | E_CLAUSE | E_BACK | E_LAMBDA | E_SYM | E_PAIR | E_CON | E_GOTO | E_VECTOR | E_ANY | E_SLOT | S_HASH)

#define opt1_is_set(p)                (((p)->debugger_bits & E_SET) != 0)
#define set_opt1_is_set(p)            (p)->debugger_bits |= E_SET
#define opt1_role_matches(p, Role)    (((p)->debugger_bits & E_MASK) == Role)
#define set_opt1_role(p, Role)        (p)->debugger_bits = (Role | ((p)->debugger_bits & ~E_MASK))
#define opt1(p, Role)                 opt1_1(hidden_sc, _TPair(p), Role, __func__, __LINE__)
#define set_opt1(p, x, Role)          set_opt1_1(hidden_sc, _TPair(p), x, Role, __func__, __LINE__)

#define F_SET                         (1 << 1)   /* bit 18 is free */
#define F_KEY                         (1 << 19)  /* case key */
#define F_SLOW                        (1 << 20)  /* slow list in member/assoc circular list check */
#define F_SYM                         (1 << 21)  /* symbol */
#define F_PAIR                        (1 << 22)  /* pair */
#define F_CON                         (1 << 23)  /* constant as above */
#define F_CALL                        (1 << 24)  /* c-func */
#define F_LAMBDA                      (1 << 25)  /* lambda form */
#define F_MASK                        (F_KEY | F_SLOW | F_SYM | F_PAIR | F_CON | F_CALL | F_LAMBDA | S_NAME)

#define opt2_is_set(p)                (((p)->debugger_bits & F_SET) != 0)
#define set_opt2_is_set(p)            (p)->debugger_bits |= F_SET
#define opt2_role_matches(p, Role)    (((p)->debugger_bits & F_MASK) == Role)
#define set_opt2_role(p, Role)        (p)->debugger_bits = (Role | ((p)->debugger_bits & ~F_MASK))
#define opt2(p, Role)                 opt2_1(hidden_sc, _TPair(p), Role, __func__, __LINE__)
#define set_opt2(p, x, Role)          set_opt2_1(hidden_sc, _TPair(p), (s7_pointer)x, Role, __func__, __LINE__)

/* opt3 collides with optimization and line number stuff (T_LINE_NUMBER, T_OPTIMIZED) */
#define G_SET                         (1 << 2)
#define G_ARGLEN                      (1 << 3)  /* arglist length */
#define G_SYM                         (1 << 4)  /* expression symbol access */
#define G_AND                         (1 << 5)  /* and second clause */
#define G_MASK                        (G_ARGLEN | G_SYM | G_AND | S_OP | S_LINE | S_LEN | S_SYNOP)

#define opt3_is_set(p)                (((p)->debugger_bits & G_SET) != 0)
#define set_opt3_is_set(p)            (p)->debugger_bits |= G_SET
#define opt3_role_matches(p, Role)    (((p)->debugger_bits & G_MASK) == Role)
#define set_opt3_role(p, Role)        (p)->debugger_bits = (Role | ((p)->debugger_bits & ~G_MASK))
#define opt3(p, Role)                 opt3_1(hidden_sc, _TPair(p), Role, __func__, __LINE__)
#define set_opt3(p, x, Role)          set_opt3_1(hidden_sc, _TPair(p), x, Role, __func__, __LINE__)

/* opt1 == s_hash, opt2 == s_fstr, opt3 == s_op|len|line and op==len so they are contradictory (but only op/line|opt3 actually collide)
 * line|len|op: unsigned int set G_SET and S_* if S_LEN -> not op and vice versa
 * another collider: pair_syntax_op|optimize_op below.  Both need bits: S_SYNOP?
 */

#define pair_line(p)                  s_line_1(sc, _TPair(p), __func__, __LINE__)
#define pair_set_line(p, X)           set_s_line_1(sc, _TPair(p), X, __func__, __LINE__)
#define pair_raw_hash(p)              s_hash_1(sc, _TPair(p), __func__, __LINE__)
#define pair_set_raw_hash(p, X)       set_s_hash_1(sc, _TPair(p), X, __func__, __LINE__)
#define pair_raw_len(p)               s_len_1(sc, _TPair(p), __func__, __LINE__)
#define pair_set_raw_len(p, X)        set_s_len_1(sc, _TPair(p), X, __func__, __LINE__)
#define pair_raw_name(p)              s_name_1(sc, _TPair(p), __func__, __LINE__)
#define pair_set_raw_name(p, X)       set_s_name_1(sc, _TPair(p), X, __func__, __LINE__)
#endif

#define opt_fast(P)                   _TLst(opt1(P,              E_FAST))
#define set_opt_fast(P, X)            set_opt1(P, _TPair(X),      E_FAST)
#define opt_back(P)                   _TPair(opt1(P,              E_BACK))
#define set_opt_back(P)               set_opt1(cdr(P), _TPair(P), E_BACK)
#define has_opt_back(P)               (cdr(opt_back(P)) == P )
#define opt_cfunc(P)                  opt1(P,                    E_CFUNC)
#define set_opt_cfunc(P, X)           set_opt1(P, X,             E_CFUNC)
#define opt_lambda_unchecked(P)       opt1(P,                    E_LAMBDA)
#define opt_lambda(P)                 _TClo(opt1(P,              E_LAMBDA))
#define set_opt_lambda(P, X)          set_opt1(P, X,             E_LAMBDA)
#define opt_goto(P)                   _TGot(opt1(P,              E_GOTO))
#define set_opt_goto(P, X)            set_opt1(P, _TGot(X),      E_GOTO)
#define opt_vector(P)                 _TVec(opt1(P,              E_VECTOR))
#define set_opt_vector(P, X)          set_opt1(P, _TVec(X),      E_VECTOR)
#define opt_clause(P)                 opt1(P,                    E_CLAUSE)
#define set_opt_clause(P, X)          set_opt1(P, X,             E_CLAUSE)
#define opt_sym1(P)                   _TSym(opt1(P,              E_SYM))
#define set_opt_sym1(P, X)            set_opt1(P, _TSym(X),      E_SYM)
#define opt_pair1(P)                  _TLst(opt1(P,              E_PAIR))
#define set_opt_pair1(P, X)           set_opt1(P, _TLst(X),      E_PAIR)
#define opt_con1(P)                   opt1(P,                    E_CON)
#define set_opt_con1(P, X)            set_opt1(P, X,             E_CON)
#define opt_any1(P)                   opt1(P,                    E_ANY)
#define opt_slot1(P)                  _TSlt(opt1(P,              E_SLOT))
#define set_opt_slot1(P, X)           set_opt1(P, _TSlt(X),      E_SLOT)

#define c_callee(f)                   ((s7_function)opt2(f,      F_CALL))
#define c_call(f)                     ((s7_function)opt2(f,      F_CALL))
#define set_c_call(f, X)              set_opt2(f, (s7_pointer)X, F_CALL)
#define opt_key(P)                    opt2(P,                    F_KEY)
#define set_opt_key(P, X)             set_opt2(P, X,             F_KEY)
#define opt_slow(P)                   _TLst(opt2(P,              F_SLOW))
#define set_opt_slow(P, X)            set_opt2(P, _TPair(X),      F_SLOW)
#define opt_sym2(P)                   _TSym(opt2(P,              F_SYM))
#define set_opt_sym2(P, X)            set_opt2(P, _TSym(X),      F_SYM)
#define opt_pair2(P)                  _TLst(opt2(P,              F_PAIR))
#define set_opt_pair2(P, X)           set_opt2(P, _TLst(X),      F_PAIR)
#define opt_con2(P)                   opt2(P,                    F_CON)
#define set_opt_con2(P, X)            set_opt2(P, X,             F_CON)
#define opt_lambda2(P)                _TPair(opt2(P,              F_LAMBDA))
#define set_opt_lambda2(P, X)         set_opt2(P, _TPair(X),      F_LAMBDA)

#define arglist_length(P)             _TI(opt3(cdr(P),           G_ARGLEN))
#define set_arglist_length(P, X)      set_opt3(cdr(P), _TI(X),   G_ARGLEN)
#define opt_sym3(P)                   _TSym(opt3(P,              G_SYM))
#define set_opt_sym3(P, X)            set_opt3(P, _TSym(X),      G_SYM)
#define opt_and_2_test(P)             _TPair(opt3(P,              G_AND))
#define set_opt_and_2_test(P, X)      set_opt3(P, _TPair(X),      G_AND)


#define car(p)                        (_TLst(p))->object.cons.car
#define set_car(p, Val)               (_TLst(p))->object.cons.car = _NFre(Val)
#define cdr(p)                        (_TLst(p))->object.cons.cdr
#define set_cdr(p, Val)               (_TLst(p))->object.cons.cdr = _NFre(Val)
#define unchecked_car(p)              (_NFre(p))->object.cons.car
#define unchecked_cdr(p)              (_NFre(p))->object.cons.cdr

#define caar(p)                       car(car(p))
#define cadr(p)                       car(cdr(p))
#define set_cadr(p, Val)              (_TLst(p))->object.cons.cdr->object.cons.car = _NFre(Val)
#define cdar(p)                       cdr(car(p))
#define set_cdar(p, Val)              (_TLst(p))->object.cons.car->object.cons.cdr = _NFre(Val)
#define cddr(p)                       cdr(cdr(p))

#define caaar(p)                      car(car(car(p)))
#define cadar(p)                      car(cdr(car(p)))
#define cdadr(p)                      cdr(car(cdr(p)))
#define caddr(p)                      car(cdr(cdr(p)))
#define set_caddr(p, Val)             (_TLst(p))->object.cons.cdr->object.cons.cdr->object.cons.car = _NFre(Val)
#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))))

#if WITH_GCC
  /* slightly tricky because cons can be called recursively */
  #define cons(Sc, A, B)   ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;})
#else
  #define cons(Sc, A, B)              s7_cons(Sc, A, B)
#endif

#define list_1(Sc, A)                 cons(Sc, A, Sc->nil)
#define list_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 is_string(p)                  (type(p) == T_STRING)
#define string_value(p)               (_TStr(p))->object.string.svalue
#define string_length(p)              (_TStr(p))->object.string.length
#define string_hash(p)                (_TStr(p))->object.string.hash
#define string_needs_free(p)          (_TStr(p))->object.string.str_ext.needs_free
#define string_temp_true_length(p)    (_TStr(p))->object.string.str_ext.accessor

#define tmpbuf_malloc(P, Len)         do {if ((Len) < TMPBUF_SIZE) P = sc->tmpbuf; else P = (char *)malloc((Len) * sizeof(char));} while (0)
#define tmpbuf_calloc(P, Len)         do {if ((Len) < TMPBUF_SIZE) {P = sc->tmpbuf; memset((void *)P, 0, Len);} else P = (char *)calloc(Len, sizeof(char));} while (0)
#define tmpbuf_free(P, Len)           do {if ((Len) >= TMPBUF_SIZE) free(P);} while (0)

#define character(p)                  (_TChr(p))->object.chr.c
#define upper_character(p)            (_TChr(p))->object.chr.up_c
#define is_char_alphabetic(p)         (_TChr(p))->object.chr.alpha_c
#define is_char_numeric(p)            (_TChr(p))->object.chr.digit_c
#define is_char_whitespace(p)         (_TChr(p))->object.chr.space_c
#define is_char_uppercase(p)          (_TChr(p))->object.chr.upper_c
#define is_char_lowercase(p)          (_TChr(p))->object.chr.lower_c
#define character_name(p)             (_TChr(p))->object.chr.c_name
#define character_name_length(p)      (_TChr(p))->object.chr.length

#if (!DEBUGGING)
  #define optimize_op(p)              (_TPair(p))->object.sym_cons.op
  #define set_optimize_op(P, Op)      optimize_op(P) = Op
#else
  #define optimize_op(p)              s_op_1(hidden_sc, _TPair(p), __func__, __LINE__)
  #define set_optimize_op(p, Op)      set_s_op_1(hidden_sc, _TPair(p), Op, __func__, __LINE__)
#endif

#define optimize_op_match(P, Q)       ((is_optimized(P)) && ((optimize_op(P) & 0xfffe) == Q))
#define op_no_hop(P)                  (optimize_op(P) & 0xfffe)
#define clear_hop(P)                  set_optimize_op(P, op_no_hop(P))
#define clear_optimize_op(P)          set_optimize_op(P, 0)
#define set_safe_optimize_op(P, Q)    do {set_optimized(P); set_optimize_op(P, Q);} while (0)
#define set_unsafe_optimize_op(P, Q)  do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0)

#define is_symbol(p)                  (type(p) == T_SYMBOL)
#define symbol_name_cell(p)           _TStr((_TSym(p))->object.sym.name)
#define symbol_set_name_cell(p, S)    (_TSym(p))->object.sym.name = _TStr(S)
#define symbol_name(p)                string_value(symbol_name_cell(p))
#define symbol_name_length(p)         string_length(symbol_name_cell(p))
#define symbol_hmap(p)                s7_int_abs(heap_location(p))
#define symbol_global_accessor_index(p) (symbol_name_cell(p))->object.string.str_ext.accessor
#define symbol_id(p)                  (_TSym(p))->object.sym.id
#define symbol_set_id(p, X)           (_TSym(p))->object.sym.id = X
/* 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 symbol_syntax_op(p)           (_TSym(p))->object.sym.op

#define global_slot(p)                (_TSym(p))->object.sym.global_slot
#define set_global_slot(p, Val)       (_TSym(p))->object.sym.global_slot = _TSld(Val)
#define initial_slot(p)               (symbol_name_cell(p))->object.string.initial_slot
#define set_initial_slot(p, Val)      (symbol_name_cell(p))->object.string.initial_slot = _TSld(Val)
#define local_slot(p)                 (_TSym(p))->object.sym.local_slot
#define set_local_slot(p, Val)        (_TSym(p))->object.sym.local_slot = _TSln(Val)
#define keyword_symbol(p)             (symbol_name_cell(p))->object.string.doc.ksym
#define keyword_set_symbol(p, Val)    (symbol_name_cell(p))->object.string.doc.ksym = _TSym(Val)
#define symbol_help(p)                (symbol_name_cell(p))->object.string.doc.documentation
#define symbol_tag(p)                 (_TSym(p))->object.sym.tag
#define symbol_set_tag(p, Val)        (_TSym(p))->object.sym.tag = Val
#define symbol_has_help(p)            (is_documented(symbol_name_cell(p)))
#define symbol_set_has_help(p)        set_documented(symbol_name_cell(p))

#define symbol_set_local(Symbol, Id, Slot) do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0)
/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */

#define is_slot(p)                    (type(p) == T_SLOT)
#define slot_value(p)                 _NFre((_TSlt(p))->object.slt.val)
#define slot_set_value(p, Val)        (_TSlt(p))->object.slt.val = _NFre(Val)
#define slot_symbol(p)                _TSym((_TSlt(p))->object.slt.sym)
#define slot_set_symbol(p, Sym)       (_TSlt(p))->object.slt.sym = _TSym(Sym)
#define next_slot(p)                  (_TSlt(p))->object.slt.nxt
#define set_next_slot(p, Val)         (_TSlt(p))->object.slt.nxt = _TSln(Val)
#define slot_pending_value(p)         (_TSlt(p))->object.slt.pending_value
#define slot_set_pending_value(p, Val) (_TSlt(p))->object.slt.pending_value = _NFre(Val)
#define slot_expression(p)            (_TSlt(p))->object.slt.expr
#define slot_set_expression(p, Val)   (_TSlt(p))->object.slt.expr = _NFre(Val)
#define slot_accessor(p)              slot_expression(p)
#define slot_set_accessor(p, Val)     slot_expression(p) = _TApp(Val)

#define is_syntax(p)                  (type(p) == T_SYNTAX)
#define syntax_symbol(p)              _TSym((_TSyn(p))->object.syn.symbol)
#define syntax_set_symbol(p, Sym)     (_TSyn(p))->object.syn.symbol = _TSym(Sym)
#define syntax_opcode(p)              (_TSyn(p))->object.syn.op
#define syntax_min_args(p)            (_TSyn(p))->object.syn.min_args
#define syntax_max_args(p)            (_TSyn(p))->object.syn.max_args
#define syntax_documentation(p)       sc->syn_docs[syntax_opcode(p)]
#define syntax_rp(p)                  (_TSyn(p))->object.syn.rp
#define syntax_ip(p)                  (_TSyn(p))->object.syn.ip
#define syntax_pp(p)                  (_TSyn(p))->object.syn.pp

#if (!DEBUGGING)
  #define pair_syntax_op(p)           (p)->object.sym_cons.op
  #define pair_set_syntax_op(p, X)    (p)->object.sym_cons.op = X
#else
  #define pair_syntax_op(p)           s_syn_op_1(hidden_sc, _TPair(p), __func__, __LINE__)
  #define pair_set_syntax_op(p, Op)   set_s_syn_op_1(hidden_sc, _TPair(p), Op, __func__, __LINE__)
#endif
#define pair_syntax_symbol(P)         car(opt_back(P))
static void pair_set_syntax_symbol(s7_pointer p, s7_pointer op) {set_car(opt_back(p), op); pair_set_syntax_op(opt_back(p), symbol_syntax_op(op));}

#define ROOTLET_SIZE 512
#define let_id(p)                     (_TLid(p))->object.envr.id
#define is_let(p)                     (type(p) == T_LET)
#define let_slots(p)                  (_TLet(p))->object.envr.slots
#define let_set_slots(p, Slot)        (_TLet(p))->object.envr.slots = _TSln(Slot)
#define outlet(p)                     (_TLet(p))->object.envr.nxt
#define set_outlet(p, ol)             (_TLet(p))->object.envr.nxt = _TLid(ol)
#define funclet_function(p)           _TSym((_TLet(p))->object.envr.edat.efnc.function)
#define funclet_set_function(p, F)    (_TLet(p))->object.envr.edat.efnc.function = _TSym(F)
#define let_line(p)                   (_TLet(p))->object.envr.edat.efnc.line
#define let_set_line(p, L)            (_TLet(p))->object.envr.edat.efnc.line = L
#define let_file(p)                   (_TLet(p))->object.envr.edat.efnc.file
#define let_set_file(p, F)            (_TLet(p))->object.envr.edat.efnc.file = F
#define dox_slot1(p)                  _TSlt((_TLet(p))->object.envr.edat.dox.dox1)
#define dox_set_slot1(p, S)           (_TLet(p))->object.envr.edat.dox.dox1 = _TSlt(S)
#define dox_slot2(p)                  _TSlt((_TLet(p))->object.envr.edat.dox.dox2)
#define dox_set_slot2(p, S)           (_TLet(p))->object.envr.edat.dox.dox2 = _TSlt(S)

#define unique_name(p)                (p)->object.unq.name
#define unique_name_length(p)         (p)->object.unq.len
#define is_unspecified(p)             (type(p) == T_UNSPECIFIED)
#define unique_cdr(p)                 (p)->object.unq.unused_nxt

#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)              (_TVec(p))->object.vector.vget
#define vector_setter(p)              (_TVec(p))->object.vector.vset
#define int_vector_element(p, i)      ((_TIvc(p))->object.vector.elements.ints[i])
#define int_vector_elements(p)        (_TIvc(p))->object.vector.elements.ints
#define float_vector_element(p, i)    ((_TFvc(p))->object.vector.elements.floats[i])
#define float_vector_elements(p)      (_TFvc(p))->object.vector.elements.floats
#define is_normal_vector(p)           (type(p) == T_VECTOR)
#define is_int_vector(p)              (type(p) == T_INT_VECTOR)
#define is_float_vector(p)            (type(p) == T_FLOAT_VECTOR)

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

#define is_hash_table(p)              (type(p) == T_HASH_TABLE)
#define hash_table_mask(p)            (_THsh(p))->object.hasher.mask
#define hash_table_element(p, i)      ((_THsh(p))->object.hasher.elements[i])
#define hash_table_elements(p)        (_THsh(p))->object.hasher.elements
#define hash_table_entries(p)         (_THsh(p))->object.hasher.entries
#define hash_table_checker(p)         (_THsh(p))->object.hasher.hash_func
#define hash_table_mapper(p)          (_THsh(p))->object.hasher.loc
#define hash_table_checker_locked(p)  (hash_table_mapper(p) != default_hash_map)
#define hash_table_procedures(p)      _TLst((_THsh(p))->object.hasher.dproc)
#define hash_table_set_procedures(p, Lst) (_THsh(p))->object.hasher.dproc = _TLst(Lst)
#define hash_table_procedures_checker(p) car(hash_table_procedures(p))
#define hash_table_procedures_mapper(p) cdr(hash_table_procedures(p))

#define is_iterator(p)                (type(p) == T_ITERATOR)
#define iterator_sequence(p)          (_TItr(p))->object.iter.obj
#define iterator_position(p)          (_TItr(p))->object.iter.lc.loc
#define iterator_length(p)            (_TItr(p))->object.iter.lw.len
#define iterator_slow(p)              _TLst((_TItr(p))->object.iter.lw.slow)
#define iterator_set_slow(p, Val)     (_TItr(p))->object.iter.lw.slow = _TLst(Val)
#define iterator_hash_current(p)      (_TItr(p))->object.iter.lw.hcur
#define iterator_current(p)           (_TItr(p))->object.iter.cur
#define iterator_current_slot(p)      _TSln((_TItr(p))->object.iter.lc.lcur)
#define iterator_set_current_slot(p, Val) (_TItr(p))->object.iter.lc.lcur = _TSln(Val)
#define iterator_let_cons(p)          (_TItr(p))->object.iter.cur
#define iterator_next(p)              (_TItr(p))->object.iter.next
#define iterator_is_at_end(p)         (iterator_next(p) == iterator_finished)

#define ITERATOR_END eof_object
#define ITERATOR_END_NAME "#<eof>"

#define is_input_port(p)              (type(p) == T_INPUT_PORT)
#define is_output_port(p)             (type(p) == T_OUTPUT_PORT)
#define port_port(p)                  (_TPrt(p))->object.prt.port
#define port_type(p)                  (_TPrt(p))->object.prt.ptype
#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)           (_TPrt(p))->object.prt.line_number
#define port_file_number(p)           (_TPrt(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)             (_TPrt(p))->object.prt.is_closed
#define port_data(p)                  (_TPrt(p))->object.prt.data
#define port_data_size(p)             (_TPrt(p))->object.prt.size
#define port_position(p)              (_TPrt(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_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 port_read_sharp(p)            port_port(p)->read_sharp
#define port_gc_loc(p)                port_port(p)->gc_loc

#define is_c_function(f)              (type(f) >= T_C_FUNCTION)
#define is_c_function_star(f)         (type(f) == T_C_FUNCTION_STAR)
#define is_any_c_function(f)          (type(f) >= T_C_FUNCTION_STAR)
#define c_function_data(f)            (_TFnc(f))->object.fnc.c_proc
#define c_function_call(f)            (_TFnc(f))->object.fnc.ff
#define c_function_required_args(f)   (_TFnc(f))->object.fnc.required_args
#define c_function_optional_args(f)   (_TFnc(f))->object.fnc.optional_args
#define c_function_has_rest_arg(f)    (_TFnc(f))->object.fnc.rest_arg
#define c_function_all_args(f)        (_TFnc(f))->object.fnc.all_args
#define c_function_setter(f)          _TApp((_TFnc(f))->object.fnc.setter)
#define c_function_set_setter(f, Val) (_TFnc(f))->object.fnc.setter = _TApp(Val)
#define c_function_name(f)            c_function_data(f)->name
#define c_function_name_length(f)     c_function_data(f)->name_length
#define c_function_documentation(f)   c_function_data(f)->doc
#define c_function_signature(f)       c_function_data(f)->signature
#define c_function_class(f)           c_function_data(f)->id
#define c_function_chooser(f)         c_function_data(f)->chooser
#define c_function_base(f)            _TApp(c_function_data(f)->generic_ff)
#define c_function_set_base(f, Val)   c_function_data(f)->generic_ff = _TApp(Val)
#define c_function_arg_defaults(f)    c_function_data(f)->arg_defaults
#define c_function_call_args(f)       c_function_data(f)->call_args
#define c_function_arg_names(f)       c_function_data(f)->arg_names
#define c_function_rp(f)              c_function_data(f)->rp
#define c_function_ip(f)              c_function_data(f)->ip
#define c_function_pp(f)              c_function_data(f)->pp
#define c_function_gp(f)              c_function_data(f)->gp
#define set_c_function(f, X)          do {set_opt_cfunc(f, X); set_c_call(f, c_function_call(opt_cfunc(f)));} while (0)

#define is_c_macro(p)                 (type(p) == T_C_MACRO)
#define c_macro_data(f)               (_TMac(f))->object.fnc.c_proc
#define c_macro_call(f)               (_TMac(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)      (_TMac(f))->object.fnc.required_args
#define c_macro_all_args(f)           (_TMac(f))->object.fnc.all_args
#define c_macro_setter(f)             _TApp((_TMac(f))->object.fnc.setter)
#define c_macro_set_setter(f, Val)    (_TMac(f))->object.fnc.setter = _TApp(Val)

#define is_random_state(p)            (type(p) == T_RANDOM_STATE)
#if WITH_GMP
#define random_gmp_state(p)           (_TRan(p))->object.rng.state
#else
#define random_seed(p)                (_TRan(p))->object.rng.seed
#define random_carry(p)               (_TRan(p))->object.rng.carry
#endif

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

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

#define temp_stack_top(p)             (_TStk(p))->object.stk.top
#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_macro_star(p)              (type(p) == T_MACRO_STAR)
#define is_bacro_star(p)              (type(p) == T_BACRO_STAR)

#define is_closure(p)                 (type(p) == T_CLOSURE)
#define is_closure_star(p)            (type(p) == T_CLOSURE_STAR)
#define closure_args(p)               (_TClo(p))->object.func.args
#define closure_set_args(p, Val)      (_TClo(p))->object.func.args = _TArg(Val)
#define closure_body(p)               (_TPair((_TClo(p))->object.func.body))
#define closure_set_body(p, Val)      (_TClo(p))->object.func.body = _TPair(Val)
#define closure_let(p)                _TLid((_TClo(p))->object.func.env)
#define closure_set_let(p, L)         (_TClo(p))->object.func.env = _TLid(L)
#define closure_setter(p)             _TApp((_TClo(p))->object.func.setter)
#define closure_set_setter(p, Val)    (_TClo(p))->object.func.setter = _TApp(Val)
#define closure_arity(p)              (_TClo(p))->object.func.arity
#define CLOSURE_ARITY_NOT_SET         0x40000000
#define MAX_ARITY                     0x20000000
#define closure_arity_unknown(p)      (closure_arity(p) == CLOSURE_ARITY_NOT_SET)
#define is_thunk(Sc, Fnc)             ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0)))

#define hook_has_functions(p)         (is_pair(s7_hook_functions(sc, _TClo(p))))

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

#define catch_all_goto_loc(p)         (_TLet(p))->object.envr.edat.ctall.goto_loc
#define catch_all_set_goto_loc(p, L)  (_TLet(p))->object.envr.edat.ctall.goto_loc = L
#define catch_all_op_loc(p)           (_TLet(p))->object.envr.edat.ctall.op_stack_loc
#define catch_all_set_op_loc(p, L)    (_TLet(p))->object.envr.edat.ctall.op_stack_loc = L
#define catch_all_result(p)           _NFre((_TLet(p))->object.envr.edat.ctall.result)
#define catch_all_set_result(p, R)    (_TLet(p))->object.envr.edat.ctall.result = R

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

#define is_c_object(p)                (type(p) == T_C_OBJECT)
#define c_object_value(p)             (_TObj(p))->object.c_obj.value
#define c_object_type(p)              (_TObj(p))->object.c_obj.type
#define c_object_let(p)               _TLid((_TObj(p))->object.c_obj.e)
#define c_object_set_let(p, L)        (_TObj(p))->object.c_obj.e = _TLid(L)
#define c_object_cref(p)              (_TObj(p))->object.c_obj.ref

static c_object_t **object_types = NULL;
static int object_types_size = 0;
static int num_object_types = 0;

#define c_object_info(p)              object_types[c_object_type(_TObj(p))]
#define c_object_ref(p)               c_object_info(p)->ref
#define c_object_set(p)               c_object_info(p)->set
#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_eql(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_direct_ref(p)        c_object_info(p)->direct_ref
#define c_object_direct_set(p)        c_object_info(p)->direct_set
#define c_object_ip(p)                c_object_info(p)->ip
#define c_object_rp(p)                c_object_info(p)->rp
#define c_object_set_ip(p)            c_object_info(p)->set_ip
#define c_object_set_rp(p)            c_object_info(p)->set_rp
#define c_object_scheme_name(p)       _TStr(c_object_info(p)->scheme_name)
/* #define c_object_outer_type(p)     c_object_info(p)->outer_type */

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

#define is_counter(p)                 (type(p) == T_COUNTER)
#define counter_result(p)             (_TCtr(p))->object.ctr.result
#define counter_set_result(p, Val)    (_TCtr(p))->object.ctr.result = _NFre(Val)
#define counter_list(p)               (_TCtr(p))->object.ctr.list
#define counter_set_list(p, Val)      (_TCtr(p))->object.ctr.list = _NFre(Val)
#define counter_capture(p)            (_TCtr(p))->object.ctr.cap
#define counter_set_capture(p, Val)   (_TCtr(p))->object.ctr.cap = Val
#define counter_let(p)                _TLid((_TCtr(p))->object.ctr.env)
#define counter_set_let(p, L)         (_TCtr(p))->object.ctr.env = _TLid(L)
#define counter_slots(p)              (_TCtr(p))->object.ctr.slots
#define counter_set_slots(p, Val)     (_TCtr(p))->object.ctr.slots = _TSln(Val)

#define is_baffle(p)                  (type(p) == T_BAFFLE)
#define baffle_key(p)                 (_TBfl(p))->object.baffle_key

#if __cplusplus && HAVE_COMPLEX_NUMBERS
  using namespace std;                /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */
  typedef complex<s7_double> s7_complex;
  static s7_double Real(complex<s7_double> x) {return(real(x));} /* protect the C++ name */
  static s7_double Imag(complex<s7_double> x) {return(imag(x));}
#endif

#define integer(p)                    (_TI(p))->object.number.integer_value
#define real(p)                       (_TR(p))->object.number.real_value
#define set_real(p, x)                real(p) = x
#define numerator(p)                  (_TF(p))->object.number.fraction_value.numerator
#define denominator(p)                (_TF(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)                  (_TZ(p))->object.number.complex_value.rl
#define set_real_part(p, x)           real_part(p) = x
#define imag_part(p)                  (_TZ(p))->object.number.complex_value.im
#define set_imag_part(p, x)           imag_part(p) = x
#if HAVE_COMPLEX_NUMBERS
  #define as_c_complex(p)             CMPLX(real_part(p), imag_part(p))
#endif

#if WITH_GMP
#define big_integer(p)                ((_TBgi(p))->object.number.big_integer)
#define big_ratio(p)                  ((_TBgf(p))->object.number.big_ratio)
#define big_real(p)                   ((_TBgr(p))->object.number.big_real)
#define big_complex(p)                ((_TBgz(p))->object.number.big_complex)
#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 *)((_TNum(p))->object.number.pval.name + 1)
#define print_name_length(p)          (_TNum(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);
      memcpy((void *)print_name(p), (void *)name, len);
    }
}

#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_, 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_, T_REAL); set_real(_X_, _N_); _X_;}) ); })
                     /* the x == 0.0 check saves more than it costs */

#define make_complex(Sc, R, I)						\
  ({ s7_double im; im = (I); ((im == 0.0) ? make_real(Sc, R) : ({ s7_pointer _X_; new_cell(Sc, _X_, T_COMPLEX); set_real_part(_X_, R); set_imag_part(_X_, im); _X_;}) ); })

#define real_to_double(Sc, X, Caller)   ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_REAL) ? real(_x_) : s7_number_to_real_with_caller(sc, _x_, Caller)); })
#define rational_to_double(Sc, X)       ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : fraction(_x_)); })

#else

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

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


/* --------------------------------------------------------------------------------
 * local versions of some standard C library functions
 * timing tests involving these are very hard to interpret -- pervasive inconsistency!
 */

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


static char *copy_string_with_length(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_length(str, safe_strlen(str)));
}


static bool local_strcmp(const char *s1, const char *s2)
{
  while (true)
    {
      if (*s1 != *s2++) return(false);
      if (*s1++ == 0) return(true);
    }
  return(true);
}

#define strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2))
/* this should only be used for internal strings -- scheme strings can have embedded nulls. */

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


static bool local_strncmp(const char *s1, const char *s2, unsigned int n)
{
#if defined(__x86_64__) || defined(__i386__) /* unaligned accesses are safe on i386 hardware, sez everyone */
  if (n >= 4)
    {
      int *is1, *is2;
      int n4 = n >> 2;
      is1 = (int *)s1;
      is2 = (int *)s2;
      do {if (*is1++ != *is2++) return(false);} while (--n4 > 0);
      s1 = (const char *)is1;
      s2 = (const char *)is2;
      n &= 3;
    }
#endif
  while (n > 0)
    {
      if (*s1++ != *s2++) return(false);
      n--;
    }
  return(true);
}

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


 static void memclr(void *s, size_t n)
{
  unsigned char *s2;
#if defined(__x86_64__) || defined(__i386__)
  if (n >= 4)
    {
      int *s1 = (int *)s;
      size_t n4 = n >> 2;
      do {*s1++ = 0;} while (--n4 > 0);
      n &= 3;
      s2 = (unsigned char *)s1;
    }
  else s2 = (unsigned char *)s;
#else
  s2 = (unsigned char *)s;
#endif
  while (n > 0)
    {
      *s2++ = 0;
      n--;
    }
}


/* ---------------- 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 s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator);
static bool is_all_x_safe(s7_scheme *sc, s7_pointer p);
static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e);
static void annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e);
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 prepackaged_type_name(s7_scheme *sc, s7_pointer x);
static void s7_warn(s7_scheme *sc, int len, const char *ctrl, ...);
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, unsigned int type);
static s7_pointer permanent_list(s7_scheme *sc, int len);
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 apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args);
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_vector_1(s7_scheme *sc, s7_int len, bool filled, unsigned int typ);
static s7_pointer make_string_uncopied_with_length(s7_scheme *sc, char *str, int len);
static s7_pointer make_string_wrapper_with_length(s7_scheme *sc, const char *str, int len);
static s7_pointer make_string_wrapper(s7_scheme *sc, const char *str);
static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr);
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(s7_scheme *sc, s7_pointer x, s7_pointer y);
static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym);
static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym);
static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body);
static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_pointer e);
static s7_pointer optimize(s7_scheme *sc, s7_pointer code, int hop, s7_pointer e);
static void free_hash_table(s7_pointer table);

#if WITH_GMP
static s7_int big_integer_to_s7_int(mpz_t n);
#else
static double next_random(s7_pointer r);
#endif

#if DEBUGGING && WITH_GCC
  static s7_pointer find_symbol_unchecked_1(s7_scheme *sc, s7_pointer symbol);
  #define find_symbol_unchecked(Sc, Sym) check_null_sym(Sc, find_symbol_unchecked_1(Sc, Sym), Sym, __LINE__, __func__)
  static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int line, const char *func);
  #define find_symbol_unexamined(Sc, Sym) find_symbol_unchecked_1(Sc, Sym)
#else
  static s7_pointer find_symbol_unchecked(s7_scheme *sc, s7_pointer symbol);
  #define find_symbol_unexamined(Sc, Sym) find_symbol_unchecked(Sc, Sym)
#endif

#if WITH_GCC
  #if DEBUGGING
    #define find_symbol_checked(Sc, Sym) ({s7_pointer _x_; _x_ = find_symbol_unchecked_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
  #else
    #define find_symbol_checked(Sc, Sym) ({s7_pointer _x_; _x_ = find_symbol_unchecked(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
  #endif
#else
  #define find_symbol_checked(Sc, Sym) find_symbol_unchecked(Sc, Sym)
#endif

static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol);
static s7_pointer find_let(s7_scheme *sc, s7_pointer obj);
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, s7_pointer descr);
static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer 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 wrong_type_argument(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 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_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_string, cdr_a_list_string, caar_a_list_string, cadr_a_list_string, cdar_a_list_string,
                  cddr_a_list_string, caaar_a_list_string, caadr_a_list_string, cadar_a_list_string, caddr_a_list_string,
                  cdaar_a_list_string, cdadr_a_list_string, cddar_a_list_string, cdddr_a_list_string, a_list_string, 
                  an_association_list_string, an_output_port_string, an_input_port_string, an_open_port_string, 
                  a_normal_real_string, a_rational_string, a_boolean_string, a_number_string, a_let_string, 
                  a_procedure_string, a_proper_list_string, a_thunk_string, something_applicable_string, a_symbol_string, 
                  a_non_negative_integer_string, a_format_port_string, an_unsigned_byte_string, a_binding_string, 
                  a_non_constant_symbol_string, an_eq_func_string, a_sequence_string, its_too_small_string, 
                  a_normal_procedure_string, its_too_large_string, its_negative_string, result_is_too_large_string, 
                  its_nan_string, its_infinite_string, too_many_indices_string, a_valid_radix_string, an_input_string_port_string, 
                  an_input_file_port_string, an_output_string_port_string, an_output_file_port_string, a_random_state_object_string;

#if (!HAVE_COMPLEX_NUMBERS)
static s7_pointer no_complex_numbers_string;
#endif


/* ---------------- evaluator ops ---------------- */

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_MACROEXPAND,
      OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_UNCHECKED, OP_BEGIN1,
      OP_IF, OP_IF1, OP_WHEN, OP_WHEN1, OP_UNLESS, OP_UNLESS1, OP_SET, OP_SET1, OP_SET2,
      OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2,
      OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, OP_COND, OP_COND1, OP_COND1_1, OP_COND_SIMPLE, OP_COND1_SIMPLE,
      OP_AND, OP_AND1, OP_OR, OP_OR1,
      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_UNQUOTE, OP_READ_APPLY_VALUES,
      OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_DONE,
      OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, 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_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S,
      OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION,
      OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3,
      OP_MAP, OP_MAP_1, OP_MAP_GATHER, OP_MAP_GATHER_1, OP_BARRIER, OP_DEACTIVATE_GOTO,

      OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR,
      OP_GET_OUTPUT_STRING, OP_GET_OUTPUT_STRING_1,
      OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END, OP_SORT_VECTOR_END, OP_SORT_STRING_END,
      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_WHEN_UNCHECKED, OP_UNLESS_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_A,
      OP_SET_SYMBOL_opSq, OP_SET_SYMBOL_opCq, OP_SET_SYMBOL_opSSq, OP_SET_SYMBOL_opSSSq, 
      OP_SET_NORMAL, OP_SET_PAIR, OP_SET_PAIR_Z, OP_SET_PAIR_A, OP_SET_PAIR_P, OP_SET_PAIR_ZA,
      OP_SET_PAIR_P_1, OP_SET_WITH_ACCESSOR, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_ALL_X,
      OP_SET_PAIR_C, OP_SET_PAIR_C_P, OP_SET_PAIR_C_P_1, OP_SET_SAFE,
      OP_INCREMENT_1, OP_DECREMENT_1, OP_SET_CONS,
      OP_INCREMENT_SS, OP_INCREMENT_SSS, OP_INCREMENT_SZ, OP_INCREMENT_SA, OP_INCREMENT_SAA,

      OP_LET_STAR_UNCHECKED, OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED,
      OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, OP_DEFINE_CONSTANT_UNCHECKED,
      OP_DEFINE_WITH_ACCESSOR, OP_DEFINE_MACRO_WITH_ACCESSOR,

      OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_STAR,
      OP_LET_C, OP_LET_S, 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_opSq, OP_LET_ALL_opSq, OP_LET_opSq_P, OP_LET_ONE, OP_LET_ONE_1, OP_LET_Z, OP_LET_Z_1,

      OP_CASE_SIMPLE, OP_CASE_SIMPLER, OP_CASE_SIMPLER_1, OP_CASE_SIMPLER_SS, OP_CASE_SIMPLEST, OP_CASE_SIMPLEST_SS, 
      OP_IF_UNCHECKED, OP_AND_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_P2, OP_OR_UNCHECKED, OP_OR_P, OP_OR_P1, OP_OR_P2,
      OP_IF_P_FEED, OP_IF_P_FEED_1, OP_WHEN_S, OP_UNLESS_S,

      OP_IF_S_P, OP_IF_S_P_P, OP_IF_NOT_S_P, OP_IF_NOT_S_P_P, OP_IF_CC_P, OP_IF_CC_P_P,
      OP_IF_CS_P, OP_IF_CS_P_P, OP_IF_CSQ_P, OP_IF_CSQ_P_P, OP_IF_CSS_P, OP_IF_CSS_P_P,
      OP_IF_CSC_P, OP_IF_CSC_P_P, OP_IF_IS_PAIR_P, OP_IF_IS_PAIR_P_P, OP_IF_opSSq_P, OP_IF_opSSq_P_P, OP_IF_S_opCq_P, OP_IF_S_opCq_P_P,
      OP_IF_IS_SYMBOL_P, OP_IF_IS_SYMBOL_P_P, OP_IF_A_P, OP_IF_A_P_P, OP_IF_AND2_P, OP_IF_AND2_P_P,
      OP_IF_Z_P, OP_IF_Z_P_P, OP_IF_P_P_P, OP_IF_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_CATCH_1, OP_CATCH_2, OP_CATCH_ALL, OP_COND_ALL_X, OP_COND_ALL_X_2, OP_COND_S,
      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_SAFE_DO, OP_SAFE_DO_STEP, OP_SIMPLE_DO_P, OP_SIMPLE_DO_STEP_P, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_P, 
      OP_DOTIMES_P, OP_DOTIMES_STEP_P, OP_SIMPLE_DO_A, OP_SIMPLE_DO_STEP_A, OP_SIMPLE_DO_E, OP_SIMPLE_DO_STEP_E,

      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_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_EVAL_MACRO_MV, OP_MACROEXPAND_1,

      OP_SAFE_C_ZZ_1, OP_SAFE_C_ZZ_2, OP_SAFE_C_ZC_1, OP_SAFE_C_SZ_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_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_CLOSURE_P_1, OP_CLOSURE_P_2, OP_SAFE_CLOSURE_P_1,

      OP_SET_WITH_LET_1, OP_SET_WITH_LET_2,
      OP_MAX_DEFINED_1};

#define OP_MAX_DEFINED (OP_MAX_DEFINED_1 + 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_SAFE_C_C, HOP_SAFE_C_C, OP_SAFE_C_S, HOP_SAFE_C_S,
      OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, HOP_SAFE_C_CS,
      OP_SAFE_C_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_CQ, HOP_SAFE_C_CQ, OP_SAFE_C_QC, HOP_SAFE_C_QC,
      OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS,
      OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC,
      OP_SAFE_C_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_SAS, HOP_SAFE_C_SAS,
      OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, OP_SAFE_C_CAS, HOP_SAFE_C_CAS,
      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_SQS, HOP_SAFE_C_SQS, OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq,
      OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, OP_SAFE_C_S_opAAAq, HOP_SAFE_C_S_opAAAq,

      OP_SAFE_C_opCq, HOP_SAFE_C_opCq, 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_SAFE_C_op_opSq_q_C, HOP_SAFE_C_op_opSq_q_C, 
      OP_SAFE_C_op_opSSq_q_S, HOP_SAFE_C_op_opSSq_q_S, OP_SAFE_C_op_opSq_q_S, HOP_SAFE_C_op_opSq_q_S, 
      OP_SAFE_C_S_op_opSSq_opSSqq, HOP_SAFE_C_S_op_opSSq_opSSqq,
      OP_SAFE_C_op_opSq_q, HOP_SAFE_C_op_opSq_q, OP_SAFE_C_C_op_S_opCqq, HOP_SAFE_C_C_op_S_opCqq,
      OP_SAFE_C_op_S_opSq_q, HOP_SAFE_C_op_S_opSq_q, 
      OP_SAFE_C_opSq_Q, HOP_SAFE_C_opSq_Q, OP_SAFE_C_opSq_Q_S, HOP_SAFE_C_opSq_Q_S,

      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_opCq_Z, HOP_SAFE_C_opCq_Z, OP_SAFE_C_S_opSZq, HOP_SAFE_C_S_opSZq,
      OP_SAFE_C_AZ, HOP_SAFE_C_AZ, OP_SAFE_C_ZA, HOP_SAFE_C_ZA,
      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_THUNK, HOP_THUNK,
      OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_C, HOP_CLOSURE_C, OP_CLOSURE_Q, HOP_CLOSURE_Q,
      OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_CS, HOP_CLOSURE_CS,
      OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_AA, HOP_CLOSURE_AA,
      OP_CLOSURE_ALL_X, HOP_CLOSURE_ALL_X, OP_CLOSURE_ALL_S, HOP_CLOSURE_ALL_S,

      OP_GLOSURE_A, HOP_GLOSURE_A, OP_GLOSURE_S, HOP_GLOSURE_S, OP_GLOSURE_P, HOP_GLOSURE_P,

      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_THUNK_E, HOP_SAFE_THUNK_E, OP_SAFE_THUNK_P, HOP_SAFE_THUNK_P,
      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_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_SA, HOP_SAFE_CLOSURE_SA, OP_SAFE_CLOSURE_S_P, HOP_SAFE_CLOSURE_S_P,
      OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA,
      OP_SAFE_CLOSURE_ALL_X, HOP_SAFE_CLOSURE_ALL_X, OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA,

      OP_SAFE_GLOSURE_A, HOP_SAFE_GLOSURE_A, OP_SAFE_GLOSURE_S, HOP_SAFE_GLOSURE_S, OP_SAFE_GLOSURE_S_E, HOP_SAFE_GLOSURE_S_E, 
      OP_SAFE_GLOSURE_P, HOP_SAFE_GLOSURE_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_SS, HOP_C_SS,
      OP_C_S, HOP_C_S, OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_Z, HOP_C_Z, OP_C_SP, HOP_C_SP,
      OP_C_SZ, HOP_C_SZ, OP_C_A, HOP_C_A, OP_C_SCS, HOP_C_SCS,

      OP_GOTO, HOP_GOTO, OP_GOTO_C, HOP_GOTO_C, OP_GOTO_S, HOP_GOTO_S, OP_GOTO_A, HOP_GOTO_A,

      OP_VECTOR_C, HOP_VECTOR_C, OP_VECTOR_S, HOP_VECTOR_S, OP_VECTOR_A, HOP_VECTOR_A, OP_VECTOR_CC, HOP_VECTOR_CC,
      OP_STRING_C, HOP_STRING_C, OP_STRING_S, HOP_STRING_S, OP_STRING_A, HOP_STRING_A,
      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_A, HOP_C_OBJECT_A, 
      OP_PAIR_C, HOP_PAIR_C, OP_PAIR_S, HOP_PAIR_S, OP_PAIR_A, HOP_PAIR_A,
      OP_HASH_TABLE_C, HOP_HASH_TABLE_C, OP_HASH_TABLE_S, HOP_HASH_TABLE_S, OP_HASH_TABLE_A, HOP_HASH_TABLE_A,
      OP_ENVIRONMENT_S, HOP_ENVIRONMENT_S, OP_ENVIRONMENT_Q, HOP_ENVIRONMENT_Q, OP_ENVIRONMENT_A, HOP_ENVIRONMENT_A, OP_ENVIRONMENT_C, HOP_ENVIRONMENT_C,

      OP_UNKNOWN, HOP_UNKNOWN, OP_UNKNOWN_ALL_S, HOP_UNKNOWN_ALL_S, OP_UNKNOWN_ALL_X, HOP_UNKNOWN_ALL_X,
      OP_UNKNOWN_G, HOP_UNKNOWN_G, OP_UNKNOWN_GG, HOP_UNKNOWN_GG, OP_UNKNOWN_A, HOP_UNKNOWN_A, OP_UNKNOWN_AA, HOP_UNKNOWN_AA,

      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_AP, HOP_SAFE_C_AP,
      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_SSP, HOP_SAFE_C_SSP,
      OPT_MAX_DEFINED
};

#if DEBUGGING || OP_NAMES

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", "macroexpand",
      "define", "define1", "begin", "begin_unchecked", "begin1",
      "if", "if1", "when", "when1", "unless", "unless1", "set", "set1", "set2",
      "let", "let1", "let_star", "let_star1", "let_star2",
      "letrec", "letrec1", "letrec_star", "letrec_star1", "cond", "cond1", "cond1_1", "cond_simple", "cond1_simple",
      "and", "and1", "or", "or1",
      "define_macro", "define_macro_star", "define_expansion",
      "case", "case1", "read_list", "read_next", "read_dot", "read_quote",
      "read_quasiquote", "read_unquote", "read_apply_values",
      "read_vector", "read_byte_vector", "read_done",
      "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done",
      "catch", "dynamic_wind", "define_constant", "define_constant1",
      "do", "do_end", "do_end1", "do_step", "do_step2", "do_init",
      "define_star", "lambda_star", "lambda_star_default", "error_quit", "unwind_input", "unwind_output",
      "error_hook_quit",
      "with_let", "with_let1", "with_let_unchecked", "with_let_s",
      "with_baffle", "with_baffle_unchecked", "expansion",
      "for_each", "for_each_1", "for_each_2", "for_each_3", 
      "map", "map_1", "map_gather", "map_gather_1", "barrier", "deactivate_goto",

      "define_bacro", "define_bacro_star",
      "get_output_string", "get_output_string_1",
      "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", "sort_string_end",
      "eval_string_1", "eval_string_2",
      "member_if", "assoc_if", "member_if1", "assoc_if1",

      "quote_unchecked", "lambda_unchecked", "let_unchecked", "case_unchecked", "when_unchecked", "unless_unchecked",

      "set_unchecked", "set_symbol_c", "set_symbol_s", "set_symbol_q", "set_symbol_p", "set_symbol_z", "set_symbol_a",
      "set_symbol_opsq", "set_symbol_opcq", "set_symbol_opssq", "set_symbol_opsssq", 
      "set_normal", "set_pair", "set_pair_z", "set_pair_a", "set_pair_p", "set_pair_za",
      "set_pair_p_1", "set_with_accessor", "set_pws", "set_let_s", "set_let_all_x",
      "set_pair_c", "set_pair_c_p", "set_pair_c_p_1", "set_safe",
      "increment_1", "decrement_1", "set_cons",
      "increment_ss", "increment_sss", "increment_sz", "increment_sa", "increment_saa",

      "let_star_unchecked", "letrec_unchecked", "letrec_star_unchecked", "cond_unchecked",
      "lambda_star_unchecked", "do_unchecked", "define_unchecked", "define_star_unchecked", "define_funchecked", "define_constant_unchecked",
      "define_with_accessor", "define_macro_with_accessor",

      "let_no_vars", "named_let", "named_let_no_vars", "named_let_star",
      "let_c", "let_s", "let_all_c", "let_all_s", "let_all_x",
      "let_star_all_x", "let_opcq", "let_opssq",
      "let_opsq", "let_all_opsq", "let_opsq_p", "let_one", "let_one_1", "let_z", "let_z_1",

      "case_simple", "case_simpler", "case_simpler_1", "case_simpler_ss", "case_simplest", "case_simplest_ss", 
      "if_unchecked", "and_unchecked", "and_p", "and_p1", "and_p2", "or_unchecked", "or_p", "or_p1", "or_p2",
      "if_p_feed", "if_p_feed_1", "when_s", "unless_s",

      "if_s_p", "if_s_p_p", "if_not_s_p", "if_not_s_p_p", "if_cc_p", "if_cc_p_p",
      "if_cs_p", "if_cs_p_p", "if_csq_p", "if_csq_p_p", "if_css_p", "if_css_p_p",
      "if_csc_p", "if_csc_p_p", "if_is_pair_p", "if_is_pair_p_p", "if_opssq_p", "if_opssq_p_p", "if_s_opcq_p", "if_s_opcq_p_p",
      "if_is_symbol_p", "if_is_symbol_p_p", "if_a_p", "if_a_p_p", "if_and2_p", "if_and2_p_p",
      "if_z_p", "if_z_p_p", "if_p_p_p", "if_p_p", "if_andp_p", "if_andp_p_p", "if_orp_p", "if_orp_p_p",
      "if_ppp", "if_pp",

      "catch_1", "catch_2", "catch_all", "cond_all_x", "cond_all_x_2", "cond_s",
      "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_p", "safe_dotimes_step_o", "safe_dotimes_step_a",
      "safe_do", "safe_do_step", "simple_do_p", "simple_do_step_p", "dox", "dox_step", "dox_step_p", 
      "dotimes_p", "dotimes_step_p", "simple_do_a", "simple_do_step_a", "simple_do_e", "simple_do_step_e",

      "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_2", "safe_c_pp_3", "safe_c_pp_4", "safe_c_pp_5", "safe_c_pp_6",
      "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", "eval_macro_mv", "macroexpand_1",

      "safe_c_zz_1", "safe_c_zz_2", "safe_c_zc_1", "safe_c_sz_1", "safe_c_za_1", "increment_sz_1", "safe_c_sz_sz",
      "safe_c_zaa_1", "safe_c_aza_1", "safe_c_aaz_1", "safe_c_ssz_1",
      "safe_c_zza_1", "safe_c_zza_2", "safe_c_zaz_1", "safe_c_zaz_2", "safe_c_azz_1", "safe_c_azz_2",
      "safe_c_zzz_1", "safe_c_zzz_2", "safe_c_zzz_3",

      "safe_c_opsq_p_1", "safe_c_opsq_p_mv", "c_p_1", "c_p_2", "c_sp_1", "c_sp_2",
      "closure_p_1", "closure_p_2", "safe_closure_p_1",

      "set-with-let-1", "set-with-let-2",
};

static const char* opt_names[OPT_MAX_DEFINED] =
     {"safe_c_c", "h_safe_c_c", "safe_c_s", "h_safe_c_s",
      "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs",
      "safe_c_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_cq", "h_safe_c_cq", "safe_c_qc", "h_safe_c_qc",
      "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css",
      "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc",
      "safe_c_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_sas", "h_safe_c_sas",
      "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", "safe_c_cas", "h_safe_c_cas",
      "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_sqs", "h_safe_c_sqs", "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq",
      "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_s_opaaq", "h_safe_c_s_opaaq", "safe_c_s_opaaaq", "h_safe_c_s_opaaaq",

      "safe_c_opcq", "h_safe_c_opcq", "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", "safe_c_op_opsq_q_c", "h_safe_c_op_opsq_q_c", 
      "safe_c_op_opssq_q_s", "h_safe_c_op_opssq_q_s", "safe_c_op_opsq_q_s", "h_safe_c_op_opsq_q_s", 
      "safe_c_s_op_opssq_opssqq", "h_safe_c_s_op_opssq_opssqq",
      "safe_c_op_opsq_q", "h_safe_c_op_opsq_q", "safe_c_c_op_s_opcqq", "h_safe_c_c_op_s_opcqq",
      "safe_c_op_s_opsq_q", "h_safe_c_op_s_opsq_q",
      "safe_c_opsq_q", "h_safe_c_opsq_q", "safe_c_opsq_q_s", "h_safe_c_opsq_q_s",

      "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_opcq_z", "h_safe_c_opcq_z", "safe_c_s_opszq", "h_safe_c_s_opszq",
      "safe_c_az", "h_safe_c_az", "safe_c_za", "h_safe_c_za",
      "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", 

      "thunk", "h_thunk",
      "closure_s", "h_closure_s", "closure_c", "h_closure_c", "closure_q", "h_closure_q",
      "closure_ss", "h_closure_ss", "closure_sc", "h_closure_sc", "closure_cs", "h_closure_cs",
      "closure_a", "h_closure_a", "closure_aa", "h_closure_aa",
      "closure_all_x", "h_closure_all_x", "closure_all_s", "h_closure_all_s",

      "glosure_a", "h_glosure_a", "glosure_s", "h_glosure_s", "glosure_p", "h_glosure_p",

      "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_thunk_e", "h_safe_thunk_e", "safe_thunk_p", "h_safe_thunk_p",
      "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_a", "h_safe_closure_a", "safe_closure_sa", "h_safe_closure_sa", "safe_closure_s_p", "h_safe_closure_s_p",
      "safe_closure_saa", "h_safe_closure_saa",
      "safe_closure_all_x", "h_safe_closure_all_x", "safe_closure_aa", "h_safe_closure_aa",

      "safe_glosure_a", "h_safe_glosure_a", "safe_glosure_s", "h_safe_glosure_s", "safe_glosure_s_e", "h_safe_glosure_s_e", 
      "safe_glosure_p", "h_safe_glosure_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_ss", "h_c_ss",
      "c_s", "h_c_s", "read_s", "h_read_s", "c_p", "h_c_p", "c_z", "h_c_z", "c_sp", "h_c_sp",
      "c_sz", "h_c_sz", "c_a", "h_c_a", "c_scs", "h_c_scs",

      "goto", "h_goto", "goto_c", "h_goto_c", "goto_s", "h_goto_s", "goto_a", "h_goto_a",
      "vector_c", "h_vector_c", "vector_s", "h_vector_s", "vector_a", "h_vector_a", "vector_cc", "h_vector_cc",
      "string_c", "h_string_c", "string_s", "h_string_s", "string_a", "h_string_a",
      "c_object", "h_c_object", "c_object_c", "h_c_object_c", "c_object_s", "h_c_object_s", "c_object_a", "h_c_object_a", 
      "pair_c", "h_pair_c", "pair_s", "h_pair_s", "pair_a", "h_pair_a",
      "hash_table_c", "h_hash_table_c", "hash_table_s", "h_hash_table_s", "hash_table_a", "h_hash_table_a",
      "environment_s", "h_environment_s", "environment_q", "h_environment_q", "environment_a", "h_environment_a", "environment_c", "h_environment_c",

      "unknown", "h_unknown", "unknown_all_s", "h_unknown_all_s", "unknown_all_x", "h_unknown_all_x",
      "unknown_g", "h_unknown_g", "unknown_gg", "h_unknown_gg", "unknown_a", "h_unknown_a", "unknown_aa", "h_unknown_aa",

      "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_ap", "h_safe_c_ap",
      "safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", "safe_c_pq", "h_safe_c_pq",
      "safe_c_ssp", "h_safe_c_ssp",
};
#endif

#define is_safe_c_op(op) (op < OP_THUNK)                               /* used only in safe_stepper */
#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op < OP_SAFE_C_PP))
#define is_callable_c_op(op) ((op < OP_THUNK) || (op > OP_UNKNOWN_AA)) /* used only in check_set */

static bool is_h_optimized(s7_pointer p)
{
  return((is_optimized(p)) &&
	 ((optimize_op(p) & 1) != 0) &&
	 (!is_unknown_op(optimize_op(p))));
}

#define is_h_safe_c_c(P) ((is_optimized(P)) && (optimize_op(P) == HOP_SAFE_C_C))
#define is_h_safe_c_s(P) ((is_optimized(P)) && (optimize_op(P) == HOP_SAFE_C_S))
#define is_safe_c_s(P)   ((is_optimized(P)) && (op_no_hop(P) == OP_SAFE_C_S))

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

s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
  if (has_methods(obj))
    return(find_method(sc, find_let(sc, obj), method));
  return(sc->undefined);
}


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

#define check_two_methods(Sc, Obj, Method1, Method2, Args)	                            \
  if (has_methods(Obj))                                                                     \
    {                                                                                       \
      s7_pointer func;							                    \
      func = find_method(Sc, find_let(Sc, Obj), Method1);                           \
      if ((func == Sc->undefined) && (Method1 != Method2) && (Method2)) func = find_method(Sc, find_let(Sc, Obj), Method2); \
      if (func != Sc->undefined) return(s7_apply_function(Sc, func, Args)); \
    }

static s7_pointer check_values(s7_scheme *sc, s7_pointer obj, s7_pointer args)
{
  check_method(sc, obj, sc->values_symbol, args);
  return(sc->gc_nil);
}

/* 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
 *   openlet 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, Checker, Method, Args)      \
  {                                                          \
    s7_pointer p;                                            \
    p = car(Args);                                           \
    if (Checker(p)) return(Sc->T);                           \
    check_method(Sc, p, Method, Args);                       \
    return(Sc->F);                                           \
  }

#define check_boolean_not_method(Sc, Checker, Method, Args)  \
  {                                                          \
    s7_pointer p, func;					     \
    p = find_symbol_checked(Sc, cadar(Args));                \
    if (Checker(p)) return(Sc->F);                           \
    if ((has_methods(p)) && ((func = find_method(Sc, find_let(Sc, p), Method)) != Sc->undefined) && \
	(s7_apply_function(Sc, func, list_1(Sc, p)) != Sc->F))		\
      return(Sc->F);                                         \
    return(Sc->T);                                           \
  }

 #define method_or_bust(Sc, Obj, Method, Args, Type, Num)	\
  {                                             \
    s7_pointer func; 	                        \
    if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
      return(s7_apply_function(Sc, func, Args)); \
    if (Num == 0) return(simple_wrong_type_argument(Sc, Method, Obj, Type)); \
    return(wrong_type_argument(Sc, Method, Num, Obj, Type));		\
  }

#define method_or_bust_with_type(Sc, Obj, Method, Args, Type, Num)	\
  {                                             \
    s7_pointer func; 	                        \
    if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
      return(s7_apply_function(Sc, func, Args)); \
    if (Num == 0) return(simple_wrong_type_argument_with_type(Sc, Method, Obj, Type)); \
    return(wrong_type_argument_with_type(Sc, Method, Num, Obj, Type));		\
  }


#define eval_error_any(Sc, ErrType, ErrMsg, Obj) \
  do {static s7_pointer _Err_ = NULL; if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
      return(s7_error(Sc, ErrType, set_elist_2(Sc, _Err_, Obj)));} while (0)

#define eval_error(Sc, ErrMsg, Obj)       eval_error_any(Sc, Sc->syntax_error_symbol, ErrMsg, Obj)
#define eval_type_error(Sc, ErrMsg, Obj)  eval_error_any(Sc, Sc->wrong_type_arg_symbol, ErrMsg, Obj)
#define eval_range_error(Sc, ErrMsg, Obj) eval_error_any(Sc, Sc->out_of_range_symbol, ErrMsg, Obj)

#define eval_error_no_return(Sc, ErrType, ErrMsg, Obj)	\
  do {static s7_pointer _Err_ = NULL; \
      if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
      s7_error(Sc, ErrType, set_elist_2(Sc, _Err_, Obj));} while (0)

#define eval_error_with_caller(Sc, ErrMsg, Caller, Obj)	\
  do {static s7_pointer _Err_ = NULL; \
      if (!_Err_) _Err_ = s7_make_permanent_string(ErrMsg); \
      return(s7_error(Sc, Sc->syntax_error_symbol, set_elist_3(Sc, _Err_, Caller, Obj)));} while (0)

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

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

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

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

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

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

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

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

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

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


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


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"
  #define Q_not pl_bt
  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"
  #define Q_is_boolean pl_bt
  check_boolean_method(sc, s7_is_boolean, sc->is_boolean_symbol, 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) || (is_immutable_symbol(p)));
}


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"
  #define Q_is_constant pl_bt
  check_boolean_method(sc, s7_is_constant, sc->is_constant_symbol, args);
}


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

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

  if (sc->gpofl_loc < 0)
    {
      unsigned int i, size, new_size;
      size = sc->protected_objects_size;
      new_size = 2 * size;
      vector_elements(sc->protected_objects) = (s7_pointer *)realloc(vector_elements(sc->protected_objects), new_size * sizeof(s7_pointer));
      vector_length(sc->protected_objects) = new_size;
      sc->protected_objects_size = new_size;
      sc->gpofl = (unsigned int *)realloc(sc->gpofl, new_size * sizeof(unsigned int));
      for (i = size; i < new_size; i++)
	{
	  vector_element(sc->protected_objects, i) = sc->gc_nil;
	  sc->gpofl[++sc->gpofl_loc] = i;
	}
    }

  loc = sc->gpofl[sc->gpofl_loc--];
#if DEBUGGING
  if ((loc < 0) || (loc >= sc->protected_objects_size))
    fprintf(stderr, "sc->gpofl loc: %u (%d)\n", loc, sc->protected_objects_size);
  if (vector_element(sc->protected_objects, loc) != sc->gc_nil)
    fprintf(stderr, "protected object at %u about to be clobbered? %s\n", loc, DISPLAY(vector_element(sc->protected_objects, loc)));
#endif
  vector_element(sc->protected_objects, loc) = x;
  return(loc);
}

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->gpofl[++sc->gpofl_loc] = i;
	return;
      }
}


void s7_gc_unprotect_at(s7_scheme *sc, unsigned int loc)
{
  if (loc < sc->protected_objects_size)
    {
      if (vector_element(sc->protected_objects, loc) != sc->gc_nil)
	sc->gpofl[++sc->gpofl_loc] = loc;
      vector_element(sc->protected_objects, loc) = sc->gc_nil;
    }
}


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

  obj = sc->unspecified;
  if (loc < 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);

#define S7_MARK(Obj) do {s7_pointer _p_; _p_ = Obj; if (!is_marked(_p_)) (*mark_function[unchecked_type(_p_)])(_p_);} while (0)

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 SYNTACTIC_TYPE,
   *   slowing everything down by a large amount.
   */
}

static void mark_noop(s7_pointer p) {}

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

static port_t *alloc_port(s7_scheme *sc)
{
  if (sc->port_heap)
    {
      port_t *p;
      p = sc->port_heap;
      sc->port_heap = (port_t *)(p->next);
      return(p);
    }
  return((port_t *)calloc(1, sizeof(port_t)));
}


static void free_port(s7_scheme *sc, port_t *p)
{
  p->next = (void *)(sc->port_heap);
  sc->port_heap = p;
}

static void close_output_port(s7_scheme *sc, s7_pointer p);

static void sweep(s7_scheme *sc)
{
  unsigned int i, j;
  if (sc->strings_loc > 0)
    {
      /* unrolling this loop is not an improvement */
      for (i = 0, j = 0; i < sc->strings_loc; i++)
	{
	  s7_pointer s1;
	  s1 = sc->strings[i];
	  if (is_free_and_clear(s1))
	    {
	      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 (is_free_and_clear(s1))
	    {
	      remove_gensym_from_symbol_table(sc, s1); /* this uses symbol_name_cell data */
	      free(symbol_name(s1));
	      if ((is_documented(s1)) &&
		  (symbol_help(s1)))
		{
		  free(symbol_help(s1));
		  symbol_help(s1) = NULL;
		}
	      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 (is_free_and_clear(sc->c_objects[i]))
	    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 (is_free_and_clear(sc->vectors[i]))
	    {
	      s7_pointer a;
	      a = sc->vectors[i];

	      /* a multidimensional empty vector can have dimension info, wrapped vectors always 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) */
		  if (vector_dimension_info(a) != sc->wrap_only)
		    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,
	   *   not_in_heap(heap_location(v)), 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 (is_free_and_clear(sc->hash_tables[i]))
	    {
	      if (hash_table_mask(sc->hash_tables[i]) > 0)
		free_hash_table(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 (is_free_and_clear(sc->input_ports[i]))
	    {
	      s7_pointer a;
	      a = sc->input_ports[i];
	      if (port_needs_free(a))
		{
		  if (port_data(a))
		    {
		      free(port_data(a));
		      port_data(a) = NULL;
		      port_data_size(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 (is_free_and_clear(sc->output_ports[i]))
	    {
	      close_output_port(sc, sc->output_ports[i]); /* needed for free filename, etc */
	      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 (is_free_and_clear(sc->continuations[i]))
	    {
	      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 (is_free_and_clear(s1))
	    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 (is_free_and_clear(s1))
	    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 (is_free_and_clear(s1))
	    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 (is_free_and_clear(s1))
	    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;
}

#define Add_String(Str) if (sc->strings_loc == sc->strings_size) add_string(sc, Str); else sc->strings[sc->strings_loc++] = Str


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

#define Add_Vector(Vec) if (sc->vectors_loc == sc->vectors_size) add_vector(sc, Vec); else sc->vectors[sc->vectors_loc++] = Vec

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 64
static void init_gc_caches(s7_scheme *sc)
{
  sc->strings_size = INIT_GC_CACHE_SIZE * 16;
  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 * 8;
  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

  /* slightly unrelated... */
  sc->setters_size = 4;
  sc->setters_loc = 0;
  sc->setters = (s7_pointer *)malloc(sc->c_objects_size * sizeof(s7_pointer));
}


static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter)
{
  /* procedure-setters GC-protected. The c_function_setter field can't be used because the built-in functions
   *   are often removed from the heap and never thereafter marked.
   */
  unsigned int i;
  for (i = 0; i < sc->setters_loc; i++)
    {
      s7_pointer x;
      x = sc->setters[i];
      if (car(x) == p)
	{
	  set_cdr(x, setter);
	  return;
 	}
    }
  if (sc->setters_loc == sc->setters_size)
    {
      sc->setters_size *= 2;
      sc->setters = (s7_pointer *)realloc(sc->setters, sc->setters_size * sizeof(s7_pointer));
    }
  sc->setters[sc->setters_loc++] = permanent_cons(p, setter, T_PAIR | T_IMMUTABLE);
}


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_slot(s7_pointer p)
{
  set_mark(p);
  S7_MARK(slot_value(p));
  if (slot_has_accessor(p))
    S7_MARK(slot_accessor(p));

  if (is_gensym(slot_symbol(p))) /* (let () (apply define (gensym) (list 32)) (gc) (gc) (curlet)) */
    set_mark(slot_symbol(p));
}

static void mark_let(s7_pointer env)
{
  s7_pointer x;
  for (x = env; is_let(x) && (!is_marked(x)); x = outlet(x))
    {
      s7_pointer y;
      set_mark(x);
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (!is_marked(y)) /* slot value might be the enclosing let */
	  mark_slot(y);
    }
}

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

static void mark_c_proc_star(s7_pointer p)
{
  set_mark(p);
  if (!has_simple_defaults(p))
    {
      s7_pointer arg;
      for (arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg))
	S7_MARK(car(arg));
    }
}

static void mark_pair(s7_pointer p)
{
  s7_pointer x;
  set_mark(p);
  S7_MARK(car(p));
  /* if the list is huge, recursion to cdr(p) is problematic when there are strict limits on the stack size
   *  so I'll try something else... (This form is faster according to callgrind).
   *
   * in snd-14 or so through 15.3, sc->temp_cell_2|3 were used for trailing args in eval, but that meant
   *   the !is_marked check below (which is intended to catch cyclic lists) caused cells to be missed;
   *   since sc->args could contain permanently marked cells, if these were passed to g_vector, for example, and
   *   make_vector_1 triggered a GC call, we needed to mark both the permanent (always marked) cell and its contents,
   *   and continue through the rest of the list.  But adding temp_cell_2|3 to sc->permanent_objects was not enough.
   *   Now I've already forgotten the rest of the story, and it was just an hour ago! -- the upshot is that temp_cell_2|3
   *   are not now used as arg list members.
   */
  for (x = cdr(p); is_pair(x) && (!is_marked(x)); x = cdr(x))
    {
      set_mark(x);
      S7_MARK(car(x));
    }
  S7_MARK(x);
}

static void mark_counter(s7_pointer p)
{
  set_mark(p);
  S7_MARK(counter_result(p));
  S7_MARK(counter_list(p));
  S7_MARK(counter_let(p));
}

static void mark_closure(s7_pointer p)
{
  set_mark(p);
  S7_MARK(closure_args(p));
  S7_MARK(closure_body(p));
  mark_let(closure_let(p));
  S7_MARK(closure_setter(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_stack(s7_pointer p)
{
  /* we can have a bare stack awaiting a continuation to hold it if the new_cell for the continuation
   *    triggers the GC!  But we need a top-of-stack??
   */
  mark_stack_1(p, temp_stack_top(p));
}

static void mark_continuation(s7_pointer p)
{
  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)
{
  mark_vector_1(p, vector_length(p));
}

static void mark_vector_possibly_shared(s7_pointer p)
{
  /* If a subvector (an inner dimension) of a vector is the only remaining reference
   *    to the main vector, we want to make sure the main vector is not GC'd until
   *    the subvector is also GC-able.  The 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 we have a shared-vector of a shared-vector, and the middle and original are not otherwise
   *   in use, we mark the middle one, but (since it itself is not in use anywhere else)
   *   we don't mark the original!  So we need to follow the share-vector chain marking every one.
   */
  if ((vector_has_dimensional_info(p)) &&
      (s7_is_vector(shared_vector(p))))
    mark_vector_possibly_shared(shared_vector(p));

  mark_vector_1(p, vector_length(p));
}

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

static void mark_int_or_float_vector_possibly_shared(s7_pointer p)
{
  if ((vector_has_dimensional_info(p)) &&
      (s7_is_vector(shared_vector(p))))
    mark_int_or_float_vector_possibly_shared(shared_vector(p));

  set_mark(p);
}

static void mark_c_object(s7_pointer p)
{
  set_mark(p);
  (*(c_object_mark(p)))(c_object_value(p));
}

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

static void mark_dynamic_wind(s7_pointer 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)
{
  set_mark(p);
  S7_MARK(hash_table_procedures(p));
  if (hash_table_entries(p) > 0)
    {
      unsigned int i, len;
      hash_entry_t **entries;
      entries = hash_table_elements(p);
      len = hash_table_mask(p) + 1;
      for (i = 0; i < len; i++)
	{
	  hash_entry_t *xp;
	  for (xp = entries[i++]; xp; xp = xp->next)
	    {
	      S7_MARK(xp->key);
	      S7_MARK(xp->value);
	    }
	  for (xp = entries[i]; xp; xp = xp->next)
	    {
	      S7_MARK(xp->key);
	      S7_MARK(xp->value);
	    }
	}
    }
}

static void mark_iterator(s7_pointer p)
{
  set_mark(p);
  S7_MARK(iterator_sequence(p));
  if (is_mark_seq(p))
    S7_MARK(iterator_current(p));
}

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

static void gf_mark(s7_scheme *sc)
{
  gc_obj *p;
  if (sc->cur_rf)
    for (p = sc->cur_rf->gc_list; p; p = p->nxt)
      S7_MARK(p->p);
}


static void init_mark_functions(void)
{
  mark_function[T_FREE]                = mark_noop;
  mark_function[T_UNIQUE]              = mark_noop;
  mark_function[T_UNSPECIFIED]         = mark_noop;
  mark_function[T_NIL]                 = mark_noop;
  mark_function[T_BOOLEAN]             = 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; /* this changes if shared vector created (similarly below) */
  mark_function[T_INT_VECTOR]          = mark_int_or_float_vector;
  mark_function[T_FLOAT_VECTOR]        = mark_int_or_float_vector; 
  mark_function[T_MACRO]               = mark_closure;
  mark_function[T_BACRO]               = mark_closure;
  mark_function[T_MACRO_STAR]          = mark_closure;
  mark_function[T_BACRO_STAR]          = mark_closure;
  mark_function[T_C_OBJECT]            = mark_c_object;
  mark_function[T_RANDOM_STATE]        = just_mark;
  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_ITERATOR]            = mark_iterator;
  mark_function[T_SYNTAX]              = mark_noop;
  mark_function[T_LET]                 = mark_let;
  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;
  mark_function[T_C_FUNCTION_STAR]     = just_mark;  /* changes to mark_c_proc_star if defaults involve an expression */
  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;
}


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_rootlet(s7_scheme *sc)
{
  s7_pointer ge;
  s7_pointer *tmp, *top;

  ge = sc->rootlet;
  tmp = vector_elements(ge);
  top = (s7_pointer *)(tmp + sc->rootlet_entries);

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

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

static void mark_permanent_objects(s7_scheme *sc)
{
  gc_obj *g;
  for (g = sc->permanent_objects; g; g = (gc_obj *)(g->nxt))
    S7_MARK(g->p);
}

static void unmark_permanent_objects(s7_scheme *sc)
{
  gc_obj *g;
  for (g = sc->permanent_objects; g; g = (gc_obj *)(g->nxt))
    clear_mark(g->p);
}


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


#if DEBUGGING
static int last_gc_line = 0;
static const char *last_gc_func = NULL;
#endif

#define GC_STATS 1
#define HEAP_STATS 2
#define STACK_STATS 4

#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0)
#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0)
#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0)


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) */
#if DEBUGGING
  #define gc_call(P, Tp) \
    p = (*tp++); \
    if (is_marked(p)) \
       clear_mark(p); \
    else \
      { \
        if (!is_free_and_clear(p))		\
          {								\
	    p->debugger_bits = 0; p->gc_line = last_gc_line; p->gc_func = last_gc_func;	\
            clear_type(p);	\
            (*fp++) = p;\
          }}
#else
  #define gc_call(P, Tp) p = (*tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}}
#endif

  if (show_gc_stats(sc))
    {
      fprintf(stdout, "gc ");
#if DEBUGGING
      fprintf(stdout, "%s[%d] ", last_gc_func, last_gc_line);
#endif
#ifndef _MSC_VER
      /* this is apparently deprecated in favor of clock_gettime -- what compile-time switch to use here?
       *   _POSIX_TIMERS, or perhaps use CLOCK_REALTIME, but clock_gettime requires -lrt -- no thanks.
       */
      gettimeofday(&start_time, &z0);
#endif
    }

  mark_rootlet(sc);
  S7_MARK(sc->args);
  mark_let(sc->envir);

  slot_set_value(sc->error_data, sc->F); 
  /* the other choice here is to explicitly mark slot_value(sc->error_data) as we do eval_history1/2 below.
   *    in both cases, the values are permanent lists that do not mark impermanent contents.
   *    this will need circular list checks, and can't depend on marked to exit early
   */
  mark_let(sc->owlet);
#if WITH_HISTORY
  {
    s7_pointer p1, p2;
    for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2))
      {
	S7_MARK(car(p1));
	S7_MARK(car(p2));
	p1 = cdr(p1);
	if (p1 == sc->eval_history1) break; /* these are circular lists */
      }
  }
#endif

  S7_MARK(sc->code);
  mark_current_code(sc);
  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);
  S7_MARK(sc->temp5);
  S7_MARK(sc->temp6);
  S7_MARK(sc->temp7);
  S7_MARK(sc->temp8);
  S7_MARK(sc->temp9);
  S7_MARK(sc->temp10);
  gf_mark(sc);

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

  mark_pair(sc->temp_cell_1);
  mark_pair(sc->temp_cell_2);
  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));

  S7_MARK(car(sc->plist_1));
  S7_MARK(car(sc->plist_2));
  S7_MARK(cadr(sc->plist_2));
  S7_MARK(car(sc->plist_3));
  S7_MARK(cadr(sc->plist_3));
  S7_MARK(caddr(sc->plist_3));

  {
    unsigned int i;
    s7_pointer p;
    for (i = 1; i < NUM_SAFE_LISTS; i++)
      if (list_is_in_use(sc->safe_lists[i]))
	for (p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
	  S7_MARK(car(p));
    for (i = 0; i < sc->setters_loc; i++)
      S7_MARK(cdr(sc->setters[i]));
  }
  {
    int i;
    for (i = 0; i < sc->num_fdats; i++)
      if (sc->fdats[i])
	S7_MARK(sc->fdats[i]->curly_arg);
  }
  S7_MARK(sc->protected_objects);
  S7_MARK(sc->protected_accessors);

  /* 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);
  mark_permanent_objects(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) != T_FREE first */
	  clear_mark(p);
	else
	  {
	    if (!is_free_and_clear(p)) /* if T_FREE, 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
		clear_type(p); /* (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);
  }

  unmark_permanent_objects(sc);
  sc->gc_freed = (int)(sc->free_heap_top - old_free_heap_top);

  if (show_gc_stats(sc))
    {
#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);
#if (PRINT_NAME_PADDING == 8)
      fprintf(stdout, "freed %d/%u (free: %d), time: %f\n", sc->gc_freed, sc->heap_size, sc->free_heap_top - sc->free_heap, secs);
#else
      fprintf(stdout, "freed %d/%u (free: %ld), time: %f\n", sc->gc_freed, sc->heap_size, sc->free_heap_top - sc->free_heap, secs);
#endif
#else
      fprintf(stdout, "freed %d/%u\n", sc->gc_freed, sc->heap_size);
#endif
    }
  
  /* if (sc->begin_hook) call_begin_hook(sc); */
  sc->previous_free_heap_top = sc->free_heap_top;
  return(sc->gc_freed); /* needed by cell allocator to decide when to increase heap size */
}

void s7_gc_stats(s7_scheme *sc, bool on) {sc->gc_stats = (on) ? GC_STATS : 0;}
unsigned int s7_heap_size(s7_scheme *sc) {return(sc->heap_size);}
int s7_gc_freed(s7_scheme *sc) {return(sc->gc_freed);}


#define GC_TRIGGER_SIZE 64

/* new_cell has to include the new cell's type.  In the free list, it is 0 (T_FREE).  If we remove it here,
 *   but then hit some error before setting the type, the GC sweep thinks it is a free cell already and
 *   does not return it to the free list: a memory leak.
 */

#if (!DEBUGGING)
#define new_cell(Sc, Obj, Type)			\
  do {						\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
    Obj = (*(--(Sc->free_heap_top))); \
    set_type(Obj, Type);	      \
    } while (0)

#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_type(Obj, Type);} while (0)
  /* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need
   *   to check it repeatedly after the first such check.
   */
#else
static bool for_any_other_reason(s7_scheme *sc, int line)
{
#if 0
  static int ctr = 0;
  if ((sc->default_rng) &&
      (!sc->gc_off) &&
      (ctr > GC_TRIGGER_SIZE))
    {
      s7_double x;
      x = next_random(sc->default_rng);
      if (x > .995)
	{
	  ctr = 0;
	  return(true);
	}
    }
  ctr++;
#endif
  return(false);
}

#define new_cell(Sc, Obj, Type)			\
  do {						\
    if ((Sc->free_heap_top <= Sc->free_heap_trigger) || (for_any_other_reason(sc, __LINE__))) {last_gc_line = __LINE__; last_gc_func = __func__; try_to_call_gc(Sc);} \
    Obj = (*(--(Sc->free_heap_top))); \
    Obj->alloc_line = __LINE__;	 Obj->alloc_func = __func__;	\
    set_type(Obj, Type);	      \
    } while (0)

#define new_cell_no_check(Sc, Obj, Type)		\
  do {						\
    Obj = (*(--(Sc->free_heap_top)));					\
    Obj->alloc_line = __LINE__;	 Obj->alloc_func = __func__;		\
    set_type(Obj, Type);						\
    } while (0)
#endif


static void resize_heap(s7_scheme *sc)
{
  /* alloc more heap */
  unsigned int old_size, old_free, k;
  s7_cell *cells;
  s7_pointer p;

  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))
    s7_warn(sc, 256, "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))
    s7_warn(sc, 256, "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 */
  cells = (s7_cell *)calloc(sc->heap_size - old_size, sizeof(s7_cell));
  for (p = cells, k = old_size; k < sc->heap_size;)
    {
      sc->heap[k] = p;
      heap_location(p) = k++;
      (*sc->free_heap_top++) = p++;
      sc->heap[k] = p;
      heap_location(p) = k++;
      (*sc->free_heap_top++) = p++;
      sc->heap[k] = p;
      heap_location(p) = k++;
      (*sc->free_heap_top++) = p++;
      sc->heap[k] = p;
      heap_location(p) = k++;
      (*sc->free_heap_top++) = p++;
    }
  sc->previous_free_heap_top = sc->free_heap_top;

  if (show_heap_stats(sc))
    fprintf(stderr, "heap grows to %u\n", sc->heap_size);
}

static void try_to_call_gc(s7_scheme *sc)
{
  /* called only from new_cell and cons */
  if (sc->gc_off)
    {
      /* we can't just return here!  Someone needs a new cell, and once the heap free list is exhausted, segfault */
      resize_heap(sc);
    }
  else
    {
#if (!DEBUGGING)
      unsigned int freed_heap;
      freed_heap = gc(sc);
      if ((freed_heap < sc->heap_size / 2) &&
	  (freed_heap < 1000000)) /* if huge heap */
	resize_heap(sc);
#else
      gc(sc);
      if ((unsigned int)(sc->free_heap_top - sc->free_heap) < sc->heap_size / 2)
	resize_heap(sc);
#endif
    }
}

  /* 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!"
  #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol)

  if (is_not_null(args))
    {
      if (!s7_is_boolean(car(args)))
	method_or_bust(sc, car(args), sc->gc_symbol, args, T_BOOLEAN, 0);
      sc->gc_off = (car(args) == sc->F);
      if (sc->gc_off)
	return(sc->F);
    }
#if DEBUGGING
  last_gc_line = __LINE__; 
  last_gc_func = __func__;
#endif
  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 int permanent_cells = 0;
#if (!WITH_THREADS)
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)     /* if either no current block or the block is used up */
    {                            /*   make a new block */
      permanent_cells += ALLOC_SIZE;
      alloc_cells = (s7_cell *)calloc(ALLOC_SIZE, sizeof(s7_cell));
      alloc_k = 0;
    }
  return(&alloc_cells[alloc_k++]);
}
#else
#define alloc_pointer() (s7_cell *)calloc(1, sizeof(s7_cell))
#endif


static void add_permanent_object(s7_scheme *sc, s7_pointer obj)
{
  gc_obj *g;
  g = (gc_obj *)malloc(sizeof(gc_obj));
  g->p = obj;
  g->nxt = sc->permanent_objects;
  sc->permanent_objects = g;
}


static void free_cell(s7_scheme *sc, s7_pointer p)
{
#if DEBUGGING
  p->debugger_bits = 0;
#endif
  clear_type(p);
  (*(sc->free_heap_top++)) = p;
}


static 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.
   *
   *    (define (bad-idea)
   *      (let ((lst '(1 2 3)))
   *        (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 (*s7* 'safety) is not 0, remove-from-heap is disabled.
   */
  loc = heap_location(x);
  if (not_in_heap(x)) return;

  switch (type(x))
    {
    case T_PAIR:
      unheap(x);
      p = alloc_pointer();
      sc->heap[loc] = p;
      (*sc->free_heap_top++) = p;
      heap_location(p) = loc;
#if 0
      /* this code fixes the problem above, but at some cost (gc + mark_pair up by about 2% in the worst case (snd-test.scm)) */
      if ((car(x) == sc->quote_symbol) &&
	  (is_pair(cadr(x))))
	{
	  add_permanent_object(sc, cdr(x));
	}
      else
	{
	  s7_remove_from_heap(sc, car(x));
	  s7_remove_from_heap(sc, cdr(x));
	}
#else
      s7_remove_from_heap(sc, car(x));
      s7_remove_from_heap(sc, cdr(x));
#endif
      return;

    case T_HASH_TABLE:
    case T_LET:
    case T_VECTOR: 
      /* not int|float_vector or string because none of their elements are GC-able (so unheap below is ok)
       *   but hash-table and let seem like they need protection? And let does happen via define-class.
       */
      add_permanent_object(sc, x);
      return;

    case T_SYNTAX:
      return;

    case T_SYMBOL:
      if (is_gensym(x))
	{
	  unsigned int i;
	  sc->heap[loc] = alloc_pointer();
	  free_cell(sc, sc->heap[loc]);
	  heap_location(sc->heap[loc]) = loc;

	  /* unheap(x); */
	  heap_location(x) = -heap_location(x);
	  /* if gensym is a hash-table key, then is removed from the heap, we need to be sure the hash-table map to it
	   *   continues to be valid.  symbol_hmap is abs(heap_location), and the possible overlap with other not-in-heap
	   *   ints is not problematic (they'll just hash to the same location).
	   */
	  for (i = 0; i < sc->gensyms_loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */
	    if (sc->gensyms[i] == x)
	      {
		unsigned int j;
		for (j = i + 1; i < sc->gensyms_loc - 1; i++, j++)
		  sc->gensyms[i] = sc->gensyms[j];
		sc->gensyms[i] = NULL;
		sc->gensyms_loc--;
		if (sc->gensyms_loc == 0) mark_function[T_SYMBOL] = mark_noop;
		break;
	      }
	}
      return;

    case T_CLOSURE: case T_CLOSURE_STAR:
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
      unheap(x);
      p = alloc_pointer();
      free_cell(sc, p);
      sc->heap[loc] = p;
      heap_location(p) = loc;

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

    default:
      break;
    }

  unheap(x);
  p = alloc_pointer();
  free_cell(sc, p);
  sc->heap[loc] = p;
  heap_location(p) = loc;
}



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

#define OP_STACK_INITIAL_SIZE 32

#if DEBUGGING
#define stop_at_error true

static void push_op_stack(s7_scheme *sc, s7_pointer op)
{
  (*sc->op_stack_now++) = _NFre(op);
  if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size)) 
    {
      fprintf(stderr, "%sop_stack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
}

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

static void initialize_op_stack(s7_scheme *sc)
{
  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(_TStk(Stack), Loc - 3)
#define stack_let(Stack, Loc)   vector_element(_TStk(Stack), Loc - 2)
#define stack_args(Stack, Loc)  vector_element(_TStk(Stack), Loc - 1)
#define stack_op(Stack, Loc)    ((opcode_t)(vector_element(_TStk(Stack), Loc)))

#if DEBUGGING
static void pop_stack(s7_scheme *sc)
{
  opcode_t cur_op;
  cur_op = sc->op;
  sc->stack_end -= 4;
  if (sc->stack_end < sc->stack_start) 
    {
      fprintf(stderr, "%sstack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  sc->code =  sc->stack_end[0];
  sc->envir = _TLid(sc->stack_end[1]);
  sc->args =  sc->stack_end[2];
  sc->op =    (opcode_t)(sc->stack_end[3]);
  if (sc->op > OP_MAX_DEFINED) 
    {
      fprintf(stderr, "%spop_stack[%d] invalid opcode: " INT_FORMAT "%s\n", BOLD_TEXT, __LINE__, sc->op, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if (unchecked_type(sc->code) == T_FREE)
    {
      fprintf(stderr, "%s%s[%d]: stack code is free, op: %s -> %s%s\n", BOLD_TEXT, __func__, __LINE__, op_names[cur_op], op_names[sc->op], UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if (unchecked_type(sc->args) == T_FREE)
    {
      fprintf(stderr, "%s%s[%d]: stack args is free, op: %s -> %s%s\n", BOLD_TEXT, __func__, __LINE__, op_names[cur_op], op_names[sc->op], UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
}

static void pop_stack_no_op(s7_scheme *sc)
{
  opcode_t cur_op;
  cur_op = sc->op;
  sc->stack_end -= 4;
  if (sc->stack_end < sc->stack_start) 
    {
      fprintf(stderr, "%sstack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  sc->code =  sc->stack_end[0];
  sc->envir = _TLid(sc->stack_end[1]);
  sc->args =  sc->stack_end[2];
  if (unchecked_type(sc->code) == T_FREE)
    {
      fprintf(stderr, "%s%s[%d]: stack code is free, op: %s -> %s%s\n", BOLD_TEXT, __func__, __LINE__, op_names[cur_op], op_names[sc->op], UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if (unchecked_type(sc->args) == T_FREE)
    {
      fprintf(stderr, "%s%s[%d]: stack args is free, op: %s -> %s%s\n", BOLD_TEXT, __func__, __LINE__, op_names[cur_op], op_names[sc->op], UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
}

static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code)
{
  if (sc->stack_end >= sc->stack_start + sc->stack_size) 
    {
      fprintf(stderr, "%sstack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if (op > OP_MAX_DEFINED) 
    {
      fprintf(stderr, "%spush_stack[%d] invalid opcode: " INT_FORMAT "%s\n", BOLD_TEXT, __LINE__, sc->op, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if (code) sc->stack_end[0] = _NFre(code);
  sc->stack_end[1] = _TLid(sc->envir);
  if (args) sc->stack_end[2] = _NFre(args);
  sc->stack_end[3] = (s7_pointer)op;
  sc->stack_end += 4;
}

#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->gc_nil)
#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->gc_nil, Code)
/* in the non-debugging case, the sc->F's here are not set, so we can (later) pop free cells */

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

#define push_stack_no_code(Sc, Op, Args) \
  do { \
      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)
#endif
/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set
 *   sc->code and sc->args to currently free objects.
 */

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

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

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


static void resize_stack(s7_scheme *sc)
{
  unsigned int i, new_size, loc;  /* long long ints?? sc->stack_size also is an unsigned int */

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

  /* how can we trap infinite recursions?  Is a warning in order here?
   *   I think I'll add 'max-stack-size
   *   size currently reaches 8192 in s7test
   */
  if (new_size > sc->max_stack_size)
    s7_error(sc, s7_make_symbol(sc, "stack-too-big"), set_elist_1(sc, make_string_wrapper(sc, "stack has grown past (*s7* 'max-stack-size)")));

  vector_elements(sc->stack) = (s7_pointer *)realloc(vector_elements(sc->stack), new_size * sizeof(s7_pointer));
  if (vector_elements(sc->stack) == NULL)
    s7_error(sc, s7_make_symbol(sc, "stack-too-big"), set_elist_1(sc, make_string_wrapper(sc, "no room to expand stack?")));

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

  if (show_stack_stats(sc))
    fprintf(stderr, "stack grows to %u\n", new_size);
}

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



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

static unsigned long long int raw_string_hash(const unsigned char *key, unsigned int len)
{
  unsigned long long int x;
  unsigned char *cx = (unsigned char *)&x;

  x = 0;
  if (len <= 8)
    memcpy((void *)cx, (void *)key, len);
  else
    {
      unsigned long long int y;
      unsigned char *cy = (unsigned char *)&y;

      memcpy((void *)cx, (void *)key, 8);
      y = 0;
      len -= 8;
      memcpy((void *)cy, (void *)(key + 8), (len > 8) ? 8 : len);
      x |= y;
    }
  return(x);
}


static s7_pointer make_symbol_with_length(s7_scheme *sc, const char *name, unsigned int len);

static s7_pointer new_symbol(s7_scheme *sc, const char *name, unsigned int len, unsigned long long int hash, unsigned int location)
{
  s7_pointer x, str, p;
  unsigned char *base, *val;

  if (sc->symbol_table_is_locked)
    return(s7_error(sc, sc->error_symbol, set_elist_1(sc, make_string_wrapper(sc, "can't make symbol: symbol table is locked!"))));

  base = (unsigned char *)malloc(sizeof(s7_cell) * 3 + len + 1);
  x = (s7_pointer)base;
  str = (s7_pointer)(base + sizeof(s7_cell));
  p = (s7_pointer)(base + 2 * sizeof(s7_cell));
  val = (unsigned char *)(base + 3 * sizeof(s7_cell));
  memcpy((void *)val, (void *)name, len);
  val[len] = '\0';

  unheap(str);
  typeflag(str) = T_STRING | T_IMMUTABLE;                  /* avoid debugging confusion involving set_type (also below) */
  string_length(str) = len;
  string_value(str) = (char *)val;
  string_hash(str) = hash;
  string_needs_free(str) = false;

  unheap(x);
  typeflag(x) = T_SYMBOL;
  symbol_set_name_cell(x, str);
  set_global_slot(x, sc->undefined);                       /* was sc->nil; */
  set_initial_slot(x, sc->undefined);
  symbol_set_local(x, 0LL, sc->nil);
  symbol_set_tag(x, 0);

  if (symbol_name_length(x) > 1)                           /* not 0, otherwise : is a keyword */
    {
      if (name[0] == ':')
	{
	  typeflag(x) |= (T_IMMUTABLE | T_KEYWORD);
	  keyword_set_symbol(x, make_symbol_with_length(sc, (char *)(name + 1), len - 1));
	  set_global_slot(x, s7_make_slot(sc, sc->nil, x, x));
	}
      else
	{
	  char c;
	  c = name[symbol_name_length(x) - 1];
	  if (c == ':')
	    {
	      char *kstr;
	      unsigned int klen;
	      klen = symbol_name_length(x) - 1;
	      /* can't used tmpbuf_* here (or not safely I think) because name is already using tmpbuf */
	      kstr = (char *)malloc((klen + 1) * sizeof(char));
	      memcpy((void *)kstr, (void *)name, klen);
	      kstr[klen] = 0;
	      typeflag(x) |= (T_IMMUTABLE | T_KEYWORD);
	      keyword_set_symbol(x, make_symbol_with_length(sc, kstr, klen));
	      set_global_slot(x, s7_make_slot(sc, sc->nil, x, x));
	      free(kstr);
	    }
	}
    }

  unheap(p);
  typeflag(p) = T_PAIR | T_IMMUTABLE;
  set_car(p, x);
  set_cdr(p, vector_element(sc->symbol_table, location));
  vector_element(sc->symbol_table, location) = p;
  pair_set_raw_hash(p, hash);
  pair_set_raw_len(p, len);
  pair_set_raw_name(p, string_value(str));
  return(x);
}

static s7_pointer make_symbol_with_length(s7_scheme *sc, const char *name, unsigned int len)
{
  s7_pointer x;
  unsigned long long int hash;
  unsigned int location;

  hash = raw_string_hash((const unsigned char *)name, len);
  location = hash % SYMBOL_TABLE_SIZE;

  if (len <= 8)
    {
      for (x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x))
	if ((hash == pair_raw_hash(x)) &&
	    (len == pair_raw_len(x)))
	  return(car(x));
    }
  else
    {
      for (x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x))
	if ((hash == pair_raw_hash(x)) &&
	    (len == pair_raw_len(x)) &&
	    (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */
	  return(car(x));
    }
  return(new_symbol(sc, name, len, hash, location));
}


static s7_pointer make_symbol(s7_scheme *sc, const char *name)
{
  return(make_symbol_with_length(sc, name, safe_strlen(name)));
}


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


static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, unsigned long long int hash, unsigned int location)
{
  s7_pointer x;
  for (x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x))
    if ((hash == pair_raw_hash(x)) &&
	(strings_are_equal(name, pair_raw_name(x))))
      return(car(x));
  return(sc->nil);
}


s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name)
{
  unsigned long long int hash;
  unsigned int location;
  s7_pointer result;

  hash = raw_string_hash((const unsigned char *)name, safe_strlen(name));
  location = hash % SYMBOL_TABLE_SIZE;
  result = symbol_table_find_by_name(sc, name, hash, location);
  if (is_null(result))
    return(NULL);

  return(result);
}


#define FILLED true
#define NOT_FILLED false

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

  s7_pointer lst, x;
  s7_pointer *els;
  int i, j, syms = 0;

  /* this can't be optimized by returning the actual symbol-table (a vector of lists), because
   *    gensyms can cause the table's lists and symbols to change at any time.  This wreaks havoc
   *    on traversals like for-each.  So, symbol-table returns a snap-shot of the table contents
   *    at the time it is called, and we call gc before making the list.  I suppose the next step
   *    is to check that we have room, and increase the heap here if necessary!
   *
   *    (define (for-each-symbol func num) (for-each (lambda (sym) (if (> num 0) (for-each-symbol func (- num 1)) (func sym))) (symbol-table)))
   *    (for-each-symbol (lambda (sym) (gensym) 1))
   */

  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))
      syms++;
  sc->w = make_vector_1(sc, syms, NOT_FILLED, T_VECTOR);
  els = vector_elements(sc->w);

  for (i = 0, j = 0; i < vector_length(sc->symbol_table); i++)
    for (x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x))
      els[j++] = car(x);

  lst = sc->w;
  sc->w = sc->nil;
  return(lst);
}


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


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


static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym)
{
  /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */
  s7_pointer x, name;
  unsigned int location;

  name = symbol_name_cell(sym);
  location = string_hash(name) % SYMBOL_TABLE_SIZE;
  x = vector_element(sc->symbol_table, location);

  if (car(x) == sym)
    {
      vector_element(sc->symbol_table, location) = cdr(x);
      free(x);
    }
  else
    {
      s7_pointer y;
      for (y = x, x = cdr(x); is_pair(x); y = x, x = cdr(x))
	{
	  if (car(x) == sym)
	    {
	      set_cdr(y, cdr(x));
	      free(x);
	      return;
	    }
	}
#if DEBUGGING
      fprintf(stderr, "could not remove %s?\n", string_value(name));
#endif
    }
}


s7_pointer s7_gensym(s7_scheme *sc, const char *prefix)
{
  char *name;
  unsigned int len, location;
  unsigned long long int hash;
  s7_pointer x;

  len = safe_strlen(prefix) + 32;
  tmpbuf_malloc(name, len);
  /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */
  len = snprintf(name, len, "{%s}-%u", prefix, sc->gensym_counter++);
  hash = raw_string_hash((const unsigned char *)name, len);
  location = hash % SYMBOL_TABLE_SIZE;
  x = new_symbol(sc, name, len, hash, location);  /* not T_GENSYM -- might be called from outside */
  tmpbuf_free(name, len);
  return(x);
}


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

static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args)
{
  #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym"
  #define Q_is_gensym pl_bt

  check_boolean_method(sc, s7_is_gensym, sc->is_gensym_symbol, args);
}


static char *pos_int_to_str(s7_int num, unsigned int *len, char endc)
{
  #define INT_TO_STR_SIZE 32
  static char itos[INT_TO_STR_SIZE];
  char *p, *op;

  p = (char *)(itos + INT_TO_STR_SIZE - 1);
  op = p;
  *p-- = '\0';
  if (endc != '\0') *p-- = endc;
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  (*len) = op - p;           /* this includes the trailing #\null */
  return((char *)(p + 1));
}

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

  const char *prefix;
  char *name, *p;
  unsigned int len, plen, nlen, location;
  unsigned long long int hash;
  s7_pointer x, str, stc;

  /* get symbol name */
  if (is_not_null(args))
    {
      s7_pointer name;
      name = car(args);
      if (!is_string(name))
	method_or_bust(sc, name, sc->gensym_symbol, args, T_STRING, 0);
      prefix = string_value(name);
    }
  else prefix = "gensym";
  plen = safe_strlen(prefix);
  len = plen + 32;
  name = (char *)malloc(len * sizeof(char));
  name[0] = '{';
  if (plen > 0) memcpy((void *)(name + 1), prefix, plen);
  name[plen + 1] = '}';
  name[plen + 2] = '-';

  p = pos_int_to_str(sc->gensym_counter++, &len, '\0');
  memcpy((void *)(name + plen + 3), (void *)p, len);
  nlen = len + plen + 2;

  hash = raw_string_hash((const unsigned char *)name, nlen);
  location = hash % SYMBOL_TABLE_SIZE;

  /* make-string for symbol name */
  str = (s7_cell *)malloc(sizeof(s7_cell));  /* was calloc? */
  unheap(str);
#if DEBUGGING
  typeflag(str) = 0;
#endif
  set_type(str, T_STRING | T_IMMUTABLE);
  string_length(str) = nlen;
  string_value(str) = name;
  string_needs_free(str) = false;
  string_hash(str) = hash;

  /* allocate the symbol in the heap so GC'd when inaccessible */
  new_cell(sc, x, T_SYMBOL | T_GENSYM);
  symbol_set_name_cell(x, str);
  set_global_slot(x, sc->undefined);
  set_initial_slot(x, sc->undefined);
  symbol_set_local(x, 0LL, sc->nil);

  /* 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 *)malloc(sizeof(s7_cell)); /* was calloc? */
#if DEBUGGING
  typeflag(stc) = 0;
#endif
  unheap(stc);
  set_type(stc, T_PAIR | T_IMMUTABLE);
  set_car(stc, x);
  set_cdr(stc, vector_element(sc->symbol_table, location));
  vector_element(sc->symbol_table, location) = stc;
  pair_set_raw_hash(stc, hash);
  pair_set_raw_len(stc, string_length(str));
  pair_set_raw_name(stc, string_value(str));

  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"
  #define Q_is_symbol pl_bt

  check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args);
}


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


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

  sym = car(args);
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL, 0);
  /* 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;

  sym = car(args);
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL, 0);
  return(symbol_name_cell(sym));
}


static s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer caller)
{
  if (!is_string(str))
    method_or_bust(sc, str, caller, list_1(sc, str), T_STRING, 0);
  if (string_length(str) == 0)
    return(simple_wrong_type_argument_with_type(sc, caller, str, make_string_wrapper(sc, "a non-null string")));

  /* currently if the string has an embedded null, it marks the end of the new symbol name. */
  return(make_symbol_with_length(sc, string_value(str), string_length(str)));
}


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


static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args);
static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol"
  #define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol)
  if (is_null(cdr(args)))
    return(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol));
  return(g_string_to_symbol_1(sc, g_string_append(sc, args), sc->symbol_symbol));
}


static s7_pointer add_sym_to_list(s7_scheme *sc, s7_pointer sym)
{
  symbol_set_tag(sym, sc->syms_tag);
  return(sym);
}

#define clear_syms_in_list(Sc) Sc->syms_tag++



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

#define new_frame(Sc, Old_Env, New_Env)		      \
  do {						      \
    s7_pointer _x_;				      \
      new_cell(Sc, _x_, T_LET); \
      let_id(_x_) = ++sc->let_number;		      \
      let_set_slots(_x_, Sc->nil);	              \
      set_outlet(_x_, Old_Env);	      \
      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, T_LET);
  let_id(x) = ++sc->let_number;
  let_set_slots(x, sc->nil);
  set_outlet(x, old_env);
  return(x);
}


static s7_pointer make_simple_let(s7_scheme *sc)
{
  s7_pointer frame;
  new_cell(sc, frame, T_LET);
  let_id(frame) = sc->let_number + 1;
  let_set_slots(frame, sc->nil);
  set_outlet(frame, sc->envir);
  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_, _val_;			\
    _sym_ = Symbol; _val_ = Value;			\
    new_cell_no_check(sc, _slot_, T_SLOT);\
    slot_set_symbol(_slot_, _sym_);			\
    slot_set_value(_slot_, _val_);			\
    symbol_set_local(_sym_, let_id(Frame), _slot_);	\
    set_next_slot(_slot_, let_slots(Frame));		\
    let_set_slots(Frame, _slot_);	                \
  } while (0)

#define add_slot_checked(Frame, Symbol, Value)		\
  do {							\
    s7_pointer _slot_, _sym_, _val_;			\
    _sym_ = Symbol; _val_ = Value;			\
    new_cell(sc, _slot_, T_SLOT);		        \
    slot_set_symbol(_slot_, _sym_);			\
    slot_set_value(_slot_, _val_);			\
    symbol_set_local(_sym_, let_id(Frame), _slot_);	\
    set_next_slot(_slot_, let_slots(Frame));		\
    let_set_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_, _val_;			 \
    _sym_ = Symbol; _val_ = Value;				\
    new_cell(Sc, _x_, T_LET);			                \
    let_id(_x_) = ++sc->let_number;				\
    set_outlet(_x_, Old_Env);			                \
    New_Env = _x_;						\
    new_cell_no_check(Sc, _slot_, T_SLOT);	                \
    slot_set_symbol(_slot_, _sym_);				\
    slot_set_value(_slot_, _val_);	                        \
    symbol_set_local(_sym_, sc->let_number, _slot_);            \
    set_next_slot(_slot_, sc->nil);			        \
    let_set_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_, _sym1_, _val1_, _sym2_, _val2_;		\
    _sym1_ = Symbol1; _val1_ = Value1;					\
    _sym2_ = Symbol2; _val2_ = Value2;					\
    new_cell(Sc, _x_, T_LET);				                \
    let_id(_x_) = ++sc->let_number;					\
    set_outlet(_x_, Old_Env);				                \
    New_Env = _x_;							\
    new_cell_no_check(Sc, _slot_, T_SLOT);		                \
    slot_set_symbol(_slot_, _sym1_);					\
    slot_set_value(_slot_, _val1_);					\
    symbol_set_local(_sym1_, sc->let_number, _slot_);			\
    let_set_slots(_x_, _slot_);			                        \
    new_cell_no_check(Sc, _x_, T_SLOT);			                \
    slot_set_symbol(_x_, _sym2_);					\
    slot_set_value(_x_, _val2_);					\
    symbol_set_local(_sym2_, sc->let_number, _x_);			\
    set_next_slot(_x_, sc->nil);				        \
    set_next_slot(_slot_, _x_);			                        \
  } while (0)


static s7_pointer old_frame_in_env(s7_scheme *sc, s7_pointer frame, s7_pointer next_frame)
{
  set_type(frame, T_LET);
  let_set_slots(frame, sc->nil);
  set_outlet(frame, next_frame);
  let_id(frame) = ++sc->let_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 = ++sc->let_number;
  let_id(env) = id;
  x = let_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 = ++sc->let_number;
  let_id(env) = id;
  x = let_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 = ++sc->let_number;
  let_id(env) = id;
  x = let_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();
  unheap(x);
  set_type(x, T_SLOT);
  slot_set_symbol(x, symbol);
  slot_set_value(x, value);
  return(x);
}


static s7_pointer find_let(s7_scheme *sc, s7_pointer obj)
{
  if (is_let(obj)) return(obj);
  switch (type(obj))
    {
    case T_LET:
      return(obj);

    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      return(closure_let(obj));

    case T_C_OBJECT:
      return(c_object_let(obj));
    }
  return(sc->nil);
}


static s7_pointer free_let(s7_scheme *sc, s7_pointer e)
{
  s7_pointer p;
#if DEBUGGING
  for (p = let_slots(e); is_slot(p);)
    {
      s7_pointer n;
      n = next_slot(p); /* grab it before we free p, or the type check stuff will complain */
      free_cell(sc, p);
      p = n;
    }
#else
  for (p = let_slots(e); is_slot(p); p = next_slot(p))
    free_cell(sc, p);
#endif
  free_cell(sc, e);
  return(sc->nil);
}


static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
  s7_pointer x;
  if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */
    return(sc->undefined);

  /* I think the symbol_id is in sync with let_id, so the standard search should work */
  if (let_id(env) == symbol_id(symbol))
    return(slot_value(local_slot(symbol)));

  for (x = env; symbol_id(symbol) < let_id(x); x = outlet(x));

  if (let_id(x) == symbol_id(symbol))
    return(slot_value(local_slot(symbol)));

  for (; is_let(x); x = outlet(x))
    {
      s7_pointer y;
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == symbol)
	  return(slot_value(y));
    }
  return(sc->undefined);
}


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

  if (e == sc->rootlet)
    return(sc->rootlet_entries);

  if (has_methods(e))
    {
      s7_pointer length_func;
      length_func = find_method(sc, e, sc->length_symbol);
      if (length_func != sc->undefined)
	{
	  p = s7_apply_function(sc, length_func, list_1(sc, e));
	  if (s7_is_integer(p))
	    return((int)s7_integer(p));
	  return(-1); /* ?? */
	}
    }

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


static s7_pointer make_slot_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
  /* env is not rootlet and is a let */
  s7_pointer slot;
  new_cell(sc, slot, T_SLOT);
  slot_set_symbol(slot, symbol);
  slot_set_value(slot, value);
  set_next_slot(slot, let_slots(env));
  let_set_slots(env, slot);
  set_local(symbol);
  /* this is called by varlet so we have to be careful about the resultant let_id
   *   check for greater to ensure shadowing stays in effect, and equal to do updates (set! in effect)
   */
  if (let_id(env) >= symbol_id(symbol))
    symbol_set_local(symbol, let_id(env), slot);
  return(slot);
}


s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
  if ((!is_let(env)) ||
      (env == sc->rootlet))
    {
      s7_pointer ge, slot;

      if ((sc->safety == 0) && (has_closure_let(value)))
	{
	  s7_remove_from_heap(sc, closure_args(value));
	  s7_remove_from_heap(sc, closure_body(value));
	}

      /* first look for existing slot -- this is not always checked before calling s7_make_slot */
      if (is_slot(global_slot(symbol)))
	{
	  slot = global_slot(symbol);
	  slot_set_value(slot, value);
	  return(slot);
	}

      ge = sc->rootlet;
      slot = permanent_slot(symbol, value);
      vector_element(ge, sc->rootlet_entries++) = slot;
      if (sc->rootlet_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->rootlet_entries; i < vector_length(ge); i++)
	    vector_element(ge, i) = sc->nil;
	}
      set_global_slot(symbol, slot);
      
      if (symbol_id(symbol) == 0) /* never defined locally? */
	{
	  if (initial_slot(symbol) == sc->undefined)
	    set_initial_slot(symbol, permanent_slot(symbol, value));
	  set_local_slot(symbol, slot);
	  set_global(symbol);
	}
      if (is_gensym(symbol))
	s7_remove_from_heap(sc, symbol);
      return(slot);
    }

  return(make_slot_1(sc, env, symbol, value));
  /* 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.
   */
}


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, T_SLOT);
  slot_set_symbol(y, variable);
  if (!is_symbol(variable)) abort();
  slot_set_value(y, value);
  return(y);
}


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

static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args)
{
  #define H_is_let "(let? obj) returns #t if obj is a let (an environment)."
  #define Q_is_let pl_bt

  check_boolean_method(sc, is_let, sc->is_let_symbol, args);
}


/* -------------------------------- unlet -------------------------------- */
#define UNLET_ENTRIES 410 /* 401 if not --disable-deprecated etc */

static void save_unlet(s7_scheme *sc)
{
  int i, k = 0;
  s7_pointer x;
  s7_pointer *inits;

  sc->unlet = (s7_pointer)calloc(1, sizeof(s7_cell));
  set_type(sc->unlet, T_VECTOR);
  vector_length(sc->unlet) = UNLET_ENTRIES;
  vector_elements(sc->unlet) = (s7_pointer *)malloc(UNLET_ENTRIES * sizeof(s7_pointer));
  vector_getter(sc->unlet) = default_vector_getter;
  vector_setter(sc->unlet) = default_vector_setter;
  inits = vector_elements(sc->unlet);
  s7_vector_fill(sc, sc->unlet, sc->nil);
  unheap(sc->unlet);

  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;
	sym = car(x);
	if (is_slot(initial_slot(sym)))
	  {
	    s7_pointer val;
	    val = slot_value(initial_slot(sym));
	    if ((is_procedure(val)) || (is_syntax(val)))
	      inits[k++] = initial_slot(sym);

	    /* (let ((begin +)) (with-let (unlet) (begin 1 2))) */
#if DEBUGGING
	    if (k >= UNLET_ENTRIES)
	      fprintf(stderr, "unlet overflow\n");
#endif
	  }
      }
}

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

  /* slightly confusing:
   *    :((unlet) 'abs)
   *    #<undefined>
   *    :(defined? 'abs (unlet))
   *    #t
   * this is because unlet sets up a local environment of unshadowed symbols,
   *   and s7_let_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).
   *
   * Also (define hi 3) #_hi => 3, (set! hi 4), #_hi -> 3 but (with-let (unlet) hi) -> 4!
   */
  int i;
  s7_pointer *inits;
  s7_pointer x;

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

  for (i = 0; (i < UNLET_ENTRIES) && (is_slot(inits[i])); i++)
    {
      s7_pointer sym;
      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 */
	    make_slot_1(sc, sc->w, sym, x);
	}
      else
	{
	  if ((is_syntax(x)) &&
	      (local_slot(sym) != sc->nil))          /* this can be a freed cell, will be nil if unchanged */
	    make_slot_1(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-let (unlet) (+ x 1)))
   */

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


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

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

  /* if car(args) is not a let (or possibly have one), should this raise an error? */
  check_method(sc, car(args), sc->is_openlet_symbol, args);
  return(make_boolean(sc, has_methods(car(args))));
}


/* -------------------------------- openlet -------------------------------- */
s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e)
{
  set_has_methods(e);
  return(e);
}

static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args)
{
  #define H_openlet "(openlet e) tells the built-in generic functions that the environment 'e might have an over-riding method."
  #define Q_openlet pcl_t
  s7_pointer e;

  e = car(args);
  check_method(sc, e, sc->openlet_symbol, args);
  if (((is_let(e)) && (e != sc->rootlet)) ||
      (has_closure_let(e)) ||
      ((is_c_object(e)) && (c_object_let(e) != sc->nil)))
    {
      set_has_methods(e);
      return(e);
    }
  return(simple_wrong_type_argument_with_type(sc, sc->openlet_symbol, e, a_let_string));
}


/* -------------------------------- coverlet -------------------------------- */
static s7_pointer c_coverlet(s7_scheme *sc, s7_pointer e)
{
  sc->temp3 = e;
  check_method(sc, e, sc->coverlet_symbol, list_1(sc, e));
  if (((is_let(e)) && (e != sc->rootlet)) ||
      (has_closure_let(e)) ||
      ((is_c_object(e)) && (c_object_let(e) != sc->nil)))
    {
      clear_has_methods(e);
      return(e);
    }
  return(simple_wrong_type_argument_with_type(sc, sc->coverlet_symbol, e, a_let_string));
}

static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args)
{
  #define H_coverlet "(coverlet e) undoes an earlier openlet."
  #define Q_coverlet pcl_t
  return(c_coverlet(sc, car(args)));
}


/* -------------------------------- varlet -------------------------------- */
static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e)
{
  s7_pointer x;

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

  if (new_e != sc->rootlet)
    {
      for (x = let_slots(old_e); is_slot(x); x = next_slot(x))
	make_slot_1(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */
    }
  else
    {
      for (x = let_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);
	}
    }
}

static s7_pointer check_c_obj_env(s7_scheme *sc, s7_pointer old_e, s7_pointer caller)
{
  if (is_c_object(old_e))
    old_e = c_object_let(old_e);
  if (!is_let(old_e))
    return(simple_wrong_type_argument_with_type(sc, caller, old_e, a_let_string));
  return(old_e);
}


s7_pointer s7_varlet(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
  if (!is_let(env))
    return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 1, env, a_let_string));

  if (!is_symbol(symbol))
    return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 2, symbol, a_symbol_string));

  if (env == sc->rootlet)
    {
      if (is_slot(global_slot(symbol)))
	{
	  if (is_syntax(slot_value(global_slot(symbol))))
		return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 2, symbol, make_string_wrapper(sc, "a non-syntactic keyword")));
	  slot_set_value(global_slot(symbol), value);
	}
      else s7_make_slot(sc, env, symbol, value);
    }
  else make_slot_1(sc, env, symbol, value);
  return(value);
}


static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args)
{
  #define H_varlet "(varlet env ...) adds its arguments (an environment, a cons: symbol . value, or a pair of arguments, the symbol and its value) \
to the environment env, and returns the environment."
  #define Q_varlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->T)
  /* varlet = with-let + define */

  s7_pointer x, e, sym, val, p;

  e = car(args);
  if (is_null(e))
    e = sc->rootlet;
  else
    {
      check_method(sc, e, sc->varlet_symbol, args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 1, e, a_let_string));
    }

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      p = car(x);
      switch (type(p))
	{
	case T_SYMBOL:
	  if (is_keyword(p))
	    sym = keyword_symbol(p);
	  else sym = p;
	  if (!is_pair(cdr(x)))
	    return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_binding_string));
	  x = cdr(x);
	  val = car(x);
	  break;

	case T_PAIR:
	  sym = car(p);
	  if (!is_symbol(sym))
	    return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string));
	  val = cdr(p);
	  break;

	case T_LET:
	  append_let(sc, e, check_c_obj_env(sc, p, sc->varlet_symbol));
	  continue;

	default:
	  return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string));
	}

      if (is_immutable_symbol(sym))
	return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string));

      if (e == sc->rootlet)
	{
	  if (is_slot(global_slot(sym)))
	    {
	      if (is_syntax(slot_value(global_slot(sym))))
		return(wrong_type_argument_with_type(sc, sc->varlet_symbol, position_of(x, args), p, make_string_wrapper(sc, "a non-syntactic keyword")));
	      /*  without this check we can end up turning our code into gibberish:
	       *   :(set! quote 1)
	       *   ;can't set! quote
	       *   :(varlet (rootlet) '(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), val);
	    }
	  else s7_make_slot(sc, e, sym, val);
	}
      else make_slot_1(sc, e, sym, val);
      /* this used to check for sym already defined, and set its value, but that greatly slows down
       *   the most common use (adding a slot), and makes it hard to shadow explicitly.  Don't use
       *   varlet as a substitute for set!/let-set!.
       */
    }
  return(e);
}


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

  s7_pointer e, syms;
  #define THE_UN_ID ++sc->let_number

  e = car(args);
  if (is_null(e))
    e = sc->rootlet;
  else
    {
      check_method(sc, e, sc->cutlet_symbol, args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->cutlet_symbol, 1, e, a_let_string));
    }
  /* besides removing the slot we have to make sure the symbol_id does not match else
   *   let-ref and others will use the old slot!  What's the un-id?  Perhaps the next one?
   *   (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b)
   */
  for (syms = cdr(args); is_pair(syms); syms = cdr(syms))
    {
      s7_pointer sym, slot;
      sym = car(syms);

      if (!is_symbol(sym))
	return(wrong_type_argument_with_type(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string));

      if (is_keyword(sym))
	sym = keyword_symbol(sym);

      if (e == sc->rootlet)
	{
	  if (is_slot(global_slot(sym)))
	    {
	      symbol_set_id(sym, THE_UN_ID);
	      slot_set_value(global_slot(sym), sc->undefined);
	    }
	}
      else
	{
	  slot = let_slots(e);
	  if (is_slot(slot))
	    {
	      if (slot_symbol(slot) == sym)
		{
		  let_set_slots(e, next_slot(let_slots(e)));
		  symbol_set_id(sym, THE_UN_ID);
		}
	      else
		{
		  s7_pointer last_slot;
		  last_slot = slot;
		  for (slot = next_slot(let_slots(e)); is_slot(slot); last_slot = slot, slot = next_slot(slot))
		    {
		      if (slot_symbol(slot) == sym)
			{
			  symbol_set_id(sym, THE_UN_ID);
			  set_next_slot(last_slot, next_slot(slot));
			  break; 
			}
		    }
		}
	    }
	}
    }
  return(e);
}


/* -------------------------------- sublet -------------------------------- */
static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_pointer caller)
{
  s7_pointer new_e;

  if (e == sc->rootlet)
    new_e = new_frame_in_env(sc, sc->nil);
  else new_e = new_frame_in_env(sc, e);
  set_all_methods(new_e, e);

  if (!is_null(bindings))
    {
      s7_pointer x;
      sc->temp3 = new_e;

      for (x = bindings; is_not_null(x); x = cdr(x))
	{
	  s7_pointer p, sym, val;

	  p = car(x);
	  switch (type(p))
	    {
	    case T_SYMBOL:
	      if (is_keyword(p))
		sym = keyword_symbol(p);
	      else sym = p;
	      if (!is_pair(cdr(x)))
		return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_binding_string));
	      x = cdr(x);
	      val = car(x);
	      break;

	    case T_PAIR:
	      sym = car(p);
	      if (!is_symbol(sym))
		return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
	      val = cdr(p);
	      break;

	    case T_LET:
	      append_let(sc, new_e, check_c_obj_env(sc, p, caller));
	      continue;

	    default:
	      return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
	    }

	  if (is_immutable_symbol(sym))
	    return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), sym, a_non_constant_symbol_string));

	  /* here we know new_e is a let and is not rootlet */
	  make_slot_1(sc, new_e, sym, val);
	  if (sym == sc->let_ref_fallback_symbol)
	    set_has_ref_fallback(new_e);
	  else
	    {
	      if (sym == sc->let_set_fallback_symbol)
		set_has_set_fallback(new_e);
	    }
	}
      sc->temp3 = sc->nil;
    }
  return(new_e);
}

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

static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args)
{
  #define H_sublet "(sublet env ...) adds its \
arguments (each an environment or a cons: symbol . value) to the environment env, and returns the \
new environment."
  #define Q_sublet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), sc->T)

  s7_pointer e;

  e = car(args);
  if (is_null(e))
    e = sc->rootlet;
  else
    {
      check_method(sc, e, sc->sublet_symbol, args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->sublet_symbol, 1, e, a_let_string));
    }
  return(sublet_1(sc, e, cdr(args), sc->sublet_symbol));
}


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

  return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol));
}

#define g_inlet s7_inlet


/* -------------------------------- let->list -------------------------------- */
s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env)
{
  s7_pointer x;

  sc->temp3 = sc->w;
  sc->w = sc->nil;

  if (env == sc->rootlet)
    {
      unsigned int i, lim2;
      s7_pointer *entries;

      entries = vector_elements(env);
      lim2 = sc->rootlet_entries;
      if (lim2 & 1) lim2--;

      for (i = 0; i < lim2; )
	{
	  sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++;
	  sc->w = cons_unchecked(sc, cons_unchecked(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++;
	}
      if (lim2 < sc->rootlet_entries)
	sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w);
    }
  else
    {
      s7_pointer iter, func;
      /* need to check make-iterator method before dropping into let->list */

      if ((has_methods(env)) && ((func = find_method(sc, env, sc->make_iterator_symbol)) != sc->undefined))
	iter = s7_apply_function(sc, func, list_1(sc, env));
      else iter = sc->nil;

      if (is_null(iter))
	{
	  for (x = let_slots(env); is_slot(x); x = next_slot(x))
	    sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w);
	}
      else
	{
	  /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */
	  while (true)
	    {
	      x = s7_iterate(sc, iter);
	      if (iterator_is_at_end(iter)) break;
	      sc->w = cons(sc, x, sc->w);
	    }
	  sc->w = safe_reverse_in_place(sc, sc->w);
	}
    }
  x = sc->w;
  sc->w = sc->temp3;
  sc->temp3 = sc->nil;
  return(x);
}

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

  s7_pointer env;
  env = car(args);
  check_method(sc, env, sc->let_to_list_symbol, args);
  if (!is_let(env))
    {
      if (is_c_object(env))
	env = c_object_let(env);
      if (!is_let(env))
        return(simple_wrong_type_argument_with_type(sc, sc->let_to_list_symbol, env, a_let_string));
    }
  return(s7_let_to_list(sc, env));
}
#endif


/* -------------------------------- let-ref -------------------------------- */
static s7_pointer let_ref_1(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
  s7_pointer x, y;
  /* (let ((a 1)) ((curlet) 'a))
   * ((rootlet) 'abs)
   */
  if (is_keyword(symbol))
    symbol = keyword_symbol(symbol);

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

  if (let_id(env) == symbol_id(symbol))
    return(slot_value(local_slot(symbol))); /* this obviously has to follow the global-env check */

  for (x = env; is_let(x); x = outlet(x))
    for (y = let_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	return(slot_value(y));

  /* now for a horrible kludge.  If a let is a mock-hash-table (for example), implicit
   *   indexing of the hash-table collides with the same thing for the let (field names
   *   versus keys), and we can't just try again here because that makes it too easy to
   *   get into infinite recursion.  So, 'let-ref-fallback...
   */
  if (has_ref_fallback(env))
    check_method(sc, env, sc->let_ref_fallback_symbol, sc->w = list_2(sc, env, symbol));

  /* why did this ignore a global value? Changed 24-May-16 to check rootlet if no methods --
   *   apparently I was using #<undefined> here (pre-rootlet-check) to indicate that an
   *   open let did not have a particular method (locally).  This seems inconsistent now,
   *   but it was far worse before.  At least (let () ((curlet) 'pi)) is pi!
   */
  if (!has_methods(env))
    {
      y = global_slot(symbol);
      if (is_slot(y))
	return(slot_value(y));
    }

  return(sc->undefined);
}

s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
{
  if (!is_let(env))
    return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, env, a_let_string));
    
  if (!is_symbol(symbol))
    {
      check_method(sc, env, sc->let_ref_symbol, sc->w = list_2(sc, env, symbol));
      if (has_ref_fallback(env))
	check_method(sc, env, sc->let_ref_fallback_symbol, sc->w = list_2(sc, env, symbol));
      return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string));
    }
  return(let_ref_1(sc, env, symbol));
}

static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_let_ref "(let-ref env sym) returns the value of the symbol sym in the environment env"
  #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
  s7_pointer e, s;

  e = car(args);
  if (!is_let(e))
    return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, e, a_let_string));

  s = cadr(args);
  if (!is_symbol(s))
    {
      check_method(sc, e, sc->let_ref_symbol, args);
      if (has_ref_fallback(e))
	check_method(sc, e, sc->let_ref_fallback_symbol, args);
      return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, s, a_symbol_string));
    }
  return(let_ref_1(sc, e, s));
}


/* -------------------------------- let-set! -------------------------------- */
static s7_pointer call_accessor(s7_scheme *sc, s7_pointer slot, s7_pointer old_value)
{
  s7_pointer func, new_value;

  /* new_value = sc->error_symbol; */
  func = slot_accessor(slot);

  if (is_procedure_or_macro(func))
    {
      if (is_c_function(func))
	{
	  set_car(sc->t2_1, slot_symbol(slot));
	  set_car(sc->t2_2, old_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, slot_symbol(slot), old_value));
	  sc->gc_off = old_off;
	}
    }
  else return(old_value);

  if (new_value == sc->error_symbol)
    return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't set! ~S to ~S"), slot_symbol(slot), old_value)));
  return(new_value);
}

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

  if (is_keyword(symbol))
    symbol = keyword_symbol(symbol);

  if (env == sc->rootlet)
    {
      if (is_immutable_symbol(symbol))  /* (let-set! (rootlet) :rest #f) */
	return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string));
      y = global_slot(symbol);
      if (is_slot(y))
	{
	  if (slot_has_accessor(y))
	    slot_set_value(y, call_accessor(sc, y, value));
	  else slot_set_value(y, value);
	  return(slot_value(y));
	}
      return(sc->undefined);
    }

  for (x = env; is_let(x); x = outlet(x))
    for (y = let_slots(x); is_slot(y); y = next_slot(y))
      if (slot_symbol(y) == symbol)
	{
	  if (slot_has_accessor(y))
	    slot_set_value(y, call_accessor(sc, y, value));
	  else slot_set_value(y, value);
	  return(slot_value(y));
	}

  if (has_set_fallback(env))
    check_method(sc, env, sc->let_set_fallback_symbol, sc->w = list_3(sc, env, symbol, value));

  if (!has_methods(env))
    {
      y = global_slot(symbol);
      if (is_slot(y))
	{
	  if (slot_has_accessor(y))
	    slot_set_value(y, call_accessor(sc, y, value));
	  else slot_set_value(y, value);
	  return(slot_value(y));
	}
    }
  return(sc->undefined);
}

s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value)
{
  if (!is_let(env))
    return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, env, a_let_string));

  if (!is_symbol(symbol))
    {
      check_method(sc, env, sc->let_set_symbol, sc->w = list_3(sc, env, symbol, value));
      if (has_set_fallback(env))
	check_method(sc, env, sc->let_set_fallback_symbol, sc->w = list_3(sc, env, symbol, value));
      return(wrong_type_argument_with_type(sc, sc->let_set_symbol, 2, symbol, a_symbol_string));
    }

  return(let_set_1(sc, env, symbol, value));
}

static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args)
{
  /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */
  #define H_let_set "(let-set! env sym val) sets the symbol sym's value in the environment env to val"
  #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T)

  return(s7_let_set(sc, car(args), cadr(args), 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);
      set_next_slot(p, result);
      result = p;
      p = q;
    }
  return(result);
}


static s7_pointer let_copy(s7_scheme *sc, s7_pointer env)
{
  if (is_let(env))
    {
      s7_pointer new_e;

      if (env == sc->rootlet)   /* (copy (rootlet)) or (copy (funclet abs)) etc */
	return(sc->rootlet);

      /* 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.
       */
      new_e = new_frame_in_env(sc, outlet(env));
      set_all_methods(new_e, env);
      sc->temp3 = new_e;
      if (is_slot(let_slots(env)))
	{
	  s7_int id;
	  s7_pointer x, y = NULL;

	  id = let_id(new_e);
	  for (x = let_slots(env); is_slot(x); x = next_slot(x))
	    {
	      s7_pointer z;
	      new_cell(sc, z, T_SLOT);
	      slot_set_symbol(z, slot_symbol(x));
	      slot_set_value(z, slot_value(x));
	      if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */
		symbol_set_local(slot_symbol(x), id, z);
	      if (is_slot(let_slots(new_e)))
		set_next_slot(y, z);
	      else let_set_slots(new_e, z);
	      set_next_slot(z, sc->nil);              /* in case GC runs during this loop */
	      y = z;
	    }
	}
      /* We can't do a (normal) loop here then reverse the slots later because the symbol's local_slot has to
       *    match the unshadowed slot, not the last in the list:
       *    (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a)))))
       */
      sc->temp3 = sc->nil;
      return(new_e);
    }
  return(sc->nil);
}


/* -------------------------------- rootlet -------------------------------- */
static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer ignore)
{
  #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)."
  #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol)
  return(sc->rootlet);
}
/* as with the symbol-table, this function can lead to disaster -- user could
 *   clobber the environment etc.  But we want it to be editable and augmentable,
 *   so I guess I'll leave it alone.  (See curlet|funclet as well).
 */

s7_pointer s7_rootlet(s7_scheme *sc)
{
  return(sc->rootlet);
}

s7_pointer s7_shadow_rootlet(s7_scheme *sc)
{
  return(sc->shadow_rootlet);
}

s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let)
{
  sc->shadow_rootlet = let;
  return(let);
}


/* -------------------------------- curlet -------------------------------- */
static s7_pointer g_curlet(s7_scheme *sc, s7_pointer args)
{
  #define H_curlet "(curlet) returns the current definitions (symbol bindings)"
  #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol)

  sc->capture_let_counter++;
  if (is_let(sc->envir))
    return(sc->envir);
  return(sc->rootlet);
}

s7_pointer s7_curlet(s7_scheme *sc)
{
  sc->capture_let_counter++;
  return(sc->envir);
}

s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e)
{
  s7_pointer p, old_e;
  old_e = sc->envir;
  sc->envir = e;

  if ((is_let(e)) && (let_id(e) > 0)) /* might be () [id=-1] or rootlet [id=0] etc */
    {
      let_id(e) = ++sc->let_number;
      for (p = let_slots(e); is_slot(p); p = next_slot(p))
	{
	  s7_pointer sym;
	  sym = slot_symbol(p);
	  if (symbol_id(sym) != sc->let_number)
	    symbol_set_local(sym, sc->let_number, p);
	}
    }

  return(old_e);
}


/* -------------------------------- outlet -------------------------------- */
s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e)
{
  return(outlet(e));
}

static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args)
{
  #define H_outlet "(outlet env) is the environment that contains env."
  #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol)

  s7_pointer env;
  env = car(args);
  if (!is_let(env))
    method_or_bust_with_type(sc, env, sc->outlet_symbol, args, a_let_string, 0);

  if ((env == sc->rootlet) ||
      (is_null(outlet(env))))
    return(sc->rootlet);
  return(outlet(env));
}

static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args)
{
  /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */
  s7_pointer env, new_outer;

  env = car(args);
  if (!is_let(env))
    return(s7_wrong_type_arg_error(sc, "set! outlet", 1, env, "a let"));

  new_outer = cadr(args);
  if (!is_let(new_outer))
    return(s7_wrong_type_arg_error(sc, "set! outlet", 2, new_outer, "a let"));
  if (new_outer == sc->rootlet)
    new_outer = sc->nil;

  if (env != sc->rootlet)
    set_outlet(env, new_outer);
  return(new_outer);
}



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

  if (let_id(sc->envir) == symbol_id(symbol))
    return(local_slot(symbol));

  for (x = sc->envir; symbol_id(symbol) < let_id(x); x = outlet(x));

  if (let_id(x) == symbol_id(symbol))
    return(local_slot(symbol));

  for (; is_let(x); x = outlet(x))
    {
      s7_pointer y;
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == symbol)
	  return(y);
    }

  return(global_slot(symbol));
}

#if WITH_GCC && DEBUGGING
static s7_pointer find_symbol_unchecked_1(s7_scheme *sc, s7_pointer symbol)
#else
static s7_pointer find_symbol_unchecked(s7_scheme *sc, s7_pointer symbol) /* find_symbol_checked includes the unbound_variable call */
#endif
{
  s7_pointer x;
  
  /* fprintf(stderr, "let_id: %lld, %s id: %lld\n", let_id(sc->envir), DISPLAY(symbol), symbol_id(symbol)); */

  if (let_id(sc->envir) == symbol_id(symbol))
    return(slot_value(local_slot(symbol)));

  for (x = sc->envir; symbol_id(symbol) < let_id(x); x = outlet(x));

  /* this looks redundant, but every attempt to improve it is much slower! */
  if (let_id(x) == symbol_id(symbol))
    return(slot_value(local_slot(symbol)));

  for (; is_let(x); x = outlet(x))
    {
      s7_pointer y;
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == symbol)
	  return(slot_value(y));
    }

  x = global_slot(symbol);
  if (is_slot(x))
    return(slot_value(x));

#if WITH_GCC
  return(NULL);
#else
  return(unbound_variable(sc, symbol));
#endif
}


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


void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value)
{
  set_real(slot_value(slot), value);
}


s7_double s7_slot_real_value(s7_scheme *sc, s7_pointer slot, const char *caller)
{
  return(real_to_double(sc, slot_value(slot), caller));
}

s7_int s7_slot_integer_value(s7_pointer slot)
{
  return(integer(slot_value(slot)));
}


static s7_pointer find_local_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  if (!is_let(e))
    return(global_slot(symbol));

  if (symbol_id(symbol) != 0)
    {
      s7_pointer y;
      for (y = let_slots(e); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == symbol)
	  return(y);
    }
  return(sc->undefined);
}


static s7_pointer s7_local_slot(s7_scheme *sc, s7_pointer symbol)
{
  s7_pointer y;
  for (y = let_slots(sc->envir); 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)
{
  s7_pointer x;

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

  return(sc->undefined);
}


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


/* -------------------------------- symbol->value -------------------------------- */

#define find_global_symbol_checked(Sc, Sym) ((is_global(Sym)) ? slot_value(global_slot(Sym)) : find_symbol_checked(Sc, Sym))

static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_value "(symbol->value sym (env (curlet))) returns the binding of (the value associated with) the \
symbol sym in the given environment: (let ((x 32)) (symbol->value 'x)) -> 32"
  #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
  /* (symbol->value 'x e) => (e 'x)? */

  s7_pointer sym;
  sym = car(args);

  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, T_SYMBOL, 1);

  if (is_not_null(cdr(args)))
    {
      s7_pointer local_env;

      local_env = cadr(args);
      if (local_env == sc->unlet_symbol)
	return((is_slot(initial_slot(sym))) ? slot_value(initial_slot(sym)) : sc->undefined);

      if (!is_let(local_env))
	method_or_bust_with_type(sc, local_env, sc->symbol_to_value_symbol, args, a_let_string, 2);

      if (local_env == sc->rootlet)
	{
	  s7_pointer x;
	  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);
}


/* -------------------------------- symbol->dynamic-value -------------------------------- */

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

  if (let_id(x) == symbol_id(sym))
    {
      (*id) = let_id(x);
      return(slot_value(local_slot(sym)));
    }
  for (; (is_let(x)) && (let_id(x) > (*id)); x = outlet(x))
    {
      s7_pointer y;
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == sym)
	  {
	    (*id) = let_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"
  #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)

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

  sym = car(args);
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, T_SYMBOL, 1);

  if (is_global(sym))
    return(slot_value(global_slot(sym)));

  if (let_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_let(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);
}


typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer e);
static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_sym_t *checker);

static bool direct_memq(s7_pointer symbol, s7_pointer symbols)
{
  s7_pointer x;
  for (x = symbols; is_pair(x); x = unchecked_cdr(x))
    {
      if (car(x) == symbol)
	return(true);
      x = cdr(x);
      if (unchecked_car(x) == symbol)
	return(true);
    }
  return(false);
}

static bool indirect_memq(s7_pointer symbol, s7_pointer symbols)
{ /* used only below in do_symbol_is_safe */
  s7_pointer x;
  for (x = symbols; is_pair(x); x = cdr(x))
    if (caar(x) == symbol)
      return(true);
  return(false);
}

static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e)
{
  return((is_slot(global_slot(sym))) || 
	 (indirect_memq(sym, e)) ||
	 (is_slot(find_symbol(sc, sym))));
}

static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e)
{
  return((is_slot(global_slot(sym))) || ((!is_with_let_let(e)) && (is_slot(find_symbol(sc, sym)))));
}

static bool pair_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e)
{
  return((is_slot(global_slot(sym))) || (direct_memq(sym, e)));
}


/* make macros and closures */

static s7_pointer make_macro(s7_scheme *sc)
{
  s7_pointer cx, mac;
  unsigned int typ;

  if (sc->op == OP_DEFINE_MACRO)
    typ = T_MACRO | T_DONT_EVAL_ARGS | T_COPY_ARGS;
  else
    {
      if (sc->op == OP_DEFINE_MACRO_STAR)
	typ = T_MACRO_STAR | T_DONT_EVAL_ARGS | T_COPY_ARGS;
      else
	{
	  if (sc->op == OP_DEFINE_BACRO)
	    typ = T_BACRO | T_DONT_EVAL_ARGS | T_COPY_ARGS;
	  else
	    {
	      if (sc->op == OP_DEFINE_BACRO_STAR)
		typ = T_BACRO_STAR | T_DONT_EVAL_ARGS | T_COPY_ARGS;
	      else
		{
		  if ((sc->op == OP_DEFINE_EXPANSION) &&
		      (!is_let(sc->envir)))        /* local expansions are just normal macros */
		    typ = T_MACRO | T_EXPANSION | T_DONT_EVAL_ARGS | T_COPY_ARGS;
		  else typ = T_MACRO | T_DONT_EVAL_ARGS | T_COPY_ARGS;
		}
	    }
	}
    }

  new_cell_no_check(sc, mac, typ);
  sc->temp6 = mac;
  closure_set_args(mac, cdar(sc->code));
  closure_set_body(mac, cdr(sc->code));
  closure_set_setter(mac, sc->F);
  closure_set_let(mac, sc->envir);
  closure_arity(mac) = CLOSURE_ARITY_NOT_SET;

  sc->capture_let_counter++;
  sc->code = caar(sc->code);
  if ((sc->op == OP_DEFINE_EXPANSION) &&
      (!is_let(sc->envir)))
    set_type(sc->code, T_EXPANSION | T_SYMBOL); /* see comment under READ_TOK */
  /* symbol? macro name has already been checked, find name in environment, and define it */
  cx = find_local_symbol(sc, sc->code, sc->envir);
  if (is_slot(cx))
    slot_set_value(cx, mac);
  else s7_make_slot(sc, sc->envir, sc->code, mac); /* was current but we've checked immutable already */

  optimize(sc, closure_body(mac), 0, sc->nil);
  sc->temp6 = sc->nil;
  return(mac);
}


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;
  unsigned int typ;

  if (is_safe_closure(code))
    {
      if (type == T_CLOSURE)
	typ = T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS;
      else typ = T_CLOSURE_STAR | T_PROCEDURE | T_SAFE_CLOSURE;
    }
  else
    {
      if (type == T_CLOSURE)
	typ = T_CLOSURE | T_PROCEDURE | T_COPY_ARGS;
      else typ = T_CLOSURE_STAR | T_PROCEDURE;
    }

  new_cell(sc, x, typ);
  closure_set_args(x, args);
  closure_set_body(x, code);
  closure_set_setter(x, sc->F);
  if (is_null(args))
    closure_arity(x) = 0;
  else closure_arity(x) = CLOSURE_ARITY_NOT_SET;
  closure_set_let(x, sc->envir);
  sc->capture_let_counter++;
  return(x);
}


#define make_closure_with_let(Sc, X, Args, Code, Env)	\
  do {							\
    unsigned int _T_;							\
    if (is_safe_closure(Code))						\
      _T_ = T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS;	\
    else _T_ = T_CLOSURE | T_PROCEDURE | T_COPY_ARGS;			\
    new_cell(Sc, X, _T_);						\
    closure_set_args(X, Args);						\
    closure_set_body(X, Code);				                \
    closure_set_setter(X, sc->F);					\
    if (is_null(Args)) closure_arity(X) = 0; else closure_arity(X) = CLOSURE_ARITY_NOT_SET; \
    closure_set_let(X, Env); \
    sc->capture_let_counter++;						\
  } while (0)


#define make_closure_without_capture(Sc, X, Args, Code, Env)	\
  do {								\
    unsigned int _T_;							\
    if (is_safe_closure(Code))						\
      _T_ = T_CLOSURE | T_PROCEDURE | T_SAFE_CLOSURE | T_COPY_ARGS;	\
    else _T_ = T_CLOSURE | T_PROCEDURE | T_COPY_ARGS;			\
    new_cell(Sc, X, _T_);						\
    closure_set_args(X, Args);						\
    closure_set_body(X, Code);				                \
    closure_set_setter(X, sc->F);					\
    if (is_null(Args)) closure_arity(X) = 0; else closure_arity(X) = CLOSURE_ARITY_NOT_SET; \
    closure_set_let(X, Env); \
  } while (0)


static int closure_length(s7_scheme *sc, s7_pointer e)
{
  /* we can't use let_length(sc, closure_let(e)) because the closure_let(closure)
   *   changes.  So the open bit is not always on.  Besides, the fallbacks need to be for closures, not environments.
   */
  s7_pointer length_func;
  length_func = find_method(sc, closure_let(e), sc->length_symbol);
  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);
}

#define check_closure_for(Sc, Fnc, Sym)				    \
  if ((has_closure_let(Fnc)) && (is_let(closure_let(Fnc))))	    \
    {								    \
      s7_pointer val;						    \
      val = find_local_symbol(Sc, Sym, closure_let(Fnc));	    \
      if ((!is_slot(val)) && (is_let(outlet(closure_let(Fnc)))))    \
	val = find_local_symbol(Sc, Sym, outlet(closure_let(Fnc))); \
      if (is_slot(val))						    \
	return(slot_value(val));				    \
    }

static s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree)
{
#if WITH_GCC
  #define COPY_TREE(P) ({s7_pointer _p; _p = P; cons_unchecked(sc, (is_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), (is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));})
#else
  #define COPY_TREE(P) copy_tree(sc, P)
#endif

  return(cons_unchecked(sc, 
			(is_pair(car(tree))) ? COPY_TREE(car(tree)) : car(tree),
			(is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree)));
}

static void annotate_expansion(s7_pointer p)
{
  if ((is_symbol(car(p))) &&
      (is_pair(cdr(p))))
    {
      set_opt_back(p);
      set_overlay(cdr(p));
    }
  else
    {
      if (is_pair(car(p)))
	annotate_expansion(car(p));
    }
  for (p = cdr(p); is_pair(p); p = cdr(p))
    if (is_pair(car(p)))
      annotate_expansion(car(p));
}

static s7_pointer copy_body(s7_scheme *sc, s7_pointer p)
{
  if (8192 >= (sc->free_heap_top - sc->free_heap))
    {
      gc(sc);
      while (8192 >= (sc->free_heap_top - sc->free_heap))
	resize_heap(sc);
    }
  sc->w = copy_tree(sc, p);
  annotate_expansion(sc->w);
  p = sc->w;
  sc->w = sc->nil;
  return(p);
}

static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc)
{
  /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */
  s7_pointer x, body;

  body = copy_body(sc, closure_body(fnc));
  new_cell(sc, x, typeflag(fnc));
  closure_set_args(x, closure_args(fnc));
  closure_set_body(x, body);
  closure_set_setter(x, closure_setter(fnc));
  closure_arity(x) = closure_arity(fnc);
  closure_set_let(x, closure_let(fnc));
  return(x);
}

/* -------------------------------- defined? -------------------------------- */
static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
{
  #define H_is_defined "(defined? obj (env (curlet)) ignore-globals) returns #t if obj has a binding (a value) in the environment env"
  #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, sc->is_let_symbol, sc->is_boolean_symbol)

  s7_pointer sym;

  /* is this correct?
   *    (defined? '_x) #f (symbol->value '_x) #<undefined>
   *    (define x #<undefined>) (defined? 'x) #t
   */

  sym = car(args);
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1);

  if (is_pair(cdr(args)))
    {
      s7_pointer e, b, x;
      e = cadr(args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->is_defined_symbol, 2, e, a_let_string));

      if (is_pair(cddr(args)))
	{
	  b = caddr(args);
	  if (!s7_is_boolean(b))
	    method_or_bust_with_type(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3);
	}
      else b = sc->F;

      if (e == sc->rootlet)
	return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to #<undefined> */

      x = find_local_symbol(sc, sym, e);
      if (is_slot(x))
	return(sc->T);

      if (b == sc->T)
	return(sc->F);

      /* here we can't fall back on find_symbol:
       *    (let ((b 2))
       *      (let ((e (curlet)))
       *        (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 (curlet)))
       *        (let ((a 1))
       *          (format #t "~A: ~A" (defined? 'abs e) (eval '(abs -1) e)))))
       *    "#f: 1"
       */
      return(make_boolean(sc, is_slot(global_slot(sym))));
    }
  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->nil) ||
      (envir == sc->rootlet))
    envir = sc->shadow_rootlet;
  x = find_local_symbol(sc, symbol, envir);
  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 */
      if ((envir == sc->shadow_rootlet) &&
	  (!is_slot(global_slot(symbol))))
	{
	  set_global(symbol); /* is_global => global_slot is usable */
	  set_global_slot(symbol, local_slot(symbol));
	}
    }
}


s7_pointer 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);
  return(sym);
}


s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
{
  s7_pointer sym;
  sym = s7_define_variable(sc, name, value);
  symbol_set_has_help(sym);
  symbol_help(sym) = copy_string(help);
  return(sym);
}


s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value)
{
  s7_pointer sym;
  sym = make_symbol(sc, name);
  s7_define(sc, sc->nil, sym, value);
  set_immutable(sym);
  return(sym);
}

/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar
 * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa
 */

s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
{
  s7_pointer sym;
  sym = s7_define_constant(sc, name, value);
  symbol_set_has_help(sym);
  symbol_help(sym) = copy_string(help);
  return(value); /* inconsistent with variable above, but consistent with define_function? */
}


char *s7_symbol_documentation(s7_scheme *sc, s7_pointer sym)
{
  if (is_keyword(sym)) return(NULL);
  if ((is_symbol(sym)) &&
      (symbol_has_help(sym)))
    return(symbol_help(sym));
  return(NULL);
}


char *s7_symbol_set_documentation(s7_scheme *sc, s7_pointer sym, const char *new_doc)
{
  if (is_keyword(sym)) return(NULL);
  if ((is_symbol(sym)) &&
      (symbol_has_help(sym)) &&
      (symbol_help(sym)))
    free(symbol_help(sym));
  symbol_set_has_help(sym);
  symbol_help(sym) = copy_string(new_doc);
  return(symbol_help(sym));
}


/* -------------------------------- keyword? -------------------------------- */

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? :rest) -> #t"
  #define Q_is_keyword pl_bt
  check_boolean_method(sc, is_keyword, sc->is_keyword_symbol, args);
}


/* -------------------------------- make-keyword -------------------------------- */
s7_pointer s7_make_keyword(s7_scheme *sc, const char *key)
{
  s7_pointer sym;
  char *name;
  unsigned int slen;
  slen = safe_strlen(key);
  tmpbuf_malloc(name, slen + 2);
  name[0] = ':';                                     /* prepend ":" */
  name[1] = '\0';
  memcpy((void *)(name + 1), (void *)key, slen);
  sym = make_symbol_with_length(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */
  tmpbuf_free(name, slen + 2);
  return(sym);
}


static s7_pointer g_make_keyword(s7_scheme *sc, s7_pointer args)
{
  /* this should be keyword, not make-keyword, but the latter is in use elsewhere, and in s7.h
   *   (string->)symbol is s7_make_symbol.  string->symbol is redundant.  
   *   Either use symbol/keyword/gensym, or string->symbol/string->keyword/string->gensym?
   */
  #define H_make_keyword "(make-keyword str) prepends ':' to str and defines that as a keyword"
  #define Q_make_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol)

  if (!is_string(car(args)))
    method_or_bust(sc, car(args), sc->make_keyword_symbol, args, T_STRING, 0);
  return(s7_make_keyword(sc, string_value(car(args))));
}

static s7_pointer c_make_keyword(s7_scheme *sc, s7_pointer x)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->make_keyword_symbol, list_1(sc, x), T_STRING, 0);
  return(s7_make_keyword(sc, string_value(x)));
}


/* -------------------------------- keyword->symbol -------------------------------- */
static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args)
{
  #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon"
  #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol)

  s7_pointer sym;
  sym = car(args);
  if (!is_keyword(sym))
    method_or_bust_with_type(sc, sym, sc->keyword_to_symbol_symbol, args, make_string_wrapper(sc, "a keyword"), 0);
  return(keyword_symbol(sym));
}

static s7_pointer c_keyword_to_symbol(s7_scheme *sc, s7_pointer sym)
{
  if (!is_keyword(sym))
    method_or_bust_with_type(sc, sym, sc->keyword_to_symbol_symbol, list_1(sc, sym), make_string_wrapper(sc, "a keyword"), 0);
  return(keyword_symbol(sym));
}


/* -------------------------------- symbol->keyword -------------------------------- */
static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended"
  #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol)

  if (!is_symbol(car(args)))
    method_or_bust(sc, car(args), sc->symbol_to_keyword_symbol, args, T_SYMBOL, 0);
  return(s7_make_keyword(sc, symbol_name(car(args))));
}

static s7_pointer c_symbol_to_keyword(s7_scheme *sc, s7_pointer sym)
{
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_to_keyword_symbol, list_1(sc, sym), T_SYMBOL, 0);
  return(s7_make_keyword(sc, symbol_name(sym)));
}



/* ---------------- 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)
    return(NULL);

  return(raw_pointer(p));
}


s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr)
{
  s7_pointer x;
  new_cell(sc, 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."
  #define Q_is_c_pointer pl_bt

  check_boolean_method(sc, s7_is_c_pointer, sc->is_c_pointer_symbol, args);
}


static s7_pointer c_c_pointer(s7_scheme *sc, s7_pointer arg)
{
  ptr_int p;
  if (!s7_is_integer(arg))
    method_or_bust(sc, arg, sc->c_pointer_symbol, list_1(sc, arg), T_INTEGER, 1);
  p = (ptr_int)s7_integer(arg);             /* (c-pointer (bignum "1234")) */
  return(s7_make_c_pointer(sc, (void *)p));
}

static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args)
{
  #define H_c_pointer "(c-pointer int) returns a c-pointer object."
  #define Q_c_pointer s7_make_signature(sc, 2, sc->is_c_pointer_symbol, sc->is_integer_symbol)
  return(c_c_pointer(sc, car(args)));
}



/* --------------------------------- rf (CLM optimizer) ----------------------------------------------- */

s7_pointer *s7_xf_start(s7_scheme *sc)
{
  sc->cur_rf->cur = sc->cur_rf->data;
  return(sc->cur_rf->cur);
}

static void resize_xf(s7_scheme *sc, xf_t *rc)
{
  /* if we're saving pointers into this array (for later fill-in), this realloc
   *   means earlier (backfill) pointers are not valid, so we have to save the position to be
   *   filled, not the pointer to it.
   */
  s7_int loc;
  loc = rc->cur - rc->data;

#if DEBUGGING
  int i;
  s7_pointer *old;
  old = rc->data;
  rc->data = (s7_pointer *)calloc(rc->size * 2, sizeof(s7_pointer));
  for (i = 0; i < rc->size; i++)
    {
      rc->data[i] = old[i];
      old[i] = NULL;
    }
#else
  rc->data = (s7_pointer *)realloc(rc->data, rc->size * 2 * sizeof(s7_pointer));
#endif
  rc->cur = (s7_pointer *)(rc->data + loc);
  rc->size *= 2;
  rc->end = (s7_pointer *)(rc->data + rc->size);
}

#define rc_loc(sc)     (ptr_int)(sc->cur_rf->cur - sc->cur_rf->data)
#define rc_go(sc, loc) (s7_pointer *)(sc->cur_rf->data + loc)

#define xf_init(N) do {rc = sc->cur_rf; if ((rc->cur + N) >= rc->end) resize_xf(sc, rc);} while (0)
#define xf_store(Val) do {(*(rc->cur)) = Val; rc->cur++;} while (0)
#define xf_save_loc(Loc) do {Loc = rc->cur - rc->data; rc->cur++;} while (0)
#define xf_save_loc2(Loc1, Loc2) do {Loc1 = rc->cur - rc->data; Loc2 = Loc1 + 1; rc->cur += 2;} while (0)
#define xf_save_loc3(Loc1, Loc2, Loc3) do {Loc1 = rc->cur - rc->data; Loc2 = Loc1 + 1; Loc3 = Loc2 + 1; rc->cur += 3;} while (0)
#define xf_store_at(Loc, Val) rc->data[Loc] = Val
#define xf_go(loc) rc->cur = (s7_pointer *)(rc->data + loc)
/* #define xf_loc() (ptr_int)(rc->cur - rc->data) */

s7_int s7_xf_store(s7_scheme *sc, s7_pointer val)
{
  s7_pointer *cur;
  xf_t *rc;
  rc = sc->cur_rf;
  if (rc->cur == rc->end)
    resize_xf(sc, rc);
  cur = rc->cur++;
  (*cur) = val;
  return(cur - rc->data);
}

void s7_xf_store_at(s7_scheme *sc, s7_int index, s7_pointer val)
{
  sc->cur_rf->data[index] = val;
}

void *s7_xf_new(s7_scheme *sc, s7_pointer e)
{
  xf_t *result;
  if (sc->rf_free_list)
    {
      result = sc->rf_free_list;
      sc->rf_free_list = sc->rf_free_list->next;
    }
  else
    {
      result = (xf_t *)malloc(sizeof(xf_t));
      result->size = 8;
      result->data = (s7_pointer *)calloc(result->size, sizeof(s7_pointer));
      result->end = (s7_pointer *)(result->data + result->size);
    }
  if (sc->cur_rf)
    {
      sc->cur_rf->next = sc->rf_stack;
      sc->rf_stack = sc->cur_rf;
    }
  sc->cur_rf = result;
  result->cur = result->data;
  result->e = e; /* set only here? */
  result->gc_list = NULL;
  return((void *)result);
}

static void s7_xf_clear(s7_scheme *sc)
{
  while (sc->cur_rf) {s7_xf_free(sc);}
}

bool s7_xf_is_stepper(s7_scheme *sc, s7_pointer sym)
{
  s7_pointer e, p;
  e = sc->cur_rf->e;
  if (!e) return(false);
  for (p = let_slots(e); is_slot(p); p = next_slot(p))
    if (slot_symbol(p) == sym)
      return(true);
  return(false);
}


static void xf_clear_list(s7_scheme *sc, xf_t *r)
{
  gc_obj *p, *op;
  for (p = r->gc_list; p; p = op)
    {
      op = p->nxt;
      free(p);
    }
  r->gc_list = NULL;
}

void *s7_xf_detach(s7_scheme *sc)
{
  xf_t *r;
  r = sc->cur_rf;
  sc->cur_rf = sc->rf_stack;
  if (sc->rf_stack)
    sc->rf_stack = sc->rf_stack->next;
  return((void *)r);
}

void s7_xf_attach(s7_scheme *sc, void *ur)
{
  xf_t *r = (xf_t *)ur;
  r->next = sc->rf_free_list;
  sc->rf_free_list = r;
  xf_clear_list(sc, r);
}

s7_pointer *s7_xf_top(s7_scheme *sc, void *ur)
{
  xf_t *r = (xf_t *)ur;
  return(r->data);
}


static s7_pointer xf_push(s7_scheme *sc, s7_pointer obj)
{
  gc_obj *p;
  p = (gc_obj *)malloc(sizeof(gc_obj));
  p->nxt = sc->cur_rf->gc_list;
  sc->cur_rf->gc_list = p;
  p->p = obj;
  return(obj);
}

#if WITH_ADD_PF
static s7_pointer xf_pop(s7_scheme *sc)
{
  if ((sc->cur_rf) && 
      (sc->cur_rf->gc_list))
    {
      s7_pointer p;
      gc_obj *g;
      g = sc->cur_rf->gc_list;
      p = g->p;
      sc->cur_rf->gc_list = g->nxt;
      free(g);
      return(p);
    }
  return(NULL);
}
#endif

void s7_xf_free(s7_scheme *sc)
{
  sc->cur_rf->next = sc->rf_free_list;
  sc->rf_free_list = sc->cur_rf;
  xf_clear_list(sc, sc->cur_rf);
  sc->cur_rf = sc->rf_stack;
  if (sc->rf_stack)
    sc->rf_stack = sc->rf_stack->next;
}

static s7_if_t implicit_int_vector_ref(s7_scheme *sc, s7_pointer expr);
static s7_rf_t implicit_float_vector_ref(s7_scheme *sc, s7_pointer expr);
static s7_pf_t implicit_pf_sequence_ref(s7_scheme *sc, s7_pointer expr);
static s7_pf_t implicit_gf_sequence_ref(s7_scheme *sc, s7_pointer expr);

#if WITH_OPTIMIZATION
static s7_pf_t implicit_pf_sequence_set(s7_scheme *sc, s7_pointer v, s7_pointer ind, s7_pointer val);
static s7_pf_t implicit_gf_sequence_set(s7_scheme *sc, s7_pointer v, s7_pointer ind, s7_pointer val);
#endif

/* set cases are via set_if/set_rf -- but set_gp|pf would need to be restricted to non-symbol settees */

/* need to make sure sequence is not a step var, also set cases */

static s7_rp_t rf_function(s7_pointer f)
{
  switch (type(f))
    {
    case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
      return(c_function_rp(f));

    case T_FLOAT_VECTOR: 
      return(implicit_float_vector_ref);

    case T_C_OBJECT:
      return(c_object_rp(f));

    case T_SYNTAX:       
      return(syntax_rp(f));
    }
  return(NULL);
}

static s7_ip_t if_function(s7_pointer f)
{
  switch (type(f))
    {
    case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
      return(c_function_ip(f));

    case T_INT_VECTOR: 
      return(implicit_int_vector_ref);

    case T_C_OBJECT:
      return(c_object_ip(f));

    case T_SYNTAX:       
      return(syntax_ip(f));
    }
  return(NULL);
}

static s7_pp_t pf_function(s7_pointer f)
{
  switch (type(f))
    {
    case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
      return(c_function_pp(f));

    case T_PAIR: case T_STRING: case T_VECTOR: case T_HASH_TABLE: case T_LET:
      return(implicit_pf_sequence_ref);

    case T_SYNTAX:       
      return(syntax_pp(f));
    }
  return(NULL);
}

static s7_pp_t gf_function(s7_pointer f)
{
  switch (type(f))
    {
    case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
      return(c_function_gp(f));

    case T_PAIR: case T_STRING: case T_VECTOR: case T_HASH_TABLE: case T_LET: case T_C_OBJECT: case T_INT_VECTOR: case T_FLOAT_VECTOR:
      return(implicit_gf_sequence_ref);
    }
  return(NULL);
}

s7_rp_t s7_rf_function(s7_scheme *sc, s7_pointer func) {return(rf_function(func));}
s7_ip_t s7_if_function(s7_scheme *sc, s7_pointer func) {return(if_function(func));}
s7_pp_t s7_pf_function(s7_scheme *sc, s7_pointer func) {return(pf_function(func));}
s7_pp_t s7_gf_function(s7_scheme *sc, s7_pointer func) {return(gf_function(func));}

void s7_rf_set_function(s7_pointer f, s7_rp_t rp)
{
#if WITH_OPTIMIZATION
  if (!is_c_function(f)) return;
  c_function_rp(f) = rp;
#else
  return;
#endif
}

void s7_if_set_function(s7_pointer f, s7_ip_t ip)
{
#if WITH_OPTIMIZATION
  if (!is_c_function(f)) return;
  c_function_ip(f) = ip;
#else
  return;
#endif
}

void s7_pf_set_function(s7_pointer f, s7_pp_t pp)
{
#if WITH_OPTIMIZATION
  if (!is_c_function(f)) return;
  c_function_pp(f) = pp;
#else
  return;
#endif
}

void s7_gf_set_function(s7_pointer f, s7_pp_t gp)
{
#if WITH_OPTIMIZATION
  if (!is_c_function(f)) return;
  c_function_gp(f) = gp;
#else
  return;
#endif
}

static s7_rp_t pair_to_rp(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val_sym, val;
  val_sym = car(expr);
  if (!s7_is_symbol(val_sym)) return(NULL);
  if (s7_local_slot(sc, val_sym)) return(NULL);
  val = s7_symbol_value(sc, val_sym);
  return(s7_rf_function(sc, val)); 
}

static s7_ip_t pair_to_ip(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val_sym, val;
  val_sym = car(expr);
  if (!s7_is_symbol(val_sym)) return(NULL);
  if (s7_local_slot(sc, val_sym)) return(NULL);
  val = s7_symbol_value(sc, val_sym);
  return(s7_if_function(sc, val)); 
}

static s7_pp_t pair_to_pp(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val_sym, val;
  val_sym = car(expr);
  if (!s7_is_symbol(val_sym)) return(NULL);
  if (s7_local_slot(sc, val_sym)) return(NULL);
  val = s7_symbol_value(sc, val_sym);
  return(s7_pf_function(sc, val)); 
}

static s7_pp_t pair_to_gp(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer val_sym, val;
  val_sym = car(expr);
  if (!s7_is_symbol(val_sym)) return(NULL);
  if (s7_local_slot(sc, val_sym)) return(NULL);
  val = s7_symbol_value(sc, val_sym);
  return(s7_gf_function(sc, val)); 
}

static s7_pf_t xf_opt(s7_scheme *sc, s7_pointer lp)
{
  s7_int loc;
  s7_pointer f;
  s7_rp_t rp;
  s7_ip_t xp;
  s7_pp_t pp;
  xf_t *rc;

  f = find_symbol(sc, car(lp));
  if (!is_slot(f)) return(NULL);
  f = slot_value(f);

  xf_init(3);
  xf_save_loc(loc);

  xp = if_function(f);
  if (xp)
    {
      s7_if_t xf;
      xf = xp(sc, lp);
      if (xf)
	{
	  xf_store_at(loc, (s7_pointer)xf);
	  return((s7_pf_t)xf);
	}
      xf_go(loc + 1);
    }

  rp = rf_function(f);
  if (rp)
    {
      s7_rf_t rf;
      rf = rp(sc, lp);
      if (rf)
	{
	  xf_store_at(loc, (s7_pointer)rf);
	  return((s7_pf_t)rf);
	}
      xf_go(loc + 1);
    }

  pp = pf_function(f);
  if (pp)
    {
      s7_pf_t pf;
      pf = pp(sc, lp);
      if (pf)
	{
	  xf_store_at(loc, (s7_pointer)pf);
	  return(pf);
	}
      xf_go(loc + 1);
    }

  pp = gf_function(f);
  if (pp)
    {
      s7_pf_t pf;
      pf = pp(sc, lp);
      if (pf)
	{
	  xf_store_at(loc, (s7_pointer)pf);
	  return(pf);
	}
    }
  return(NULL);
}

#if 0
static s7_pointer if_to_pf(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t xf;
  s7_int x;
  xf = (s7_if_t)(**p); (*p)++;
  x = xf(sc, p);
  return(make_integer(sc, x));
}

static s7_pointer rf_to_pf(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t rf;
  s7_double x;
  rf = (s7_rf_t)(**p); (*p)++;
  x = rf(sc, p);
  return(make_real(sc, x));
}

static s7_pf_t pf_opt(s7_scheme *sc, s7_pointer lp)
{
  s7_int loc, loc1;
  s7_pointer f;
  s7_rp_t rp;
  s7_ip_t xp;
  s7_pp_t pp;
  xf_t *rc;

  f = find_symbol(sc, car(lp));
  if (!is_slot(f)) return(NULL);
  f = slot_value(f);

  xf_init(3);
  xf_save_loc(loc);

  xp = if_function(f);
  if (xp)
    {
      s7_if_t xf;
      xf_save_loc(loc1);
      xf = xp(sc, lp);
      if (xf)
	{
	  xf_store_at(loc, (s7_pointer)if_to_pf);
	  xf_store_at(loc1, (s7_pointer)xf);
	  return((s7_pf_t)if_to_pf);
	}
      xf_go(loc + 1);
    }

  rp = rf_function(f);
  if (rp)
    {
      s7_rf_t rf;
      xf_save_loc(loc1);
      rf = rp(sc, lp);
      if (rf)
	{
	  xf_store_at(loc, (s7_pointer)rf_to_pf);
	  xf_store_at(loc1, (s7_pointer)rf);
	  return((s7_pf_t)rf_to_pf);
	}
      xf_go(loc + 1);
    }

  pp = pf_function(f);
  if (pp)
    {
      s7_pf_t pf;
      pf = pp(sc, lp);
      if (pf)
	{
	  xf_store_at(loc, (s7_pointer)pf);
	  return(pf);
	}
    }
  return(NULL);
}
#endif

static s7_double rf_c(s7_scheme *sc, s7_pointer **p)
{
  s7_double x;
  x = s7_number_to_real(sc, **p); (*p)++;
  return(x);
}

static s7_double rf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_double x;
  x = s7_number_to_real(sc, slot_value(**p)); (*p)++;
  return(x);
}

static bool arg_to_rf(s7_scheme *sc, s7_pointer a1, s7_int in_loc)
{
  s7_int loc;
  xf_t *rc;

  xf_init(2);
  if (in_loc == -1)
    xf_save_loc(loc);
  else loc = in_loc;

  if (is_pair(a1))
    {
      s7_rp_t rp;
      s7_rf_t rf;
      rp = pair_to_rp(sc, a1);
      if (!rp) return(false);
      rf = rp(sc, a1);
      if (!rf) return(false);
      xf_store_at(loc, (s7_pointer)rf);
      return(true);
    }

  if (is_symbol(a1))
    {
      s7_pointer slot;
      slot = s7_slot(sc, a1);
      if ((is_slot(slot)) && 
	  (is_real(slot_value(slot))))
	{
	  xf_store(slot);
	  xf_store_at(loc, (s7_pointer)rf_s);
	  return(true);
	}
      return(false);
    }

  if (is_real(a1))
    {
      xf_store(a1);
      xf_store_at(loc, (s7_pointer)rf_c);
      return(true);
    }

  return(false);
}

bool s7_arg_to_rf(s7_scheme *sc, s7_pointer a1)
{
  return(arg_to_rf(sc, a1, -1));
}

static s7_int if_c(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer i;
  i = **p; (*p)++;
  return(integer(i));
}

static s7_int if_s(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x;
  x = slot_value(**p); (*p)++;
  if (!is_integer(x)) s7_wrong_type_arg_error(sc, "", 0, x, "an integer");
  return(integer(x));
}

static bool arg_to_if(s7_scheme *sc, s7_pointer a1, s7_int in_loc)
{
  s7_int loc;
  xf_t *rc;

  xf_init(2);
  if (in_loc == -1)
    xf_save_loc(loc);
  else loc = in_loc;

  if (is_pair(a1))
    {
      s7_ip_t ip;
      s7_if_t xf;
      ip = pair_to_ip(sc, a1);
      if (!ip) return(false);
      xf = ip(sc, a1);
      if (!xf) return(false);
      xf_store_at(loc, (s7_pointer)xf);
      return(true);
    }

  if (is_symbol(a1))
    {
      s7_pointer slot;
      slot = s7_slot(sc, a1);
      if ((is_slot(slot)) && 
	  (is_integer(slot_value(slot))))
	{
	  xf_store(slot);
	  xf_store_at(loc, (s7_pointer)if_s);
	  return(true);
	}
      return(false);
    }

  if (is_integer(a1))
    {
      xf_store(a1);
      xf_store_at(loc, (s7_pointer)if_c);
      return(true);
    }

  return(false);
}

bool s7_arg_to_if(s7_scheme *sc, s7_pointer a1)
{
  return(arg_to_if(sc, a1, -1));
}

static s7_pointer pf_c(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x;
  x = **p; (*p)++;
  return(x);
}

static s7_pointer pf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x;
  x = slot_value(**p); (*p)++;
  return(x);
}

static bool arg_to_pf(s7_scheme *sc, s7_pointer a1, s7_int in_loc)
{
  s7_int loc;
  xf_t *rc;

  xf_init(2);
  if (in_loc == -1)
    xf_save_loc(loc);
  else loc = in_loc;

  if (is_pair(a1))
    {
      s7_pp_t pp;
      s7_pf_t pf;
      pp = pair_to_pp(sc, a1);
      if (!pp) return(false);
      pf = pp(sc, a1);
      if (!pf) return(false);
      xf_store_at(loc, (s7_pointer)pf);
      return(true);
    }

  if (is_symbol(a1))
    {
      s7_pointer slot;
      slot = s7_slot(sc, a1);
      if (is_slot(slot))
	{
	  xf_store(slot);
	  xf_store_at(loc, (s7_pointer)pf_s);
	  return(true);
	}
      return(false);
    }

  xf_store(a1);
  xf_store_at(loc, (s7_pointer)pf_c);
  return(true);
}

bool s7_arg_to_pf(s7_scheme *sc, s7_pointer a1)
{
  return(arg_to_pf(sc, a1, -1));
}

static bool arg_to_gf(s7_scheme *sc, s7_pointer a1, s7_int in_loc)
{
  if (is_pair(a1))
    {
      s7_pp_t gp;
      gp = pair_to_gp(sc, a1);
      if (gp)
	{
	  xf_t *rc;
	  s7_pf_t gf;
	  s7_int loc;

	  xf_init(1);
	  if (in_loc == -1)
	    xf_save_loc(loc);
	  else loc = in_loc;
	  gf = gp(sc, a1);
	  if (gf)
	    {
	      xf_store_at(loc, (s7_pointer)gf);
	      return(true);
	    }
	}
    }
  return(false);
}

bool s7_arg_to_gf(s7_scheme *sc, s7_pointer a1)
{
  return(arg_to_gf(sc, a1, -1));
}

static s7_rf_t pair_to_rf(s7_scheme *sc, s7_pointer a1, s7_rf_t x)
{
  if (s7_arg_to_rf(sc, a1))
    return(x);
  return(NULL);
}

static s7_rf_t pair_to_rf_via_if(s7_scheme *sc, s7_pointer a1, s7_rf_t x)
{
  if (s7_arg_to_if(sc, a1))
    return(x);
  return(NULL);
}


s7_rf_t s7_rf_1(s7_scheme *sc, s7_pointer expr, s7_rf_t r, s7_rf_t s, s7_rf_t x)
{
  s7_pointer a1;
  xf_t *rc;

  if ((is_null(cdr(expr))) || (!is_null(cddr(expr)))) return(NULL);
  a1 = cadr(expr);

  xf_init(1);
  if (is_real(a1))
    {
      xf_store(a1);
      return(r);
    }

  if (is_symbol(a1))
    {
      a1 = s7_slot(sc, a1);
      if ((!is_slot(a1)) || (is_t_complex(slot_value(a1)))) return(NULL);
      xf_store(a1);
      return(s);
    }

  if (is_pair(a1))
    return(pair_to_rf(sc, a1, x));

  return(NULL);
}

s7_rf_t s7_rf_2(s7_scheme *sc, s7_pointer expr, s7_rf_t rr, s7_rf_t sr, s7_rf_t xr, s7_rf_t rs, s7_rf_t ss, s7_rf_t xs, s7_rf_t rx, s7_rf_t sx, s7_rf_t xx)
{
  s7_pointer a1, a2;
  xf_t *rc;

  if ((is_null(cdr(expr))) || (!is_null(cdddr(expr)))) return(NULL);
  a1 = cadr(expr);
  a2 = caddr(expr);

  xf_init(2);
  if (is_real(a1))
    {
      xf_store(a1);
      if (is_real(a2))
	{
	  xf_store(a2);
	  return(rr);
	}
      if (is_symbol(a2))
	{
	  a2 = s7_slot(sc, a2);
	  if ((!is_slot(a2)) || (is_t_complex(slot_value(a2)))) return(NULL);
	  xf_store(a2);
	  return(rs);
	}
      if (is_pair(a2))
	return(pair_to_rf(sc, a2, rx));
      return(NULL);
    }

  if (is_symbol(a1))
    {
      a1 = s7_slot(sc, a1);
      if ((!is_slot(a1)) || (is_t_complex(slot_value(a1)))) return(NULL);
      xf_store(a1);
      if (is_real(a2))
	{
	  xf_store(a2);
	  return(sr);
	}
      if (is_symbol(a2))
	{
	  a2 = s7_slot(sc, a2);
	  if ((!is_slot(a2)) || (is_t_complex(slot_value(a2)))) return(NULL);
	  xf_store(a2);
	  return(ss);
	}
      if (is_pair(a2))
	return(pair_to_rf(sc, a2, sx));
      return(NULL);
    }

  if (is_pair(a1))
    {
      s7_int loc;
      s7_rp_t rp;
      s7_rf_t rf;

      xf_save_loc(loc);
      rp = pair_to_rp(sc, a1);
      if (!rp) return(NULL);
      rf = rp(sc, a1);
      if (!rf) return(NULL);
      xf_store_at(loc, (s7_pointer)rf);

      if (is_real(a2))
	{
	  xf_store(a2);
	  return(xr);
	}
      if (is_symbol(a2))
	{
	  a2 = s7_slot(sc, a2);
	  if ((!is_slot(a2)) || (is_t_complex(slot_value(a2)))) return(NULL);
	  xf_store(a2);
	  return(xs);
	}
      if (is_pair(a2))
	return(pair_to_rf(sc, a2, xx));
      return(NULL);
    }
  return(NULL);
}

#if (!WITH_GMP)
typedef struct {s7_rf_t none, r, s, p, rs, rp, ss, sp, pp, rss, rsp, rpp, sss, ssp, spp, ppp;} rf_ops;
static rf_ops *add_r_ops, *multiply_r_ops;

static s7_rf_t com_rf_2(s7_scheme *sc, s7_pointer expr, rf_ops *a)
{
  /* expr len is assumed to be 3 (2 args) */
  s7_pointer a1, a2, p1 = NULL, p2 = NULL, s1 = NULL, s2 = NULL, c1 = NULL, c2 = NULL;
  xf_t *rc;

  a1 = cadr(expr);
  if (is_pair(a1)) p1 = a1; else {if (is_symbol(a1)) s1 = a1; else {if (is_real(a1)) c1 = a1; else return(NULL);}}
  a2 = caddr(expr);
  if (is_pair(a2)) p2 = a2; else {if (is_symbol(a2)) s2 = a2; else {if (is_real(a2)) c2 = a2; else return(NULL);}}
  
  xf_init(2);
  if (!c1) {c1 = c2; c2 = NULL;}
  if (c2)
    {
      if ((is_t_real(c1)) || (is_t_real(c2)))
	{
	  s7_pointer x;
	  s7_double x1, x2;
	  x1 = real_to_double(sc, c1, (a == add_r_ops) ? "+" : "*");
	  x2 = real_to_double(sc, c2, (a == add_r_ops) ? "+" : "*");
	  if (a == add_r_ops)
	    x = make_real(sc, x1 + x2);
	  else x = make_real(sc, x1 * x2);
	  if (!is_immutable_real(x))
	    xf_push(sc, x);
	  xf_store(x);
	  return(a->r);
	}
      return(NULL);
    }
  if (!s1) {s1 = s2; s2 = NULL;} 
  if (!p1) {p1 = p2; p2 = NULL;}
  
  if (s1)
    {
      bool s1_real;
      s1 = s7_slot(sc, s1);
      if ((!is_slot(s1)) || (is_unsafe_stepper(s1)) || (is_t_complex(slot_value(s1)))) return(NULL);
      s1_real = (is_t_real(slot_value(s1)));
      xf_store(s1);
      if (s2)
	{
	  s2 = s7_slot(sc, s2);
	  if ((!is_slot(s2)) || (is_unsafe_stepper(s2)) || (is_t_complex(slot_value(s2)))) return(NULL);
	  
	  if ((s1_real) ||                         /* TODO: look at step etc */
	      (is_t_real(slot_value(s2))))
	    {
	      xf_store(s2);
	      return(a->ss);
	    }
	  return(NULL);
	}
      if (c1)
	{
	  if ((s1_real) || (is_t_real(c1)))
	    {
	      xf_store(c1);
	      return(a->rs);
	    }
	  return(NULL);
	}
      if (s7_arg_to_rf(sc, p1))
	return(a->sp);
      return(NULL);
    }

  /* must be p1 here, c1 or p2 */
  if (c1)
    {
      xf_store(c1);
      if (s7_arg_to_rf(sc, p1))
	return(a->rp);
      return(NULL);
    }
  
  if ((s7_arg_to_rf(sc, p1)) &&
      (s7_arg_to_rf(sc, p2)))
    return(a->pp);

  return(NULL);
}

static s7_rf_t com_rf_3(s7_scheme *sc, s7_pointer expr, rf_ops *a)
{
  /* expr len is assumed to be 4 (3 args) */
  s7_pointer a1, a2, a3, p1 = NULL, p2 = NULL, p3 = NULL, s1 = NULL, s2 = NULL, s3 = NULL, c1 = NULL, c2 = NULL, c3 = NULL;
  bool s1_real = false;
  xf_t *rc;
  
  a1 = cadr(expr);
  if (is_pair(a1)) p1 = a1; else {if (is_symbol(a1)) s1 = a1; else {if (is_real(a1)) c1 = a1; else return(NULL);}}
  a2 = caddr(expr);
  if (is_pair(a2)) p2 = a2; else {if (is_symbol(a2)) s2 = a2; else {if (is_real(a2)) c2 = a2; else return(NULL);}}
  a3 = cadddr(expr);
  if (is_pair(a3)) p3 = a3; else {if (is_symbol(a3)) s3 = a3; else {if (is_real(a3)) c3 = a3; else return(NULL);}}
  
  if (!s2) {s2 = s3; s3 = NULL;}
  if (!s1) {s1 = s2; s2 = s3; s3 = NULL;} 

  xf_init(3);
  if (s1)
    {
      s1 = s7_slot(sc, s1);
      if ((!is_slot(s1)) || (is_unsafe_stepper(s1)) || (is_t_complex(slot_value(s1)))) return(NULL);
      s1_real = (is_t_real(slot_value(s1)));
      xf_store(s1);
    }

  if (!p2) {p2 = p3; p3 = NULL;}
  if (!p1) {p1 = p2; p2 = p3; p3 = NULL;}

  if (!c2) {c2 = c3; c3 = NULL;}
  if (!c1) {c1 = c2; c2 = c3; c3 = NULL;}
  if (c2)
    {
      if ((is_t_real(c1)) || (is_t_real(c2)) || ((c3) && (is_t_real(c3))))
	{
	  s7_pointer x;
	  s7_double x1, x2, x3;
	  x1 = real_to_double(sc, c1, (a == add_r_ops) ? "+" : "*");
	  x2 = real_to_double(sc, c2, (a == add_r_ops) ? "+" : "*");
	  if (c3) x3 = real_to_double(sc, c3, (a == add_r_ops) ? "+" : "*"); else x3 = ((a == add_r_ops) ? 0.0 : 1.0);
	  if (a == add_r_ops)
	    x = make_real(sc, x1 + x2 + x3);
	  else x = make_real(sc, x1 * x2 * x3);
	  if (!is_immutable_real(x))
	    xf_push(sc, x);
	  xf_store(x);
	  if (c3) return(a->r);
	  if (s1) return(a->rs);
	  if (s7_arg_to_rf(sc, p1))
	    return(a->rp);
	}
      return(NULL);
    }

  if (s1)
    {
      if (s2)
	{
	  bool s2_real;
	  s2 = s7_slot(sc, s2);
	  if ((!is_slot(s2)) || (is_unsafe_stepper(s2)) || (is_t_complex(slot_value(s2)))) return(NULL);
	  s2_real = (is_t_real(slot_value(s2)));
	  xf_store(s2);
	  if (s3)
	    {
	      s3 = s7_slot(sc, s3);
	      if ((!is_slot(s3)) || (is_unsafe_stepper(s3)) || (is_t_complex(slot_value(s3)))) return(NULL);
	      if ((s1_real) || (s2_real) || (is_t_real(slot_value(s3))))
		{
		  xf_store(s3);
		  return(a->sss);
		}
	      return(NULL);
	    }
	  if (c1)
	    {
	      if ((s1_real) || (s2_real) || (is_t_real(c1)))
		{
		  xf_store(c1);
		  return(a->rss);
		}
	      return(NULL);
	    }
	  if (s7_arg_to_rf(sc, p1))
	    return(a->ssp);
	  return(NULL);
	}
      if (c1)
	{
	  xf_store(c1);
	  if (s7_arg_to_rf(sc, p1))
	    return(a->rsp);
	  return(NULL);
	}
      if ((s7_arg_to_rf(sc, p1)) &&
	  (s7_arg_to_rf(sc, p2)))
	return(a->spp);
      return(NULL);
    }
  
  if (c1)
    {
      xf_store(c1);
      if ((s7_arg_to_rf(sc, p1)) &&
	  (s7_arg_to_rf(sc, p2)))
	return(a->rpp);
      return(NULL);
    }

  if ((s7_arg_to_rf(sc, p1)) &&
      (s7_arg_to_rf(sc, p2)) &&
      (s7_arg_to_rf(sc, p3)))
    return(a->ppp);
  return(NULL);
}

typedef struct {s7_if_t none, r, s, p, rs, rp, ss, sp, pp, rss, rsp, rpp, sss, ssp, spp, ppp;} if_ops;
static if_ops *add_i_ops, *multiply_i_ops;

static s7_if_t com_if_2(s7_scheme *sc, s7_pointer expr, if_ops *a)
{
  /* expr len is assumed to be 3 (2 args) */
  s7_pointer a1, a2, p1 = NULL, p2 = NULL, s1 = NULL, s2 = NULL, c1 = NULL, c2 = NULL;
  xf_t *rc;

  a1 = cadr(expr);
  if (is_pair(a1)) p1 = a1; else {if (is_symbol(a1)) s1 = a1; else {if (is_real(a1)) c1 = a1; else return(NULL);}}
  a2 = caddr(expr);
  if (is_pair(a2)) p2 = a2; else {if (is_symbol(a2)) s2 = a2; else {if (is_real(a2)) c2 = a2; else return(NULL);}}
  
  xf_init(2);
  if (!c1) {c1 = c2; c2 = NULL;}
  if ((c1) && (!is_t_integer(c1))) return(NULL);
  if (c2)
    {
      s7_pointer x;
      if (!(is_t_integer(c2))) return(NULL);
      if (a == add_i_ops)
	x = make_integer(sc, integer(c1) + integer(c2));
      else x = make_integer(sc, integer(c1) * integer(c2));
      if (!is_immutable_integer(x))
	xf_push(sc, x);
      xf_store(x);
      return(a->r);
    }
  if (!s1) {s1 = s2; s2 = NULL;} 
  if (!p1) {p1 = p2; p2 = NULL;}
  
  if (s1)
    {
      s1 = s7_slot(sc, s1);
      if ((!is_slot(s1)) || (is_unsafe_stepper(s1)) || (!is_t_integer(slot_value(s1)))) return(NULL);
      xf_store(s1);
      if (s2)
	{
	  s2 = s7_slot(sc, s2);
	  if ((!is_slot(s2)) || (is_unsafe_stepper(s2)) || (!is_t_integer(slot_value(s2)))) return(NULL);
	  xf_store(s2);
	  return(a->ss);
	}
      if (c1)
	{
	  xf_store(c1);
	  return(a->rs);
	}
      if (s7_arg_to_if(sc, p1))
	return(a->sp);
      return(NULL);
    }

  /* must be p1 here, c1 or p2 */
  if (c1)
    {
      xf_store(c1);
      if (s7_arg_to_if(sc, p1))
	return(a->rp);
      return(NULL);
    }
  
  if ((s7_arg_to_if(sc, p1)) &&
      (s7_arg_to_if(sc, p2)))
    return(a->pp);

  return(NULL);
}

static s7_if_t com_if_3(s7_scheme *sc, s7_pointer expr, if_ops *a)
{
  /* expr len is assumed to be 4 (3 args) */
  s7_pointer a1, a2, a3, p1 = NULL, p2 = NULL, p3 = NULL, s1 = NULL, s2 = NULL, s3 = NULL, c1 = NULL, c2 = NULL, c3 = NULL;
  xf_t *rc;

  a1 = cadr(expr);
  if (is_pair(a1)) p1 = a1; else {if (is_symbol(a1)) s1 = a1; else {if (is_real(a1)) c1 = a1; else return(NULL);}}
  a2 = caddr(expr);
  if (is_pair(a2)) p2 = a2; else {if (is_symbol(a2)) s2 = a2; else {if (is_real(a2)) c2 = a2; else return(NULL);}}
  a3 = cadddr(expr);
  if (is_pair(a3)) p3 = a3; else {if (is_symbol(a3)) s3 = a3; else {if (is_real(a3)) c3 = a3; else return(NULL);}}
  
  xf_init(3);
  if (!s2) {s2 = s3; s3 = NULL;}
  if (!s1) {s1 = s2; s2 = s3; s3 = NULL;}
  if (s1)
    {
      s1 = s7_slot(sc, s1);
      if ((!is_slot(s1)) || (is_unsafe_stepper(s1)) || (!is_t_integer(slot_value(s1)))) return(NULL);
      xf_store(s1);
    }

  if (!p2) {p2 = p3; p3 = NULL;}
  if (!p1) {p1 = p2; p2 = p3; p3 = NULL;}

  if (!c2) {c2 = c3; c3 = NULL;}
  if (!c1) {c1 = c2; c2 = c3; c3 = NULL;}
  if (c1)
    {
      if (!is_t_integer(c1)) return(NULL);
      if (c2)
	{
	  s7_pointer x;
	  if (!is_t_integer(c2)) return(NULL);
	  if ((c3) && (!is_t_integer(c3))) return(NULL);
	  if (a == add_i_ops)
	    x = make_integer(sc, integer(c1) + integer(c2) + ((c3) ? integer(c3) : 0));
	  else x = make_integer(sc, integer(c1) * integer(c2) * ((c3) ? integer(c3) : 1));
	  if (!is_immutable_integer(x))
	    xf_push(sc, x);
	  xf_store(x);
	  if (c3) return(a->r);
	  if (s1) return(a->rs);
	  if (s7_arg_to_if(sc, p1))
	    return(a->rp);
	}
      return(NULL);
    }

  if (s1)
    {
      if (s2)
	{
	  s2 = s7_slot(sc, s2);
	  if ((!is_slot(s2)) || (is_unsafe_stepper(s2)) || (!is_t_integer(slot_value(s2)))) return(NULL);
	  xf_store(s2);
	  if (s3)
	    {
	      s3 = s7_slot(sc, s3);
	      if ((!is_slot(s3)) || (is_unsafe_stepper(s3)) || (!is_t_integer(slot_value(s3)))) return(NULL);
	      xf_store(s3);
	      return(a->sss);
	    }
	  if (c1)
	    {
	      xf_store(c1);
	      return(a->rss);
	    }
	  if (s7_arg_to_if(sc, p1))
	    return(a->ssp);
	  return(NULL);
	}
      if (c1)
	{
	  xf_store(c1);
	  if (s7_arg_to_if(sc, p1))
	    return(a->rsp);
	  return(NULL);
	}
      if ((s7_arg_to_if(sc, p1)) &&
	  (s7_arg_to_if(sc, p2)))
	return(a->spp);
      return(NULL);
    }
  
  if (c1)
    {
      xf_store(c1);
      if ((s7_arg_to_if(sc, p1)) &&
	  (s7_arg_to_if(sc, p2)))
	return(a->rpp);
      return(NULL);
    }

  if ((s7_arg_to_if(sc, p1)) &&
      (s7_arg_to_if(sc, p2)) &&
      (s7_arg_to_if(sc, p3)))
    return(a->ppp);
  return(NULL);
}
#endif

#if WITH_OPTIMIZATION
static s7_double set_rf_sr(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, c1;
  s7_double x;
  s1 = (**p); (*p)++;
  c1 = (**p); (*p)++;
  x = real(c1);
  slot_set_value(s1, make_real(sc, x));
  return(x);
}

#if 0
static s7_double set_rf_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_double x;
  s1 = (**p); (*p)++;
  s2 = (**p); (*p)++;
  x = real_to_double(sc, slot_value(s2), "set!");
  slot_set_value(s1, make_real(sc, x));
  return(x);
}
#endif

static s7_double set_rf_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_double x;
  s7_rf_t r1;
  s1 = (**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  slot_set_value(s1, make_real(sc, x));
  return(x);
}

static s7_int set_if_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_int x;
  s7_if_t i1;
  s1 = (**p); (*p)++;
  i1 = (s7_if_t)(**p); (*p)++;
  x = i1(sc, p);
  slot_set_value(s1, make_integer(sc, x));
  return(x);
}

static s7_rf_t float_vector_set_rf_expanded(s7_scheme *sc, s7_pointer fv, s7_pointer ind_sym, s7_pointer val_expr);
static s7_if_t int_vector_set_if_expanded(s7_scheme *sc, s7_pointer iv, s7_pointer ind_sym, s7_pointer val_expr);

static s7_rf_t set_rf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer slot, a1;
  xf_t *rc;

  if (is_pair(cdddr(expr))) return(NULL);
  a1 = cadr(expr);
  if (!is_symbol(a1)) /* look for implicit index case */
    {
      s7_pointer fv;
      if ((!is_pair(a1)) || (!is_symbol(car(a1))) || (!is_null(cddr(a1)))) return(NULL);
      fv = s7_symbol_value(sc, car(a1));
      if (is_float_vector(fv))
	return(float_vector_set_rf_expanded(sc, fv, cadr(a1), caddr(expr)));
      if ((is_c_object(fv)) &&
	  (c_object_set_rp(fv)))
	return(c_object_set_rp(fv)(sc, expr));
      return(NULL);
    }

  /* if sym has real value and new val is real, we're ok */
  slot = s7_slot(sc, a1);
  if (!is_slot(slot)) return(NULL);

  xf_init(2);
  if (is_t_real(slot_value(slot)))
    {
      s7_pointer a2;
      xf_store(slot);
      a2 = caddr(expr);
      if (is_t_real(a2))
	{
	  xf_store(a2);
	  return(set_rf_sr);
	}
#if 0
      if (is_symbol(a2))
	{
	  s7_pointer a2_slot;
	  a2_slot = s7_slot(sc, a2);
	  if (!is_slot(a2_slot)) return(NULL);
	  if (type(slot_value(a2_slot)) != T_REAL) return(NULL);
	  xf_store(a2_slot);
	  return(set_rf_ss);
	}
#endif
      if (is_pair(a2))
	{
	  s7_rp_t rp;
	  s7_rf_t rf;
	  s7_int loc;
	  xf_save_loc(loc);
	  rp = pair_to_rp(sc, a2);
	  if (!rp) return(NULL);
	  rf = rp(sc, a2);
	  if (!rf) return(NULL);
	  xf_store_at(loc, (s7_pointer)rf);
	  return(set_rf_sx);
	}
    }
  return(NULL);
}

static s7_if_t set_if(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer slot, a1;

  if (is_pair(cdddr(expr))) return(NULL);
  a1 = cadr(expr);

  if (!is_symbol(a1)) /* look for implicit index case */
    {
      s7_pointer fv;
      if ((!is_pair(a1)) || (!is_symbol(car(a1))) || (!is_null(cddr(a1)))) return(NULL);
      fv = s7_symbol_value(sc, car(a1));
      if (is_int_vector(fv))
	return(int_vector_set_if_expanded(sc, fv, cadr(a1), caddr(expr)));
      if ((is_c_object(fv)) &&
	  (c_object_set_ip(fv)))
	return(c_object_set_ip(fv)(sc, expr));
      return(NULL);
    }

  if (!is_symbol(a1)) return(NULL);
  slot = s7_slot(sc, a1);
  if (!is_slot(slot)) return(NULL);

  if (is_t_integer(slot_value(slot)))
    {
      s7_pointer a2;
      xf_t *rc;
      xf_init(1);
      xf_store(slot);
      a2 = caddr(expr);
      if ((is_pair(a2)) &&
	  (s7_arg_to_if(sc, a2)))
	return(set_if_sx);
    }
  return(NULL);
}

static s7_pf_t set_pf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1;
  if (is_pair(cdddr(expr))) return(NULL);
  a1 = cadr(expr);
  if (is_pair(a1)) /* look for implicit index case */
    {
      s7_pointer v;
      if ((!is_symbol(car(a1))) || (!is_pair(cdr(a1))) || (!is_null(cddr(a1)))) return(NULL);
      v = s7_slot(sc, car(a1));
      if (!is_slot(v)) return(NULL);
      switch (type(slot_value(v)))
	{
	case T_PAIR: case T_STRING: case T_VECTOR: case T_HASH_TABLE: case T_LET:
	  return(implicit_pf_sequence_set(sc, v, cadr(a1), caddr(expr)));

	case T_INT_VECTOR: case T_FLOAT_VECTOR:
	  return(implicit_gf_sequence_set(sc, v, cadr(a1), caddr(expr)));
	}
    }
  return(NULL);
}
#endif

typedef s7_pointer (*p0_pf_t)(s7_scheme *sc);
static s7_pointer p0_pf_1(s7_scheme *sc, s7_pointer **p, p0_pf_t fnc)
{
  return(fnc(sc));
}

static s7_pf_t pf_0(s7_scheme *sc, s7_pointer expr, s7_pf_t fnc)
{
  if (!is_null(cdr(expr))) return(NULL);
  return(fnc);
}

#define PF_0(CName, Pfnc) \
  static s7_pointer CName ## _pf_0(s7_scheme *sc, s7_pointer **rp) {return(p0_pf_1(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(pf_0(sc, expr, CName ## _pf_0));}

PF_0(curlet, s7_curlet)
PF_0(rootlet, s7_rootlet)
PF_0(current_input_port, s7_current_input_port)
PF_0(current_output_port, s7_current_output_port)
PF_0(current_error_port, s7_current_error_port)

static s7_pointer c_unlet(s7_scheme *sc) {return(g_unlet(sc, sc->nil));}
PF_0(unlet, c_unlet)
static s7_pointer c_gc(s7_scheme *sc) {return(g_gc(sc, sc->nil));}
PF_0(gc, c_gc)


/* -------- PF_TO_PF -------- */
typedef s7_pointer (*pf_pf_t)(s7_scheme *sc, s7_pointer x);
static s7_pointer pf_pf_1(s7_scheme *sc, s7_pointer **p, pf_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_pointer pf_pf_s(s7_scheme *sc, s7_pointer **p, pf_pf_t fnc)
{
  s7_pointer x;
  (*p)++; x = slot_value(**p); (*p)++;
  return(fnc(sc, x));
}

static s7_pf_t pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f1, s7_pf_t f2)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      ptr_int loc;
      s7_pointer a1;
      a1 = cadr(expr);
      loc = rc_loc(sc);
      if (s7_arg_to_pf(sc, a1)) return((is_symbol(a1)) ? f2 : f1);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_gf(sc, a1)) return((is_symbol(a1)) ? f2 : f1);
    }
  return(NULL);
}

#define PF_TO_PF(CName, Pfnc)						\
  static s7_pointer CName ## _pf_p(s7_scheme *sc, s7_pointer **rp) {return(pf_pf_1(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_s(s7_scheme *sc, s7_pointer **rp) {return(pf_pf_s(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(pf_1(sc, expr, CName ## _pf_p, CName ## _pf_s));}

static s7_pointer c_symbol_to_value(s7_scheme *sc, s7_pointer x) {return(g_symbol_to_value(sc, set_plist_1(sc, x)));}
PF_TO_PF(symbol_to_value, c_symbol_to_value)
static s7_pointer c_symbol_to_string(s7_scheme *sc, s7_pointer p) {return(g_symbol_to_string(sc, set_plist_1(sc, p)));}
PF_TO_PF(symbol_to_string, c_symbol_to_string)
static s7_pointer c_gensym(s7_scheme *sc, s7_pointer p) {return(g_gensym(sc, set_plist_1(sc, p)));}
PF_TO_PF(gensym, c_gensym)

static s7_pointer c_not(s7_scheme *sc, s7_pointer x) {return((x == sc->F) ? sc->T : sc->F);}
PF_TO_PF(not, c_not)
PF_TO_PF(outlet, s7_outlet)
PF_TO_PF(openlet, s7_openlet)
PF_TO_PF(funclet, s7_funclet)
PF_TO_PF(coverlet, c_coverlet)

#define bool_with_method(Name, Checker, Method)				\
  static s7_pointer c_ ## Name (s7_scheme *sc, s7_pointer p)		\
  {									\
    s7_pointer func;							\
    if (Checker(p)) return(sc->T);					\
    if ((has_methods(p)) &&						\
        ((func = find_method(sc, find_let(sc, p), Method)) != sc->undefined)) \
      return(s7_apply_function(sc, func, list_1(sc, p)));		\
    return(sc->F);							\
  }									\
  PF_TO_PF(Name, c_ ## Name)

bool_with_method(is_char, s7_is_character, sc->is_char_symbol)
bool_with_method(is_boolean, s7_is_boolean, sc->is_boolean_symbol)
bool_with_method(is_byte_vector, is_byte_vector, sc->is_byte_vector_symbol)
bool_with_method(is_complex, is_number, sc->is_complex_symbol)
bool_with_method(is_constant, s7_is_constant, sc->is_constant_symbol)
bool_with_method(is_continuation, is_continuation, sc->is_continuation_symbol)
bool_with_method(is_c_pointer, s7_is_c_pointer, sc->is_c_pointer_symbol)
bool_with_method(is_dilambda, s7_is_dilambda, sc->is_dilambda_symbol)
bool_with_method(is_eof_object, is_eof, sc->is_eof_object_symbol)
bool_with_method(is_float_vector, is_float_vector, sc->is_float_vector_symbol)
bool_with_method(is_gensym, is_gensym, sc->is_gensym_symbol)
bool_with_method(is_hash_table, is_hash_table, sc->is_hash_table_symbol)
bool_with_method(is_input_port, is_input_port, sc->is_input_port_symbol)
bool_with_method(is_integer, is_integer, sc->is_integer_symbol)
bool_with_method(is_int_vector, is_int_vector, sc->is_int_vector_symbol)
bool_with_method(is_iterator, is_iterator, sc->is_iterator_symbol)
bool_with_method(is_keyword, is_keyword, sc->is_keyword_symbol)
bool_with_method(is_let, is_let, sc->is_let_symbol)
bool_with_method(is_macro, is_macro, sc->is_macro_symbol)
bool_with_method(is_null, is_null, sc->is_null_symbol)
bool_with_method(is_number, is_number, sc->is_number_symbol)
bool_with_method(is_openlet, s7_is_openlet, sc->is_openlet_symbol)
bool_with_method(is_output_port, is_output_port, sc->is_output_port_symbol)
bool_with_method(is_pair, is_pair, sc->is_pair_symbol)
bool_with_method(is_procedure, is_procedure, sc->is_procedure_symbol)
bool_with_method(is_rational, is_rational, sc->is_rational_symbol)
bool_with_method(is_real, is_real, sc->is_real_symbol)
bool_with_method(is_string, is_string, sc->is_string_symbol)
bool_with_method(is_symbol, is_symbol, sc->is_symbol_symbol)
bool_with_method(is_vector, s7_is_vector, sc->is_vector_symbol)
#define opt_is_list(p) s7_is_list(sc, p)
bool_with_method(is_list, opt_is_list, sc->is_list_symbol)
bool_with_method(iterator_is_at_end, iterator_is_at_end, sc->iterator_is_at_end_symbol)
bool_with_method(is_random_state, is_random_state, sc->is_random_state_symbol)

PF_TO_PF(make_keyword, c_make_keyword)
PF_TO_PF(keyword_to_symbol, c_keyword_to_symbol)
PF_TO_PF(symbol_to_keyword, c_symbol_to_keyword)

static s7_pointer c_symbol(s7_scheme *sc, s7_pointer x) {return(g_string_to_symbol_1(sc, x, sc->symbol_symbol));} 
PF_TO_PF(symbol, c_symbol)

#if 0
static s7_pointer symbol_pf_p(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(g_string_to_symbol_1(sc, x, sc->symbol_symbol));
}
#endif

/* an experiment -- we need a temp pointer per func? */
static s7_pointer string_to_symbol_pf_p(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(g_string_to_symbol_1(sc, x, sc->string_to_symbol_symbol));
}

static s7_pointer number_to_string_pf_p(s7_scheme *sc, s7_pointer **p);
static s7_pointer number_to_string_pf_s(s7_scheme *sc, s7_pointer **p);
static s7_pointer number_to_string_pf_temp(s7_scheme *sc, s7_pointer **p);
static s7_pointer number_to_string_pf_s_temp(s7_scheme *sc, s7_pointer **p);

static s7_pf_t string_to_symbol_pf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      ptr_int loc;
      loc = rc_loc(sc);
      if (s7_arg_to_pf(sc, cadr(expr))) 
	return(string_to_symbol_pf_p);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_gf(sc, cadr(expr)))
	{
	  if (sc->cur_rf->data[loc] == (s7_pointer)number_to_string_pf_p)
	    sc->cur_rf->data[loc] = (s7_pointer)number_to_string_pf_temp;
	  if (sc->cur_rf->data[loc] == (s7_pointer)number_to_string_pf_s)
	    sc->cur_rf->data[loc] = (s7_pointer)number_to_string_pf_s_temp;
	  return(string_to_symbol_pf_p);
	}
    }
  return(NULL);
}

#if (!WITH_PURE_S7)
PF_TO_PF(let_to_list, s7_let_to_list)
#endif


/* -------- PF2_TO_PF -------- */
typedef s7_pointer (*pf2_pf_t)(s7_scheme *sc, s7_pointer x, s7_pointer y);
static s7_pointer pf2_pf_1(s7_scheme *sc, s7_pointer **p, pf2_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x, y;
  f = (s7_pf_t)(**p); (*p)++;
  x = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;	
  y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer pf2_pf_sp(s7_scheme *sc, s7_pointer **p, pf2_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x, y;
  x = slot_value(**p); (*p)++;
  f = (s7_pf_t)(**p); (*p)++;	
  y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer pf2_pf_ss(s7_scheme *sc, s7_pointer **p, pf2_pf_t fnc)
{
  s7_pointer x, y;
  x = slot_value(**p); (*p)++;
  y = slot_value(**p); (*p)++;
  return(fnc(sc, x, y));
}

static s7_pointer pf2_pf_sc(s7_scheme *sc, s7_pointer **p, pf2_pf_t fnc)
{
  s7_pointer x, y;
  x = slot_value(**p); (*p)++;
  y = (**p); (*p)++;
  return(fnc(sc, x, y));
}

static s7_pointer pf2_pf_pc(s7_scheme *sc, s7_pointer **p, pf2_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x, y;
  f = (s7_pf_t)(**p); (*p)++;
  x = f(sc, p);
  y = (**p); (*p)++;
  return(fnc(sc, x, y));
}

static s7_pf_t pf_2(s7_scheme *sc, s7_pointer expr, s7_pf_t fpp, s7_pf_t fsp, s7_pf_t fss, s7_pf_t fsc, s7_pf_t fpc)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      s7_pointer a1, a2;
      xf_t *rc;

      xf_init(2);
      a1 = cadr(expr);
      a2 = caddr(expr);
      if (is_symbol(a1))
	{
	  a1 = s7_slot(sc, a1);
	  if (!is_slot(a1)) return(NULL);
	  xf_store(a1);
	  if (is_symbol(a2))
	    {
	      a2 = s7_slot(sc, a2);
	      if (!is_slot(a2)) return(NULL);
	      xf_store(a2);
	      return(fss);
	    }
	  if (is_pair(a2))
	    {
	      if (!s7_arg_to_pf(sc, a2)) return(NULL);
	      return(fsp);
	    }
	  xf_store(a2);
	  return(fsc);
	}
      if (s7_arg_to_pf(sc, a1))
	{
	  if ((!is_pair(a2)) && (!is_symbol(a2)))
	    {
	      xf_store(a2);
	      return(fpc);
	    }
	  if (s7_arg_to_pf(sc, a2))
	    return(fpp);
	}
    }
  return(NULL);
}

#define PF2_TO_PF(CName, Pfnc)						\
  static s7_pointer CName ## _pf_p2(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_1(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_p2_sp(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_sp(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_p2_ss(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_ss(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_p2_sc(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_sc(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_p2_pc(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_pc(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) \
  { \
    return(pf_2(sc, expr, CName ## _pf_p2, CName ## _pf_p2_sp, CName ## _pf_p2_ss, CName ## _pf_p2_sc, CName ## _pf_p2_pc));\
  }


static s7_pf_t pf_2_x(s7_scheme *sc, s7_pointer expr, bool (*checker)(s7_scheme *sc, s7_pointer obj), 
		      s7_pf_t fpp, s7_pf_t fpp_x, s7_pf_t fsp, s7_pf_t fss, s7_pf_t fsc, s7_pf_t fpc, s7_pf_t fpc_x)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      s7_pointer a1, a2;
      xf_t *rc;

      xf_init(2);
      a1 = cadr(expr);
      a2 = caddr(expr);
      if (is_symbol(a1))
	{
	  a1 = s7_slot(sc, a1);
	  if (!is_slot(a1)) return(NULL);
	  xf_store(a1);
	  if (is_symbol(a2))
	    {
	      a2 = s7_slot(sc, a2);
	      if (!is_slot(a2)) return(NULL);
	      xf_store(a2);
	      return(fss);
	    }
	  if (is_pair(a2))
	    {
	      if (!s7_arg_to_pf(sc, a2)) return(NULL);
	      return(fsp);
	    }
	  xf_store(a2);
	  return(fsc);
	}
      if (s7_arg_to_pf(sc, a1))
	{
	  if ((!is_pair(a2)) && (!is_symbol(a2)))
	    {
	      xf_store(a2);
	      if ((checker(sc, a1)) && (checker(sc, a2)))
		return(fpc_x);
	      return(fpc);
	    }
	  if (s7_arg_to_pf(sc, a2))
	    {
	      if ((checker(sc, a1)) && (checker(sc, a2)))
		return(fpp_x);
	      return(fpp);
	    }
	}
    }
  return(NULL);
}

#define PF2_TO_PF_X(CName, Checker, Pfnc1, Pfnc2)				\
  static s7_pointer CName ## _pf_p2_pp(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_1(sc, rp, Pfnc1));} \
  static s7_pointer CName ## _pf_p2_ppx(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_1(sc, rp, Pfnc2));} \
  static s7_pointer CName ## _pf_p2_pc(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_pc(sc, rp, Pfnc1));} \
  static s7_pointer CName ## _pf_p2_pcx(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_pc(sc, rp, Pfnc2));} \
  static s7_pointer CName ## _pf_p2_sp(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_sp(sc, rp, Pfnc1));} \
  static s7_pointer CName ## _pf_p2_ss(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_ss(sc, rp, Pfnc1));} \
  static s7_pointer CName ## _pf_p2_sc(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_sc(sc, rp, Pfnc1));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) \
   {\
     return(pf_2_x(sc, expr, Checker, \
                   CName ## _pf_p2_pp, CName ## _pf_p2_ppx, \
                   CName ## _pf_p2_sp, CName ## _pf_p2_ss, CName ## _pf_p2_sc,	\
                   CName ## _pf_p2_pc, CName ## _pf_p2_pcx));		\
   }


static s7_pointer c_is_eq(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, x == y));}
PF2_TO_PF(is_eq, c_is_eq)
static s7_pointer c_is_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, s7_is_eqv(x, y)));}
PF2_TO_PF(is_eqv, c_is_eqv)
static s7_pointer c_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, s7_is_equal(sc, x, y)));}
PF2_TO_PF(is_equal, c_is_equal)
static s7_pointer c_is_morally_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, s7_is_morally_equal(sc, x, y)));}
PF2_TO_PF(is_morally_equal, c_is_morally_equal)
PF2_TO_PF(let_ref, s7_let_ref)

static s7_pointer c_cutlet(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_cutlet(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(cutlet, c_cutlet)
static s7_pointer c_inlet(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(s7_inlet(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(inlet, c_inlet)


/* -------- PF3_TO_PF -------- */
typedef s7_pointer (*pf3_pf_t)(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z);
static s7_pointer pf3_pf_1(s7_scheme *sc, s7_pointer **p, pf3_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x, y, z;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;	
  y = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;	
  z = f(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pointer pf3_pf_s(s7_scheme *sc, s7_pointer **p, pf3_pf_t fnc)
{
  s7_pf_t f;
  s7_pointer x, y, z;
  x = slot_value(**p); (*p)++;
  f = (s7_pf_t)(**p); (*p)++;	
  y = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;	
  z = f(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pf_t pf_3(s7_scheme *sc, s7_pointer expr, s7_pf_t fp, s7_pf_t fs)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_pair(cdddr(expr))) && (is_null(cddddr(expr))))
    {
      s7_pointer a1;

      a1 = cadr(expr);
      if (is_symbol(a1))
	{
	  s7_pointer slot;
	  slot = s7_slot(sc, a1);
	  if (!is_slot(slot)) return(NULL);
	  s7_xf_store(sc, slot);
	}
      else
	{
	  if (!s7_arg_to_pf(sc, a1)) return(NULL);
	}
      if ((s7_arg_to_pf(sc, caddr(expr))) &&
	  (s7_arg_to_pf(sc, cadddr(expr))))
	return((is_symbol(a1)) ? fs : fp);
    }
  return(NULL);
}

#define PF3_TO_PF(CName, Pfnc)						\
  static s7_pointer CName ## _pf_p3(s7_scheme *sc, s7_pointer **rp) {return(pf3_pf_1(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_p3_s(s7_scheme *sc, s7_pointer **rp) {return(pf3_pf_s(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(pf_3(sc, expr, CName ## _pf_p3, CName ## _pf_p3_s));}

PF3_TO_PF(let_set, s7_let_set)
PF3_TO_PF(varlet, s7_varlet)
PF_TO_PF(c_pointer, c_c_pointer)


/* -------- PIF_TO_PF -------- */
typedef s7_pointer (*pif_pf_t)(s7_scheme *sc, s7_pointer x, s7_int y);
static s7_pointer pif_pf_1(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
{
  s7_pf_t pf;
  s7_if_t xf;
  s7_pointer x;
  s7_int y;
  pf = (s7_pf_t)(**p); (*p)++;	
  x = pf(sc, p);
  xf = (s7_if_t)(**p); (*p)++;	
  y = xf(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer pif_pf_s(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
{
  s7_if_t xf;
  s7_pointer x;
  s7_int y;
  x = slot_value(**p); (*p)++;
  xf = (s7_if_t)(**p); (*p)++;	
  y = xf(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer pif_pf_pp(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
{
  s7_pf_t pf;
  s7_pointer x, y;
  pf = (s7_pf_t)(**p); (*p)++;	
  x = pf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;	
  y = pf(sc, p);
  if (!is_integer(y)) 
    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
  return(fnc(sc, x, integer(y)));
}

static s7_pointer pif_pf_sp(s7_scheme *sc, s7_pointer **p, pif_pf_t fnc)
{
  s7_pf_t pf;
  s7_pointer x, y;
  x = slot_value(**p); (*p)++;
  pf = (s7_pf_t)(**p); (*p)++;	
  y = pf(sc, p);
  if (!is_integer(y)) 
    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A should be an integer"), y)));
  return(fnc(sc, x, integer(y)));
}

static s7_pf_t pif_1(s7_scheme *sc, s7_pointer expr, s7_pf_t fpi, s7_pf_t fsi, s7_pf_t fpp, s7_pf_t fsp) 
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      s7_pointer a1, a2;
      ptr_int loc;
      a1 = cadr(expr);
      a2 = caddr(expr);
      if (is_symbol(a1))
	{
	  s7_pointer slot;
	  slot = s7_slot(sc, a1);
	  if (!is_slot(slot)) return(NULL);
	  s7_xf_store(sc, slot);
	}
      else 
	{
	  if (!s7_arg_to_pf(sc, a1))
	    return(NULL);
	}
      loc = rc_loc(sc);
      if (s7_arg_to_if(sc, a2))
	return((is_symbol(a1)) ? fsi : fpi);

      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_pf(sc, a2))
	return((is_symbol(a1)) ? fsp : fpp);
    }
  return(NULL);
}

#define PIF_TO_PF(CName, Pfnc)						\
  static s7_pointer CName ## _pf_pi(s7_scheme *sc, s7_pointer **rp) {return(pif_pf_1(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_si(s7_scheme *sc, s7_pointer **rp) {return(pif_pf_s(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_pp(s7_scheme *sc, s7_pointer **rp) {return(pif_pf_pp(sc, rp, Pfnc));} \
  static s7_pointer CName ## _pf_sp(s7_scheme *sc, s7_pointer **rp) {return(pif_pf_sp(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(pif_1(sc, expr, CName ## _pf_pi, CName ## _pf_si, CName ## _pf_pp, CName ## _pf_sp));}


/* -------- PPIF_TO_PF -------- */
typedef s7_pointer (*ppif_pf_t)(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int z);
static s7_pointer ppif_pf_1(s7_scheme *sc, s7_pointer **p, ppif_pf_t fnc) /* other case is pf2_pf_1, type pf2_pf_t */
{
  s7_pf_t pf;
  s7_if_t xf;
  s7_pointer x, y;
  s7_int z;
  pf = (s7_pf_t)(**p); (*p)++;	
  x = pf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;	
  y = pf(sc, p);
  xf = (s7_if_t)(**p); (*p)++;	
  z = xf(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pf_t ppif_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f1, s7_pf_t f2)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))))
    {
      ptr_int loc;
      if (!s7_arg_to_pf(sc, cadr(expr))) return(NULL);
      loc = rc_loc(sc);
      if (!s7_arg_to_pf(sc, caddr(expr)))
	{
	  sc->cur_rf->cur = rc_go(sc, loc);
	  if (!s7_arg_to_gf(sc, caddr(expr))) return(NULL);
	}
      if (is_null(cdddr(expr)))	return(f1);
      if (!is_null(cddddr(expr))) return(NULL);
      if (s7_arg_to_if(sc, cadddr(expr))) return(f2);
    }
  return(NULL);
}

#define PPIF_TO_PF(CName, Pfnc1, Pfnc2)					\
  static s7_pointer CName ## _pf_pp(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_1(sc, rp, Pfnc1));} \
  static s7_pointer CName ## _pf_ppi(s7_scheme *sc, s7_pointer **rp) {return(ppif_pf_1(sc, rp, Pfnc2));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(ppif_1(sc, expr, CName ## _pf_pp, CName ## _pf_ppi));}


/* -------- PIPF_TO_PF -------- */
typedef s7_pointer (*pipf_pf_t)(s7_scheme *sc, s7_pointer x, s7_int y, s7_pointer z);
static s7_pointer pipf_pf_slot(s7_scheme *sc, s7_pointer **p, pipf_pf_t fnc)
{
  s7_pf_t pf;
  s7_pointer x, z;
  s7_int y;
  x = (s7_pointer)(**p); (*p)++;
  y = s7_integer(slot_value(**p)); (*p)++;
  pf = (s7_pf_t)(**p); (*p)++;	
  z = pf(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pointer pipf_pf_s(s7_scheme *sc, s7_pointer **p, pipf_pf_t fnc)
{
  s7_pf_t pf;
  s7_if_t xf;
  s7_pointer x, z;
  s7_int y;
  x = (s7_pointer)(**p); (*p)++;
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;	
  z = pf(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pointer pipf_pf_seq(s7_scheme *sc, s7_pointer **p, pipf_pf_t fnc) /* used in implicit_sequence_set */
{
  s7_pf_t pf;
  s7_if_t xf;
  s7_pointer x, z;
  s7_int y;
  x = slot_value(**p); (*p)++;
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;	
  z = pf(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_pointer pipf_pf_a(s7_scheme *sc, s7_pointer **p, pipf_pf_t fnc)
{
  s7_pf_t pf;
  s7_if_t xf;
  s7_pointer x, z;
  s7_int y;
  pf = (s7_pf_t)(**p); (*p)++;	
  x = pf(sc, p);
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;	
  z = pf(sc, p);
  return(fnc(sc, x, y, z));
}

enum {TEST_NO_S, TEST_SS, TEST_SI, TEST_SQ}; /* si = sym ind, ss = sym sym for first two */
typedef int (*pf_i_t)(s7_scheme *sc, s7_pointer x);
static s7_pf_t pipf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f1, s7_pf_t f2, s7_pf_t f3, pf_i_t tester)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_pair(cdddr(expr))) && (is_null(cddddr(expr))))
    {
      int choice;
      choice = tester(sc, expr);
      if ((choice == TEST_SS) || (choice == TEST_SI) ||
	  ((choice == TEST_NO_S) &&
	   (s7_arg_to_pf(sc, cadr(expr))) &&
	   (s7_arg_to_if(sc, caddr(expr)))))
	{
	  ptr_int loc;
	  loc = rc_loc(sc);
	  if (s7_arg_to_pf(sc, cadddr(expr)))
	    return((choice == TEST_SS) ?  f1 : ((choice == TEST_SI) ? f2 : f3));
	  sc->cur_rf->cur = rc_go(sc, loc);
	  if (s7_arg_to_gf(sc, cadddr(expr)))
	    return((choice == TEST_SS) ? f1 : ((choice == TEST_SI) ? f2 : f3));
	}
    }
  return(NULL);
}

#define PIPF_TO_PF(CName, F1, F2, Tester) \
  static s7_pointer CName ## _pf_slot(s7_scheme *sc, s7_pointer **rp) {return(pipf_pf_slot(sc, rp, F1));} \
  static s7_pointer CName ## _pf_s(s7_scheme *sc, s7_pointer **rp) {return(pipf_pf_s(sc, rp, F1));} \
  static s7_pointer CName ## _pf_seq(s7_scheme *sc, s7_pointer **rp) {return(pipf_pf_seq(sc, rp, F1));} \
  static s7_pointer CName ## _pf_a(s7_scheme *sc, s7_pointer **rp) {return(pipf_pf_a(sc, rp, F2));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(pipf_1(sc, expr, CName ## _pf_slot, CName ## _pf_s, CName ## _pf_a, Tester));}


/* -------- IF_TO_IF -------- */
typedef s7_int (*if_if_t)(s7_scheme *sc, s7_int x);
static s7_int if_if_1(s7_scheme *sc, s7_pointer **p, if_if_t fnc)
{
  s7_if_t f;
  s7_int x;
  f = (s7_if_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_if_t if_1(s7_scheme *sc, s7_pointer expr, s7_if_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_if(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define IF_TO_IF(CName, Ifnc)			\
  static s7_int CName ## _if_i(s7_scheme *sc, s7_pointer **rp) {return(if_if_1(sc, rp, Ifnc));} \
  static s7_if_t CName ## _if(s7_scheme *sc, s7_pointer expr) {return(if_1(sc, expr, CName ## _if_i));}

#if (!WITH_GMP)

/* -------- IF2_TO_IF -------- */
typedef s7_int (*if2_if_t)(s7_scheme *sc, s7_int x, s7_int y);
static s7_int if2_if_1(s7_scheme *sc, s7_pointer **p, if2_if_t fnc)
{
  s7_if_t f;
  s7_int x, y;
  f = (s7_if_t)(**p); (*p)++;	
  x = f(sc, p);
  f = (s7_if_t)(**p); (*p)++;	
  y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_if_t if_2(s7_scheme *sc, s7_pointer expr, s7_if_t f)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))) &&
      (s7_arg_to_if(sc, cadr(expr))) &&
      (s7_arg_to_if(sc, caddr(expr))))
    return(f);
  return(NULL);
}

#define IF2_TO_IF(CName, Ifnc)						\
  static s7_int CName ## _if_i2(s7_scheme *sc, s7_pointer **rp) {return(if2_if_1(sc, rp, Ifnc));} \
  static s7_if_t CName ## _if(s7_scheme *sc, s7_pointer expr) {return(if_2(sc, expr, CName ## _if_i2));}


/* -------- IF_3_TO_IF -------- */

typedef s7_int (*if3_if_t)(s7_scheme *sc, s7_int x, s7_int y, s7_int z);
static s7_int if3_if_1(s7_scheme *sc, s7_pointer **p, if3_if_t fnc)
{
  s7_if_t f;
  s7_int x, y, z;
  f = (s7_if_t)(**p); (*p)++;	
  x = f(sc, p);
  f = (s7_if_t)(**p); (*p)++;	
  y = f(sc, p);
  f = (s7_if_t)(**p); (*p)++;	
  z = f(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_if_t if_3(s7_scheme *sc, s7_pointer expr, s7_if_t f1, s7_if_t f2, s7_if_t f3)
{
  if (!is_pair(cdr(expr))) return(NULL);
  if (!s7_arg_to_if(sc, cadr(expr))) return(NULL);
  if (is_null(cddr(expr))) return(f1);
  if (!s7_arg_to_if(sc, caddr(expr))) return(NULL);
  if (is_null(cdddr(expr))) return(f2);
  if (!s7_arg_to_if(sc, cadddr(expr))) return(NULL);
  if (is_null(cddddr(expr))) return(f3);
  return(NULL);
}

#define IF_3_TO_IF(CName, Ifnc1, Ifnc2, Ifnc3)				\
  static s7_int CName ## _if_i1(s7_scheme *sc, s7_pointer **rp) {return(if_if_1(sc, rp, Ifnc1));} \
  static s7_int CName ## _if_i2(s7_scheme *sc, s7_pointer **rp) {return(if2_if_1(sc, rp, Ifnc2));} \
  static s7_int CName ## _if_i3(s7_scheme *sc, s7_pointer **rp) {return(if3_if_1(sc, rp, Ifnc3));} \
  static s7_if_t CName ## _if(s7_scheme *sc, s7_pointer expr) {return(if_3(sc, expr, CName ## _if_i1, CName ## _if_i2, CName ## _if_i3));}
#endif /* gmp */


/* -------- IF_TO_PF -------- */
typedef s7_pointer (*if_pf_t)(s7_scheme *sc, s7_int x);
static s7_pointer if_p_1(s7_scheme *sc, s7_pointer **p, if_pf_t fnc)
{
  s7_if_t f;
  s7_int x;
  f = (s7_if_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_pf_t if_pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_if(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define IF_TO_PF(CName, Ifnc)			\
  static s7_pointer CName ## _pf_i(s7_scheme *sc, s7_pointer **rp) {return(if_p_1(sc, rp, Ifnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(if_pf_1(sc, expr, CName ## _pf_i));}


/* -------- PF_TO_IF -------- */
typedef s7_int (*pf_if_t)(s7_scheme *sc, s7_pointer x);
static s7_int pf_i_1(s7_scheme *sc, s7_pointer **p, pf_if_t fnc)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_if_t pf_if_1(s7_scheme *sc, s7_pointer expr, s7_if_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_pf(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define PF_TO_IF(CName, Pfnc)			\
  static s7_int CName ## _if_p(s7_scheme *sc, s7_pointer **rp) {return(pf_i_1(sc, rp, Pfnc));} \
  static s7_if_t CName ## _if(s7_scheme *sc, s7_pointer expr) {return(pf_if_1(sc, expr, CName ## _if_p));}


/* -------- PF_TO_RF -------- */
typedef s7_double (*pf_rf_t)(s7_scheme *sc, s7_pointer x);
static s7_double pf_r_1(s7_scheme *sc, s7_pointer **p, pf_rf_t fnc)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_rf_t pf_rf_1(s7_scheme *sc, s7_pointer expr, s7_rf_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_rf(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define PF_TO_RF(CName, Pfnc)			\
  static s7_double CName ## _rf_p(s7_scheme *sc, s7_pointer **rp) {return(pf_r_1(sc, rp, Pfnc));} \
  static s7_rf_t CName ## _rf(s7_scheme *sc, s7_pointer expr) {return(pf_rf_1(sc, expr, CName ## _rf_p));}


#if (!WITH_GMP)

/* -------- RF_TO_IF -------- */
typedef s7_int (*rf_if_t)(s7_scheme *sc, s7_double x);
static s7_int rf_i_1(s7_scheme *sc, s7_pointer **p, rf_if_t fnc)
{
  s7_rf_t f;
  s7_double x;
  f = (s7_rf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_if_t rf_if_1(s7_scheme *sc, s7_pointer expr, s7_if_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_rf(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define RF_TO_IF(CName, Rfnc)			\
  static s7_int CName ## _if_r(s7_scheme *sc, s7_pointer **rp) {return(rf_i_1(sc, rp, Rfnc));} \
  static s7_if_t CName ## _if(s7_scheme *sc, s7_pointer expr) {return(rf_if_1(sc, expr, CName ## _if_r));}

#endif /* gmp */

/* -------- RF_TO_PF -------- */
typedef s7_pointer (*rf_pf_t)(s7_scheme *sc, s7_double x);
static s7_pointer rf_p_1(s7_scheme *sc, s7_pointer **p, rf_pf_t fnc)
{
  s7_rf_t f;
  s7_double x;
  f = (s7_rf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

#if (!WITH_GMP)

static s7_pf_t rf_pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_rf(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define RF_TO_PF(CName, Pfnc)			\
  static s7_pointer CName ## _pf_r(s7_scheme *sc, s7_pointer **rp) {return(rf_p_1(sc, rp, Pfnc));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(rf_pf_1(sc, expr, CName ## _pf_r));}


/* -------- RF_TO_RF -------- */
typedef s7_double (*rf_rf_t)(s7_scheme *sc, s7_double x);
static s7_double rf_rf_1(s7_scheme *sc, s7_pointer **p, rf_rf_t fnc)
{
  s7_rf_t f;
  s7_double x;
  f = (s7_rf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(fnc(sc, x));
}

static s7_rf_t rf_1(s7_scheme *sc, s7_pointer expr, s7_rf_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && (s7_arg_to_rf(sc, cadr(expr))))
    return(f);
  return(NULL);
}

#define RF_TO_RF(CName, Rfnc)						\
  static s7_double CName ## _rf_r(s7_scheme *sc, s7_pointer **rp) {return(rf_rf_1(sc, rp, Rfnc));} \
  static s7_rf_t CName ## _rf(s7_scheme *sc, s7_pointer expr) {return(rf_1(sc, expr, CName ## _rf_r));}

#define DIRECT_RF_TO_RF(CName) \
  static s7_double CName ## _rf_r(s7_scheme *sc, s7_pointer **p) {s7_rf_t f; s7_double x; f = (s7_rf_t)(**p); (*p)++; x = f(sc, p); return(CName(x));} \
  static s7_rf_t CName ## _rf(s7_scheme *sc, s7_pointer expr) {if (s7_arg_to_rf(sc, s7_cadr(expr))) return(CName ## _rf_r); return(NULL);}



/* -------- RF2_TO_RF -------- */
typedef s7_double (*rf2_rf_t)(s7_scheme *sc, s7_double x, s7_double y);
static s7_double rf2_rf_1(s7_scheme *sc, s7_pointer **p, rf2_rf_t fnc)
{
  s7_rf_t f;
  s7_double x, y;
  f = (s7_rf_t)(**p); (*p)++;	
  x = f(sc, p);
  f = (s7_rf_t)(**p); (*p)++;	
  y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_rf_t rf_2(s7_scheme *sc, s7_pointer expr, s7_rf_t f)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))) && 
      (s7_arg_to_rf(sc, cadr(expr))) &&
      (s7_arg_to_rf(sc, caddr(expr))))
    return(f);
  return(NULL);
}

#define RF2_TO_RF(CName, Rfnc)						\
  static s7_double CName ## _rf_r2(s7_scheme *sc, s7_pointer **rp) {return(rf2_rf_1(sc, rp, Rfnc));} \
  static s7_rf_t CName ## _rf(s7_scheme *sc, s7_pointer expr) {return(rf_2(sc, expr, CName ## _rf_r2));}


/* -------- RF_3_TO_RF -------- */

typedef s7_double (*rf3_rf_t)(s7_scheme *sc, s7_double x, s7_double y, s7_double z);
static s7_double rf3_rf_1(s7_scheme *sc, s7_pointer **p, rf3_rf_t fnc)
{
  s7_rf_t f;
  s7_double x, y, z;
  f = (s7_rf_t)(**p); (*p)++;	
  x = f(sc, p);
  f = (s7_rf_t)(**p); (*p)++;	
  y = f(sc, p);
  f = (s7_rf_t)(**p); (*p)++;	
  z = f(sc, p);
  return(fnc(sc, x, y, z));
}

static s7_rf_t rf_3(s7_scheme *sc, s7_pointer expr, s7_rf_t f1, s7_rf_t f2, s7_rf_t f3)
{
  if (!is_pair(cdr(expr))) return(NULL);
  if (!s7_arg_to_rf(sc, cadr(expr))) return(NULL);
  if (is_null(cddr(expr))) return(f1);
  if (!s7_arg_to_rf(sc, caddr(expr))) return(NULL);
  if (is_null(cdddr(expr))) return(f2);
  if (!s7_arg_to_rf(sc, cadddr(expr))) return(NULL);
  if (is_null(cddddr(expr))) return(f3);
  return(NULL);
}

#define RF_3_TO_RF(CName, Rfnc1, Rfnc2, Rfnc3)				\
  static s7_double CName ## _rf_r1(s7_scheme *sc, s7_pointer **rp) {return(rf_rf_1(sc, rp, Rfnc1));} \
  static s7_double CName ## _rf_r2(s7_scheme *sc, s7_pointer **rp) {return(rf2_rf_1(sc, rp, Rfnc2));} \
  static s7_double CName ## _rf_r3(s7_scheme *sc, s7_pointer **rp) {return(rf3_rf_1(sc, rp, Rfnc3));} \
  static s7_rf_t CName ## _rf(s7_scheme *sc, s7_pointer expr) {return(rf_3(sc, expr, CName ## _rf_r1, CName ## _rf_r2, CName ## _rf_r3));}


/* -------- R_P_F_TO_PF -------- */
static s7_pf_t rpf_pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t fnc1, s7_pf_t fnc2, s7_pf_t fnc3)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      ptr_int loc;
      loc = rc_loc(sc);
      if (s7_arg_to_rf(sc, cadr(expr))) return(fnc1);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_pf(sc, cadr(expr)))	return(fnc2);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_gf(sc, cadr(expr)))	return(fnc3);
    }
  return(NULL);
}

#define R_P_F_TO_PF(CName, PFnc1, PFnc2, PFnc3)				\
  static s7_pointer CName ## _pf_r(s7_scheme *sc, s7_pointer **rp) {return(rf_p_1(sc, rp, PFnc1));} \
  static s7_pointer CName ## _pf_p(s7_scheme *sc, s7_pointer **rp) {return(pf_pf_1(sc, rp, PFnc2));} \
  static s7_pointer CName ## _pf_g(s7_scheme *sc, s7_pointer **rp) {return(pf_pf_1(sc, rp, PFnc3));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(rpf_pf_1(sc, expr, CName ## _pf_r, CName ## _pf_p, CName ## _pf_g));}

#endif /* gmp */

/* -------- XF_TO_PF -------- */
static s7_pf_t xf_pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f1, s7_pf_t f2, s7_pf_t f3)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      ptr_int loc;
      loc = rc_loc(sc);
      if (s7_arg_to_if(sc, cadr(expr))) return(f1);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_rf(sc, cadr(expr))) return(f2);
      sc->cur_rf->cur = rc_go(sc, loc);
      if (s7_arg_to_pf(sc, cadr(expr))) return(f3);
    }
  return(NULL);
}

#define XF_TO_PF(CName, PFnc1, PFnc2, PFnc3)					\
  static s7_pointer CName ## _pf_i(s7_scheme *sc, s7_pointer **rp) {return(if_p_1(sc, rp, PFnc1));} \
  static s7_pointer CName ## _pf_r(s7_scheme *sc, s7_pointer **rp) {return(rf_p_1(sc, rp, PFnc2));} \
  static s7_pointer CName ## _pf_p(s7_scheme *sc, s7_pointer **rp) {return(pf_pf_1(sc, rp, PFnc3));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) {return(xf_pf_1(sc, expr, CName ## _pf_i, CName ## _pf_r, CName ## _pf_p));}


/* -------- XF2_TO_PF -------- */
typedef s7_pointer (*if2_pf_t)(s7_scheme *sc, s7_int x, s7_int y);
typedef s7_pointer (*rf2_pf_t)(s7_scheme *sc, s7_double x, s7_double y);
static s7_pointer if2_pf_1(s7_scheme *sc, s7_pointer **p, if2_pf_t fnc)
{
  s7_if_t f;
  s7_int x, y;
  f = (s7_if_t)(**p); (*p)++;	x = f(sc, p);
  f = (s7_if_t)(**p); (*p)++;	y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer rf2_pf_1(s7_scheme *sc, s7_pointer **p, rf2_pf_t fnc)
{
  s7_rf_t f;
  s7_double x, y;
  f = (s7_rf_t)(**p); (*p)++;	x = f(sc, p);
  f = (s7_rf_t)(**p); (*p)++;	y = f(sc, p);
  return(fnc(sc, x, y));
}

static s7_pointer rf2_pf_sc(s7_scheme *sc, s7_pointer **p, rf2_pf_t fnc)
{
  s7_pointer xp, yp;
  (*p)++; 
  xp = slot_value(**p); (*p) += 2;
  yp = (**p); (*p)++;
  if ((is_t_real(xp)) && (is_t_real(yp)))
    return(fnc(sc, real(xp), real(yp)));
  return(fnc(sc, s7_number_to_real(sc, xp), s7_number_to_real(sc, yp)));
}

static s7_pf_t xf2_pf_1(s7_scheme *sc, s7_pointer expr, s7_pf_t f1, s7_pf_t f2, s7_pf_t f3, s7_pf_t f4, s7_pf_t f5)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      ptr_int loc;
      s7_pointer a1, a2;
      a1 = cadr(expr);
      a2 = caddr(expr);
      if ((is_symbol(a1)) && (is_symbol(a2)))
	{
	  a1 = s7_slot(sc, a1);
	  if (!is_slot(a1)) return(NULL);
	  s7_xf_store(sc, a1);
	  a2 = s7_slot(sc, a2);
	  if (!is_slot(a2)) return(NULL);
	  s7_xf_store(sc, a2);
	  return(f5);
	}
      loc = rc_loc(sc);
      if ((s7_arg_to_if(sc, a1)) && (s7_arg_to_if(sc, a2))) return(f1);
      sc->cur_rf->cur = rc_go(sc, loc);
      if ((s7_arg_to_rf(sc, a1)) && (s7_arg_to_rf(sc, a2))) return(((is_symbol(a1)) && (is_real(a2))) ? f3 : f2);
      sc->cur_rf->cur = rc_go(sc, loc);	
      if ((s7_arg_to_pf(sc, a1)) && (s7_arg_to_pf(sc, a2))) return(f4);
    }
  return(NULL);
}

#define XF2_TO_PF(CName, PFnc1, PFnc2, PFnc3)					\
  static s7_pointer CName ## _pf_i2(s7_scheme *sc, s7_pointer **rp) {return(if2_pf_1(sc, rp, PFnc1));} \
  static s7_pointer CName ## _pf_r2(s7_scheme *sc, s7_pointer **rp) {return(rf2_pf_1(sc, rp, PFnc2));} \
  static s7_pointer CName ## _pf_r2_sc(s7_scheme *sc, s7_pointer **rp) {return(rf2_pf_sc(sc, rp, PFnc2));} \
  static s7_pointer CName ## _pf_p2(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_1(sc, rp, PFnc3));} \
  static s7_pointer CName ## _pf_ss(s7_scheme *sc, s7_pointer **rp) {return(pf2_pf_ss(sc, rp, PFnc3));} \
  static s7_pf_t CName ## _pf(s7_scheme *sc, s7_pointer expr) \
  {\
    return(xf2_pf_1(sc, expr, CName ## _pf_i2, CName ## _pf_r2, CName ## _pf_r2_sc, CName ## _pf_p2, CName ## _pf_ss));	\
  }

#if WITH_OPTIMIZATION
static s7_pointer if_pf_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t test, t;
  s7_pointer val;
  ptr_int e1;
  
  test = (s7_pf_t)(**p); (*p)++;
  t = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;

  val = test(sc, p);
  if (val != sc->F)
    val = t(sc, p);
  else val = sc->unspecified;
  (*p) = rc_go(sc, e1);

  return(val);
}

static s7_pointer if_pf_not_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t test, t;
  s7_pointer val;
  ptr_int e1; 
  
  test = (s7_pf_t)(**p); (*p)++;
  t = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;

  val = test(sc, p);
  if (val == sc->F)
    val = t(sc, p);
  else val = sc->unspecified;
  (*p) = rc_go(sc, e1);

  return(val);
}

#if (!WITH_GMP)
static s7_pointer equal_p2(s7_scheme *sc, s7_pointer **p);
#endif
static s7_pointer c_equal_2(s7_scheme *sc, s7_pointer x, s7_pointer y);

static s7_pointer if_pf_not_equal_2(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t t, eq2;
  s7_pointer val, x, y;
  ptr_int e1; 
  
  (*p)++;
  t = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;

  eq2 = (s7_pf_t)(**p); (*p)++;	
  x = eq2(sc, p);
  eq2 = (s7_pf_t)(**p); (*p)++;	
  y = eq2(sc, p);

  if (c_equal_2(sc, x, y) == sc->F)
    val = t(sc, p);
  else val = sc->unspecified;
  (*p) = rc_go(sc, e1);

  return(val);
}

static s7_pointer if_pf_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x;
  s7_pf_t r1, r2;
  s7_pf_t pf;
  s7_pointer val;
  ptr_int e1, e2;

  pf = (s7_pf_t)(**p); (*p)++;
  r1 = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;
  r2 = (s7_pf_t)(**p); (*p)++;
  e2 = (ptr_int)(**p); (*p)++;

  val = pf(sc, p);
  if (val != sc->F)
    {
      x = r1(sc, p);
      (*p) = rc_go(sc, e2);
    }
  else 
    {
      (*p) = rc_go(sc, e1);
      x = r2(sc, p);
    }
  return(x);
}

static s7_pf_t if_pf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer test, t, f = NULL;
  s7_int test_loc, t_loc, f_loc = 0, e1_loc, e2_loc = 0;
  bool not_case = false;
  ptr_int loc;
  xf_t *rc;

  if ((is_null(cdr(expr))) || (is_null(cddr(expr)))) return(NULL);
  test = cadr(expr);
  if ((is_pair(test)) && (car(test) == sc->not_symbol))
    {
      not_case = true;
      test = cadr(test);
    }
  t = caddr(expr);

  xf_init(5);
  xf_save_loc3(test_loc, t_loc, e1_loc);

  if (is_pair(cdddr(expr)))
    {
      f = cadddr(expr);
      xf_save_loc2(f_loc, e2_loc);
    }

  if (!arg_to_pf(sc, test, test_loc)) return(NULL);
  loc = rc_loc(sc);
  if (!arg_to_pf(sc, t, t_loc))
    {
      sc->cur_rf->cur = rc_go(sc, loc);
      if (!arg_to_if(sc, t, t_loc)) return(NULL);
    }
  xf_store_at(e1_loc, (s7_pointer)rc_loc(sc));

  if (f)
    {
      if (!arg_to_pf(sc, f, f_loc)) return(NULL);
      xf_store_at(e2_loc, (s7_pointer)rc_loc(sc));
    }

  if (!f)
    {
      if (not_case) 
	{
#if (!WITH_GMP)
	  if ((s7_pointer)equal_p2 == sc->cur_rf->data[test_loc])
	    return(if_pf_not_equal_2);
#endif
	  return(if_pf_not_xx);
	}
      return(if_pf_xx);
    }
  return(if_pf_xxx);
}


static s7_double if_rf_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_double x;
  s7_rf_t r1, r2;
  s7_pf_t pf;
  s7_pointer val;
  ptr_int e1, e2;
  
  pf = (s7_pf_t)(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  r2 = (s7_rf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;
  e2 = (ptr_int)(**p); (*p)++;

  val = pf(sc, p);
  if (val != sc->F)
    {
      x = r1(sc, p);
      (*p) = rc_go(sc, e2);
    }
  else 
    {
      (*p) = rc_go(sc, e1);
      x = r2(sc, p);
    }
  return(x);
}

static s7_rf_t if_rf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer test, t, f;
  s7_int test_loc, t_loc, f_loc = 0, e1_loc = 0, e2_loc;
  xf_t *rc;

  if ((is_null(cdr(expr))) || (is_null(cddr(expr))) || (is_null(cdddr(expr)))) return(NULL);
  test = cadr(expr);
  t = caddr(expr);
  f = cadddr(expr);
  xf_init(5);

  xf_save_loc3(test_loc, t_loc, f_loc);
  xf_save_loc2(e1_loc, e2_loc);

  if (!arg_to_pf(sc, test, test_loc)) return(NULL);
  if (!arg_to_rf(sc, t, t_loc)) return(NULL);
  xf_store_at(e1_loc, (s7_pointer)rc_loc(sc));
  if (!arg_to_rf(sc, f, f_loc)) return(NULL);
  xf_store_at(e2_loc, (s7_pointer)rc_loc(sc));

  return(if_rf_xxx);
}

static s7_pointer quote_pf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s;
  s = **p; (*p)++;
  return(s);
}

static s7_pf_t quote_pf(s7_scheme *sc, s7_pointer expr)
{
  if (is_symbol(cadr(expr)))
    {
      xf_t *rc;
      xf_init(1);
      xf_store(cadr(expr));
      return(quote_pf_s);
    }
  return(NULL);
}

static s7_pointer or_pf_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf1, pf2;
  ptr_int e1;
  s7_pointer val;

  pf1 = (s7_pf_t)(**p); (*p)++;
  pf2 = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;

  val = pf1(sc, p);
  if (val != sc->F)
    {
      (*p) = rc_go(sc, e1);
      return(val);
    }
  return(pf2(sc, p));
}

static s7_pf_t or_pf(s7_scheme *sc, s7_pointer expr)
{
  int len;
  len = s7_list_length(sc, expr);
  if (len == 3)
    {
      int loc1, loc2, eloc;
      xf_t *rc;
      xf_init(3);
      xf_save_loc3(loc1, loc2, eloc);

      if (!arg_to_pf(sc, cadr(expr), loc1)) return(NULL);
      if (!arg_to_pf(sc, caddr(expr), loc2)) return(NULL);
      xf_store_at(eloc, (s7_pointer)rc_loc(sc));

      return(or_pf_xx);
    }
  return(NULL);
}

static s7_pointer and_pf_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf1, pf2;
  ptr_int e1;

  pf1 = (s7_pf_t)(**p); (*p)++;
  pf2 = (s7_pf_t)(**p); (*p)++;
  e1 = (ptr_int)(**p); (*p)++;

  if (pf1(sc, p) == sc->F) 
    {
      (*p) = rc_go(sc, e1);
      return(sc->F);
    }
  return(pf2(sc, p));
}

static s7_pf_t and_pf(s7_scheme *sc, s7_pointer expr)
{
  int len;
  len = s7_list_length(sc, expr);
  if (len == 3)
    {
      s7_int loc1, loc2, eloc;
      xf_t *rc;
      xf_init(3);
      xf_save_loc3(loc1, loc2, eloc);

      if (!arg_to_pf(sc, cadr(expr), loc1)) return(NULL);
      if (!arg_to_pf(sc, caddr(expr), loc2)) return(NULL);
      xf_store_at(eloc, (s7_pointer)rc_loc(sc));

      return(and_pf_xx);
    }
  return(NULL);
}
#endif


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

static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args)
{
  #define H_is_continuation "(continuation? obj) returns #t if obj is a continuation"
  #define Q_is_continuation pl_bt

  check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args);
  /* is this the right thing?  It returns #f for call-with-exit ("goto") because
   *   that form of continuation can't continue (via a jump back to its context).
   * 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);
	  set_cdr(p, fast);
	  return(sc->w);
	}

      set_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);
	  set_cdr(p, fast);
	  return(sc->w);
	}
      /* if unrolled further, it's a lot slower? */
      set_cdr(p, cons(sc, car(fast), sc->nil));
      p = cdr(p);

      fast = cdr(fast);
      slow = cdr(slow);
      if (fast == slow)
	{
	  /* try to preserve the original cyclic structure */
	  s7_pointer p1, f1, p2, f2;
	  set_match_pair(a);
	  for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1))
	    set_match_pair(f1);
	  for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2))
	    clear_match_pair(f2);
	  for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2))
	    {
	      clear_match_pair(f1);
	      f1 = cdr(f1);
	      clear_match_pair(f1);
	      if (f1 == f2) break;
	    }
	  if (is_null(p1))
	    set_cdr(p2, p2);
	  else set_cdr(p1, p2);
	  return(sc->w);
	}
    }
  return(sc->w);
}


static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer nobj;
  new_cell(sc, nobj, T_COUNTER);
  counter_set_result(nobj, counter_result(obj));
  counter_set_list(nobj, counter_list(obj));
  counter_set_capture(nobj, counter_capture(obj));
  counter_set_let(nobj, counter_let(obj));
  counter_set_slots(nobj, counter_slots(obj));
  return(nobj);
}


static s7_pointer copy_stack(s7_scheme *sc, s7_pointer old_v, int top)
{
  #define CC_INITIAL_STACK_SIZE 256 /* 128 is too small here */
  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 (len > CC_INITIAL_STACK_SIZE)
    {
      if (top < CC_INITIAL_STACK_SIZE / 4)
	len = CC_INITIAL_STACK_SIZE;
    }
  else
    {
      if (len < CC_INITIAL_STACK_SIZE)
	len = CC_INITIAL_STACK_SIZE;
    }
  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.
   */

  new_v = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
  set_type(new_v, T_STACK);
  temp_stack_top(new_v) = top;
  nv = vector_elements(new_v);
  ov = vector_elements(old_v);
  if (len > 0)
    memcpy((void *)nv, (void *)ov, len * sizeof(s7_pointer));

  s7_gc_on(sc, false);
  for (i = 2; i < top; i += 4)
    {
      s7_pointer p;
      p = ov[i];                            /* args */
      if (is_pair(p))                       /* args need not be a list (it can be a port or #f, etc) */
	nv[i] = protected_list_copy(sc, p); /* args (copy is needed -- see s7test.scm) */
      /* 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))
       */
      else
	{
	  if (is_counter(p))              /* these can only occur in this context */
	    nv[i] = copy_counter(sc, p);
	}
    }
  s7_gc_on(sc, true);
  return(new_v);
}


static s7_pointer make_goto(s7_scheme *sc)
{
  s7_pointer x;
  new_cell(sc, x, T_GOTO | T_PROCEDURE);
  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;
  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));
  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 s7_pointer make_baffle(s7_scheme *sc)
{
  s7_pointer x;
  new_cell(sc, x, T_BAFFLE);
  baffle_key(x) = sc->baffle_ctr++;
  return(x);
}


static bool find_baffle(s7_scheme *sc, int key)
{
  /* search backwards through sc->envir for sc->baffle_symbol with key as value
   */
  s7_pointer x, y;
  for (x = sc->envir; is_let(x); x = outlet(x))
    for (y = let_slots(x); is_slot(y); y = next_slot(y))
      if ((slot_symbol(y) == sc->baffle_symbol) &&
	  (baffle_key(slot_value(y)) == key))
	return(true);

  if ((is_slot(global_slot(sc->baffle_symbol))) &&
      (is_baffle(slot_value(global_slot(sc->baffle_symbol)))))
    return(baffle_key(slot_value(global_slot(sc->baffle_symbol))) == key);

  return(false);
}


static int find_any_baffle(s7_scheme *sc)
{
  /* search backwards through sc->envir for any sc->baffle_symbol
   */
  if (sc->baffle_ctr > 0)
    {
      s7_pointer x, y;
      for (x = sc->envir; is_let(x); x = outlet(x))
	for (y = let_slots(x); is_slot(y); y = next_slot(y))
	  if (slot_symbol(y) == sc->baffle_symbol)
	    return(baffle_key(slot_value(y)));

      if ((is_slot(global_slot(sc->baffle_symbol))) &&
	  (is_baffle(slot_value(global_slot(sc->baffle_symbol)))))
	return(baffle_key(slot_value(global_slot(sc->baffle_symbol))));
    }
  return(-1);
}


s7_pointer s7_make_continuation(s7_scheme *sc)
{
  s7_pointer x, stack;
  int loc;

  loc = s7_stack_top(sc);
  stack = copy_stack(sc, sc->stack, loc);
  sc->temp8 = stack;

  new_cell(sc, x, T_CONTINUATION | T_PROCEDURE);
  continuation_data(x) = (continuation_t *)malloc(sizeof(continuation_t));
  continuation_set_stack(x, stack);
  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);                        /* no heap allocation here */
  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);

  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)
    {
      op = stack_op(sc->stack, i);
      switch (op)
	{
	case OP_DYNAMIC_WIND:
	  {
	    s7_pointer x;
	    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)
	    {
	      /* this can cause an infinite loop if the call/cc is trying to jump back into
	       *   a dynamic-wind init function -- it's even possible to trick with-baffle!
	       *   I can't find any fool-proof way to catch this problem.
	       */
	      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) &&
      (!(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 can this happen? (it doesn't in s7test) */
    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, quit = 0;

  if (!call_exit_active(sc->code))
    {
      static s7_pointer call_with_exit_error = NULL;
      if (!call_with_exit_error)
	call_with_exit_error = s7_make_permanent_string("call-with-exit escape procedure called outside its block");
      s7_error(sc, sc->invalid_escape_function_symbol, set_elist_1(sc, call_with_exit_error));
    }

  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:
	  {
	    s7_pointer lx;
	    lx = stack_code(sc->stack, i);
	    if (dynamic_wind_state(lx) == DWIND_BODY)
	      {
		dynamic_wind_state(lx) = DWIND_FINISH;
		if (dynamic_wind_out(lx) != sc->F)
		  {
		    push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
		    sc->args = sc->nil;
		    sc->code = dynamic_wind_out(lx);
		    eval(sc, OP_APPLY);
		  }
	      }
	  }
	  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_GET_OUTPUT_STRING_1:
	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;

	case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */
	  quit++;
	  break;

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

  if (quit > 0)
    {
      if (sc->longjmp_ok)
	{
	  pop_stack(sc);
	  longjmp(sc->goto_start, CALL_WITH_EXIT_JUMP);
	}
      for (i = 0; i < quit; i++)
	push_stack(sc, OP_EVAL_DONE, sc->nil, sc->nil);
    }
}


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!"
  #define Q_call_cc s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)
  /* I think the intent is that sc->values_symbol as the proc-sig return type indicates multiple values are possible (otherwise use #t). */

  s7_pointer p;
  p = car(args);                             /* this is the procedure passed to call/cc */
  if (!is_procedure(p))                      /* this includes continuations */
    {
      check_two_methods(sc, p, sc->call_cc_symbol, sc->call_with_current_continuation_symbol, args);
      return(simple_wrong_type_argument_with_type(sc, sc->call_cc_symbol, p, a_procedure_string));
    }
  if (!s7_is_aritable(sc, p, 1))
    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(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."
  #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)

  s7_pointer p, x;
  /* (call-with-exit (lambda (return) ...)) */
  p = car(args);
  if (!is_procedure(p))                           /* this includes continuations */
    method_or_bust_with_type(sc, p, sc->call_with_exit_symbol, args, a_procedure_string, 0);

  x = make_goto(sc);
  push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */
  push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p);

  /* 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);
#if (!WITH_PURE_S7)
  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);
#endif
  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);
#endif

#define HAVE_OVERFLOW_CHECKS ((defined(__clang__) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || \
                              (defined(__GNUC__) && __GNUC__ >= 5))

#if (defined(__clang__) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) 
  #define subtract_overflow(A, B, C)     __builtin_ssubll_overflow(A, B, C)
  #define add_overflow(A, B, C)          __builtin_saddll_overflow(A, B, C)
  #define multiply_overflow(A, B, C)     __builtin_smulll_overflow(A, B, C)
  #define int_subtract_overflow(A, B, C) __builtin_ssub_overflow(A, B, C)
  #define int_add_overflow(A, B, C)      __builtin_sadd_overflow(A, B, C)
  #define int_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C)
#else
#if (defined(__GNUC__) && __GNUC__ >= 5)
  #define subtract_overflow(A, B, C)     __builtin_sub_overflow(A, B, C)
  #define add_overflow(A, B, C)          __builtin_add_overflow(A, B, C)
  #define multiply_overflow(A, B, C)     __builtin_mul_overflow(A, B, C)
  #define int_subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C)
  #define int_add_overflow(A, B, C)      __builtin_add_overflow(A, B, C)
  #define int_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
#endif
#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! */

#if (!__NetBSD__)
  #define s7_fabsl(X) fabsl(X)
#else
  static double s7_fabsl(long double x) {if (x < 0.0) return(-x);  return(x);}
#endif


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


#if defined(__sun) && defined(__SVR4)
  static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* there's no isinf in Solaris */
#else
#if (!MS_WINDOWS)

  #if __cplusplus
    #define is_inf(x) std::isinf(x)
  #else
    #define is_inf(x) isinf(x)
  #endif

#else
  static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));}  /* Another possibility: (x * 0) != 0 */

  /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */
  static double asinh(double x) {return(log(x + sqrt(1.0 + x * x)));}
  static double acosh(double x) {return(log(x + sqrt(x * x - 1.0)));}
  /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */
  static double atanh(double x) {return(log((1.0 + x) / (1.0 - x)) / 2.0);}
  static double cbrt(double x) {if (x >= 0.0) return(pow(x, 1.0 / 3.0)); return(-pow(-x, 1.0 / 3.0));}
#endif /* windows */
#endif /* sun */


/* for g_log, we also need round. this version is from stackoverflow, see also round_per_R5RS below */
double s7_round(double number) {return((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));}

#if HAVE_COMPLEX_NUMBERS
#if __cplusplus
  #define _Complex_I (complex<s7_double>(0.0, 1.0))
  #define creal(x) Real(x)
  #define cimag(x) Imag(x)
  #define carg(x) arg(x)
  #define cabs(x) abs(x)
  #define csqrt(x) sqrt(x)
  #define cpow(x, y) pow(x, y)
  #define clog(x) log(x)
  #define cexp(x) exp(x)
  #define csin(x) sin(x)
  #define ccos(x) cos(x)
  #define csinh(x) sinh(x)
  #define ccosh(x) cosh(x)
#else
  typedef double complex s7_complex;
#endif


#if (!HAVE_COMPLEX_TRIG)
#if (__cplusplus)

  static s7_complex ctan(s7_complex z)   {return(csin(z) / ccos(z));}
  static s7_complex ctanh(s7_complex z)  {return(csinh(z) / ccosh(z));}
  static s7_complex casin(s7_complex z)  {return(-_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)));}
  static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
#else

/* still not in FreeBSD! */
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 */
}

#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */
  static s7_complex cexp(s7_complex z) {return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * _Complex_I);}
#endif

#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10)
  static s7_complex csin(s7_complex z)   {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * _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);}
  static s7_complex ctan(s7_complex z)   {return(csin(z) / ccos(z));}
  static s7_complex ctanh(s7_complex z)  {return(csinh(z) / ccosh(z));}
  static s7_complex casin(s7_complex z)  {return(-_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 catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
  static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
  /* perhaps less prone to numerical troubles (untested): 2.0 * clog(csqrt(0.5 * (z + 1.0)) + csqrt(0.5 * (z - 1.0))) */
#endif /* not FreeBSD 10 */
#endif /* not c++ */
#endif /* not HAVE_COMPLEX_TRIG */

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

#ifdef __OpenBSD__
  /* openbsd's builtin versions of these functions are not usable */
  static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
  static s7_complex cacosh_1(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
#endif
#ifdef __NetBSD__
  static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
  static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
#endif


bool s7_is_number(s7_pointer p)
{
#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((is_t_integer(p)) ||
	 (is_t_big_integer(p)));
#else
  return(is_integer(p));
#endif
}

bool s7_is_real(s7_pointer p)
{
#if WITH_GMP
  return((is_real(p)) ||
	 (is_t_big_integer(p)) ||
	 (is_t_big_ratio(p)) ||
	 (is_t_big_real(p)));
#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)) ||
	 (is_t_big_integer(p)) ||
	 (is_t_big_ratio(p)));
#else
  return(is_rational(p));
#endif
}


bool s7_is_ratio(s7_pointer p)
{
#if WITH_GMP
  return((is_t_ratio(p)) ||
	 (is_t_big_ratio(p)));
#else
  return(is_t_ratio(p));
#endif
}


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


static s7_int c_gcd(s7_int u, s7_int v)
{
  s7_int a, b;

  if ((u == s7_int_min) || (v == s7_int_min))
    {
      /* can't take abs of these (below) so do it by hand */
      s7_int divisor = 1;
      if (u == v) return(u);
      while (((u & 1) == 0) && ((v & 1) == 0))
	{
	  u /= 2;
	  v /= 2;
	  divisor *= 2;
	}
      return(divisor);
    }

  a = s7_int_abs(u);
  b = s7_int_abs(v);
  while (b != 0)
    {
      s7_int temp;
      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;
  s7_int i, i0, i1, p0, q0, p1, q1;
  double e0, e1, e0p, e1p;
  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)
    {
      s7_int old_p1, old_q1;
      double old_e0, old_e1, old_e0p, val, r, r1;
      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;

      /* do handles all step vars in parallel */
      old_p1 = p1;
      p1 = p0;
      old_q1 = q1;
      q1 = q0;
      old_e0 = e0;
      e0 = e1p;
      old_e0p = e0p;
      e0p = e1;
      old_e1 = e1;

      p0 = old_p1 + r * p0;
      q0 = old_q1 + r * q0;
      e1 = old_e0p - r * e1p;
      /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */
      e1p = old_e0 - r * old_e1;
    }
  return(false);
}


s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error)
{
  s7_int numer = 0, denom = 1;
  if (c_rationalize(x, error, &numer, &denom))
    return(s7_make_ratio(sc, numer, denom));
  return(make_real(sc, x));
}


static s7_int number_to_numerator(s7_pointer n)
{
  if (is_t_ratio(n))
    return(numerator(n));
  return(integer(n));
}


static s7_int number_to_denominator(s7_pointer n)
{
  if (is_t_ratio(n))
    return(denominator(n));
  return(1);
}


s7_pointer s7_make_integer(s7_scheme *sc, s7_int n)
{
  s7_pointer x;
  if (is_small(n))              /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */
    return(small_int(n));

  new_cell(sc, 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, T_INTEGER | T_MUTABLE);
  integer(x) = n;
  return(x);
}


static s7_pointer make_permanent_integer_unchecked(s7_int i)
{
  s7_pointer p;
  p = (s7_pointer)calloc(1, sizeof(s7_cell));
  typeflag(p) = T_IMMUTABLE | T_INTEGER;
  unheap(p);
  integer(p) = i;
  return(p);
}

static s7_pointer make_permanent_integer(s7_int i)
{
  if (is_small(i)) return(small_int(i));

  if (i == MAX_ARITY) return(max_arity);
  if (i == CLOSURE_ARITY_NOT_SET) return(arity_not_set);
  if (i == -1) return(minus_one);
  if (i == -2) return(minus_two);
  /* a few -3 */

  return(make_permanent_integer_unchecked(i));
}


s7_pointer s7_make_real(s7_scheme *sc, s7_double n)
{
  s7_pointer x;
  /* in snd-test this is called about 40000000 times, primarily test 8/18/22 */

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

  new_cell(sc, x, T_REAL);
  set_real(x, n);

  return(x);
}


s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n)
{
  s7_pointer x;
  new_cell(sc, x, T_REAL | T_MUTABLE);
  set_real(x, n);
  return(x);
}


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);
  unheap(x);
  set_real(x, n);

  str = number_to_string_base_10(x, 0, float_format_precision, 'g', &nlen, USE_WRITE);
  set_print_name(x, str, nlen);
  return(x);
}


s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b)
{
  s7_pointer x;
  if (b == 0.0)
    {
      new_cell(sc, x, T_REAL);
      set_real(x, a);
    }
  else
    {
      new_cell(sc, x, T_COMPLEX);
      set_real_part(x, a);
      set_imag_part(x, b);
    }
  return(x);
}


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_string_wrapper(sc, "make-ratio"), set_elist_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_int_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? we can't get this in the ratio reader, I think, because the denominator is negative */
	  b = b + 1;
	  /* so (/ -1 most-negative-fixnum) -> 1/9223372036854775807 -- not ideal, but ... */
	}
      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, T_RATIO);
  numerator(x) = a;
  denominator(x) = b;

  return(x);
}
/* in fc19 as a guest running in virtualbox on OSX, the line  a /= divisor can abort with an arithmetic exception (SIGFPE)
 *    if leastfix/mostfix -- apparently this is a bug in virtualbox.
 */


#define WITH_OVERFLOW_ERROR true
#define WITHOUT_OVERFLOW_ERROR false

#if (!WITH_PURE_S7)
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: return(x); /* apparently (exact->inexact 1+i) is not an error */
    default: 
      method_or_bust_with_type(sc, x, sc->exact_to_inexact_symbol, list_1(sc, x), a_number_string, 0);
    }
}

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_symbol, x, a_normal_real_string));
	    return(sc->nil);
	  }

	if ((val > s7_int_max) ||
	    (val < s7_int_min))
	  {
	    if (with_error)
	      return(simple_out_of_range(sc, sc->inexact_to_exact_symbol, x, its_too_large_string));
	    return(sc->nil);
	  }

	if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom))
	  return(s7_make_ratio(sc, numer, denom));
      }

    default:
      if (with_error)
	method_or_bust(sc, x, sc->inexact_to_exact_symbol, list_1(sc, x), T_REAL, 0);
      return(sc->nil);
    }
  return(x);
}
#endif

s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller)
{
  if (is_t_real(x))
    return(real(x));
  /* 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));
#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));
#endif
    }
  s7_wrong_type_arg_error(sc, caller, 0, x, "a real number");
  return(0.0);
}


s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x)
{
  return(s7_number_to_real_with_caller(sc, x, "s7_number_to_real"));
}


s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) /* currently unused */
{
  if (type(x) != T_INTEGER)
    s7_wrong_type_arg_error(sc, caller, 0, x, "an integer");
  return(integer(x));
}

s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x)                                 /* currently unused */
{
  return(s7_number_to_integer_with_caller(sc, x, "s7_number_to_integer"));
}


s7_int s7_numerator(s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:     return(integer(x));
    case T_RATIO:       return(numerator(x));
#if WITH_GMP
    case T_BIG_INTEGER: return(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 (is_t_big_integer(p))
    return(big_integer_to_s7_int(big_integer(p)));
#endif
  return(integer(p));
}


s7_double s7_real(s7_pointer p)
{
#if WITH_GMP
  if (is_t_big_real(p))
    return((s7_double)mpfr_get_d(big_real(p), GMP_RNDN));
#endif
  return(real(p));
}


#if (!WITH_GMP)
static s7_complex s7_to_c_complex(s7_pointer p)
{
#if HAVE_COMPLEX_NUMBERS
  return(CMPLX(s7_real_part(p), s7_imag_part(p)));
#else
  return(0.0);
#endif
}


static s7_pointer s7_from_c_complex(s7_scheme *sc, s7_complex z)
{
  return(s7_make_complex(sc, creal(z), cimag(z)));
}
#endif


#if ((!WITH_PURE_S7) || (!HAVE_OVERFLOW_CHECKS))
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_int_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]);
  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]);
}
#endif

static int s7_int32_max = 0, s7_int32_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_symbol, 1, p, a_number_string));
    }
}


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 HAVE_OVERFLOW_CHECKS
  {
    s7_int n1d2, n2d1, d1d2, dn;
    if ((multiply_overflow(d1, d2, &d1d2)) ||
	(multiply_overflow(n1, d2, &n1d2)) ||
	(multiply_overflow(n2, d1, &n2d1)) ||
	(subtract_overflow(n1d2, n2d1, &dn)))
      return(make_real(sc, ((long double)n1 / (long double)d1) - ((long double)n2 / (long double)d2)));
    return(s7_make_ratio(sc, dn, d1d2));
  }
#else
  if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
      (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
      (n1 < s7_int32_min) || (n2 < s7_int32_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
#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)
{
    return(((is_integer(x)) && (integer(x) == 1)) ||
	   ((is_t_real(x)) && (real(x) == 1.0)));
}


/* 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 int s7_int_to_string(char *p, s7_int n, int radix, int width)
{
  static const char dignum[] = "0123456789abcdef";
  int i, len, start, end;
  bool sign;
  s7_int pown;

  if ((radix < 2) || (radix > 16))
    return(0);

  if (n == s7_int_min) /* can't negate this, so do it by hand */
    {
      static const char *mnfs[17] = {"","",
	"-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222",
	"-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212",
	"-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828",	"-9223372036854775808",
	"-1728002635214590698",	"-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808", "-8000000000000000"};

      len = safe_strlen(mnfs[radix]);
      if (width > len)
	{
	  start = width - len - 1;
	  memset((void *)p, (int)' ', start);
	}
      else start = 0;
      for (i = 0; i < len; i++)
	p[start + i] = mnfs[radix][i];
      p[len + start] = '\0';
      return(len + start);
    }

  sign = (n < 0);
  if (sign) n = -n;

  /* the previous version that counted up to n, rather than dividing down below n, as here,
   *   could be confused by large ints on 64 bit machines
   */
  pown = n;
  for (i = 1; i < 100; i++)
    {
      if (pown < radix)
	break;
      pown /= (s7_int)radix;
    }
  len = i - 1;
  if (sign) len++;
  end = 0;
  if (width > len)                  /* (format #f "~10B" 123) */
    {
      start = width - len - 1;
      end += start;
      memset((void *)p, (int)' ', start);
    }
  else
    {
      start = 0;
      end = 0;
    }

  if (sign)
    {
      p[start] = '-';
      end++;
    }

  for (i = start + len; i >= end; i--)
    {
      p[i] = dignum[n % radix];
      n /= radix;
    }
  p[len + start + 1] = '\0';
  return(len + start + 1);
}


static char *integer_to_string_base_10_no_width(s7_pointer obj, int *nlen) /* do not free the returned string */
{
  long long int num;
  char *p, *op;
  bool sign;
  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));
   *  but that is very slow -- the following code is 6 times faster
   */
  num = (long long int)integer(obj);
  if (num == s7_int_min)
    {
      (*nlen) = 20;
      return((char *)"-9223372036854775808");
    }
  p = (char *)(int_to_str + INT_TO_STR_SIZE - 1);
  op = p;
  *p-- = '\0';

  sign = (num < 0);
  if (sign) num = -num;  /* we need a positive index below */
  do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
  if (sign)
    {
      *p = '-';
      (*nlen) = op - p;
      return(p);
    }

  (*nlen) = op - p - 1;
  return(++p);
}


#define BASE_10 10
static int num_to_str_size = -1;
static char *num_to_str = NULL;
static const char *float_format_g = NULL;

static char *floatify(char *str, int *nlen)
{
  if ((strchr(str, 'e') == NULL) &&
      (strchr(str, '.') == NULL))
    {
      /* this assumes there is room in str for 2 more chars */
      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 */
{
  /* the rest of s7 assumes nlen is set to the correct length 
   *   a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small.
   *   but then even worse: (format #f "~F" 1e308+1e308i)!
   */
  int len;
  len = 1024;
  if (width > len) len = 2 * width;
  if (len > num_to_str_size)
    {
      if (!num_to_str)
	num_to_str = (char *)malloc(len * sizeof(char));
      else num_to_str = (char *)realloc(num_to_str, len * sizeof(char));
      num_to_str_size = len;
    }

  /* bignums can't happen here */
  switch (type(obj))
    {
    case T_INTEGER:
      if (width == 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 - 4, frmt, width, precision, s7_real(obj)); /* -4 for floatify */
	(*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, float_format_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, float_format_g, precision, imag_part(obj));
		    ip = ibuf;
		  }
	      }
	    len = snprintf(num_to_str, num_to_str_size, "(complex %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)
{
  /* the rest of s7 assumes nlen is set to the correct length */
  char *p;
  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)
    {
      p = number_to_string_base_10(obj, width, precision, float_choice, nlen, USE_WRITE);
      return(copy_string_with_length(p, *nlen));
    }

  switch (type(obj))
    {
    case T_INTEGER:
      p = (char *)malloc((128 + width) * sizeof(char));
      *nlen = s7_int_to_string(p, s7_integer(obj), radix, width);
      return(p);

    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_length("nan.0", *nlen = 5));
	if (is_inf(x))
	  {
	    if (x < 0.0)
	      return(copy_string_with_length("-inf.0", *nlen = 6));
	    return(copy_string_with_length("inf.0", *nlen = 5));
	  }

	if (x < 0.0)
	  {
	    sign = true;
	    x = -x;
	  }

	if (x > 1.0e18) /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */
	  {
	    int ep;
	    char *p1;
	    s7_pointer r;

	    len = 0;
	    ep = (int)floor(log(x) / log((double)radix));
	    r = make_real(sc, x / pow((double)radix, (double)ep)); /* divide it down to one digit, then the fractional part */
	    p1 = number_to_string_with_radix(sc, r, radix, width, precision, float_choice, &len);
	    p = (char *)malloc((len + 8) * sizeof(char));
	    (*nlen) = snprintf(p, len + 8, "%s%se%d", (sign) ? "-" : "", p1, ep);
	    free(p1);
	    return(p);
	  }

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

	/* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */

	for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix)
	  {
	    s7_int ipart;
	    ipart = (s7_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:
      {
	char *n, *d;
	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 void prepare_temporary_string(s7_scheme *sc, int len, int which)
{
  s7_pointer p;
  p = sc->tmp_strs[which];
  if (len > string_temp_true_length(p))
    {
      string_value(p) = (char *)realloc(string_value(p), len * sizeof(char));
      string_temp_true_length(p) = len;
    }
}

static s7_pointer g_number_to_string_1(s7_scheme *sc, s7_pointer args, bool temporary)
{
  #define H_number_to_string "(number->string num (radix 10)) converts the number num into a string."
  #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol)

  s7_int radix = 10;
  int size, nlen = 0;
  char *res;
  s7_pointer x;

  x = car(args);
  if (!s7_is_number(x))
    method_or_bust_with_type(sc, x, sc->number_to_string_symbol, args, a_number_string, 1);

  if (is_pair(cdr(args)))
    {
      s7_pointer y;
      y = cadr(args);
      if (s7_is_integer(y))
	radix = s7_integer(y);
      else method_or_bust(sc, y, sc->number_to_string_symbol, args, T_INTEGER, 2);
      if ((radix < 2) || (radix > 16))
	return(out_of_range(sc, sc->number_to_string_symbol, small_int(2), y, a_valid_radix_string));
    }

#if WITH_GMP
  if (s7_is_bignum(x))
    {
      res = big_number_to_string_with_radix(x, radix, 0, &nlen, USE_WRITE);
      return(make_string_uncopied_with_length(sc, res, nlen));
    }
#endif

  size = float_format_precision;
  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 (radix == 10)
	{
	  if (is_real(x))
	    {
	      s7_double val;
	      val = fabs(s7_real(x));
	      if ((val > (s7_int32_max / 4)) || (val < 1.0e-6))
		size += 4;
	    }
	  else
	    {
	      s7_double rl;
	      rl = fabs(s7_real_part(x));
	      if ((rl > (s7_int32_max / 4)) || (rl < 1.0e-6))
		{
		  s7_double im;
		  im = fabs(s7_imag_part(x));
		  if ((im > (s7_int32_max / 4)) || (im < 1.0e-6))
		    size += 4;
		}
	    }
	}
    }
  if (radix != 10)
    {
      res = number_to_string_with_radix(sc, x, radix, 0, size, 'g', &nlen);
      return(make_string_uncopied_with_length(sc, res, nlen));
    }
  res = number_to_string_base_10(x, 0, size, 'g', &nlen, USE_WRITE);
  if (temporary)
    {
      s7_pointer p;
      prepare_temporary_string(sc, nlen + 1, 1);
      p = sc->tmp_strs[1];
      string_length(p) = nlen;
      memcpy((void *)(string_value(p)), (void *)res, nlen);
      string_value(p)[nlen] = 0;
      return(p);
    }
  return(s7_make_string_with_length(sc, res, nlen));
}

static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args)
{
  return(g_number_to_string_1(sc, args, false));
}

static s7_pointer number_to_string_temp;
static s7_pointer g_number_to_string_temp(s7_scheme *sc, s7_pointer args)
{
  return(g_number_to_string_1(sc, args, true));
}

static s7_pointer number_to_string_pf_temp(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(g_number_to_string_1(sc, set_plist_1(sc, x), true));
}

static s7_pointer number_to_string_pf_s_temp(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x;
  (*p)++; x = slot_value(**p); (*p)++;
  return(g_number_to_string_1(sc, set_plist_1(sc, x), true));
}

static s7_pointer c_number_to_string(s7_scheme *sc, s7_pointer n) {return(g_number_to_string_1(sc, set_plist_1(sc, n), false));}
PF_TO_PF(number_to_string, c_number_to_string)


#define CTABLE_SIZE 256
static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space, *number_table, *symbol_slashify_table;
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));
  symbol_slashify_table = (bool *)calloc(CTABLE_SIZE, sizeof(bool));
  char_ok_in_a_name = (bool *)calloc(CTABLE_SIZE, sizeof(bool));
  white_space = (bool *)calloc(CTABLE_SIZE + 1, sizeof(bool));
  white_space++;      /* leave white_space[-1] false for white_space[EOF] */
  number_table = (bool *)calloc(CTABLE_SIZE, sizeof(bool));

  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[(unsigned char)'('] = false;  /* idiotic cast is for C++'s benefit */
  char_ok_in_a_name[(unsigned char)')'] = false;
  char_ok_in_a_name[(unsigned char)';'] = false;
  char_ok_in_a_name[(unsigned char)'\t'] = false;
  char_ok_in_a_name[(unsigned char)'\n'] = false;
  char_ok_in_a_name[(unsigned char)'\r'] = false;
  char_ok_in_a_name[(unsigned char)' '] = false;
  char_ok_in_a_name[(unsigned char)'"'] = false;
  /* what about stuff like vertical tab?  or comma? */

  for (i = 0; i < CTABLE_SIZE; i++)
    white_space[i] = false;
  white_space[(unsigned char)'\t'] = true;
  white_space[(unsigned char)'\n'] = true;
  white_space[(unsigned char)'\r'] = true;
  white_space[(unsigned char)'\f'] = true;
  white_space[(unsigned char)'\v'] = true;
  white_space[(unsigned char)' '] = true;
  white_space[(unsigned char)'\205'] = true; /* 133 */
  white_space[(unsigned char)'\240'] = true; /* 160 */

  /* surely only 'e' is needed... */
  exponent_table[(unsigned char)'e'] = true; exponent_table[(unsigned char)'E'] = true;
  exponent_table[(unsigned char)'@'] = true;
#if WITH_EXTRA_EXPONENT_MARKERS
  exponent_table[(unsigned char)'s'] = true; exponent_table[(unsigned char)'S'] = true;
  exponent_table[(unsigned char)'f'] = true; exponent_table[(unsigned char)'F'] = true;
  exponent_table[(unsigned char)'d'] = true; exponent_table[(unsigned char)'D'] = true;
  exponent_table[(unsigned char)'l'] = true; exponent_table[(unsigned char)'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[(unsigned char)'\\'] = true;
  slashify_table[(unsigned char)'"'] = true;
  slashify_table[(unsigned char)'\n'] = false;

  for (i = 0; i < CTABLE_SIZE; i++)
    symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i]));

  digits = (int *)calloc(CTABLE_SIZE, sizeof(int));
  for (i = 0; i < CTABLE_SIZE; i++)
    digits[i] = 256;

  digits[(unsigned char)'0'] = 0; digits[(unsigned char)'1'] = 1; digits[(unsigned char)'2'] = 2; digits[(unsigned char)'3'] = 3; digits[(unsigned char)'4'] = 4;
  digits[(unsigned char)'5'] = 5; digits[(unsigned char)'6'] = 6; digits[(unsigned char)'7'] = 7; digits[(unsigned char)'8'] = 8; digits[(unsigned char)'9'] = 9;
  digits[(unsigned char)'a'] = 10; digits[(unsigned char)'A'] = 10;
  digits[(unsigned char)'b'] = 11; digits[(unsigned char)'B'] = 11;
  digits[(unsigned char)'c'] = 12; digits[(unsigned char)'C'] = 12;
  digits[(unsigned char)'d'] = 13; digits[(unsigned char)'D'] = 13;
  digits[(unsigned char)'e'] = 14; digits[(unsigned char)'E'] = 14;
  digits[(unsigned char)'f'] = 15; digits[(unsigned char)'F'] = 15;

  for (i = 0; i < CTABLE_SIZE; i++)
    number_table[i] = false;
  number_table[(unsigned char)'0'] = true;
  number_table[(unsigned char)'1'] = true;
  number_table[(unsigned char)'2'] = true;
  number_table[(unsigned char)'3'] = true;
  number_table[(unsigned char)'4'] = true;
  number_table[(unsigned char)'5'] = true;
  number_table[(unsigned char)'6'] = true;
  number_table[(unsigned char)'7'] = true;
  number_table[(unsigned char)'8'] = true;
  number_table[(unsigned char)'9'] = true;
  number_table[(unsigned char)'.'] = true;
  number_table[(unsigned char)'+'] = true;
  number_table[(unsigned char)'-'] = true;
  number_table[(unsigned char)'#'] = true;
}


#define is_white_space(C) white_space[C]
  /* this is much faster than C's isspace, and does not depend on the current locale.
   * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space
   */


static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
{
  s7_pointer reader, value, args;
  bool need_loader_port;
  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.
   *    Since #f means "nothing found", it is tricky to handle #F: 
   *       (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t))))
   * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback.
   */

  need_loader_port = is_loader_port(sc->input_port);
  if (need_loader_port)
    clear_loader_port(sc->input_port);

  /* normally read* can't read from sc->input_port if it is in use by the loader,
   *   but here we are deliberately making that possible.
   */
  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); /* this is much less error-safe than s7_call */
	  if (value != sc->F)
	    break;
	}
    }
  if (need_loader_port)
    set_loader_port(sc->input_port);
  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_symbol);
	}
      if (is_null(x))
	return(cadr(args));
    }
  return(sc->error_symbol);
}


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

static s7_pointer unknown_sharp_constant(s7_scheme *sc, char *name)
{
  /* check *read-error-hook* */
  if (hook_has_functions(sc->read_error_hook))
    {
      s7_pointer result;
      result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->T, make_string_wrapper(sc, name)));
      if (result != sc->unspecified)
	return(result);
    }
  return(sc->nil);
}

#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(unknown_sharp_constant(sc, name));

  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(unknown_sharp_constant(sc, name));


      /* -------- #o #d #x #b -------- */
    case 'o':   /* #o (octal) */
    case 'd':   /* #d (decimal) */
    case 'x':   /* #x (hex) */
    case 'b':   /* #b (binary) */
      {
	int num_at = 1;
#if (!WITH_PURE_S7)
	bool to_inexact = false, to_exact = false;

	if (name[1] == '#')
	  {
	    if (!at_top)
	      return(unknown_sharp_constant(sc, name));
	    if ((len > 2) && ((name[2] == 'e') || (name[2] == 'i'))) /* r6rs includes caps here */
	      {
		if ((len > 3) && (name[3] == '#'))
		  return(unknown_sharp_constant(sc, name));
		to_inexact = (name[2] == 'i');
		to_exact = (name[2] == 'e');
		num_at = 3;
	      }
	    else return(unknown_sharp_constant(sc, name));
	  }
#endif
	/* 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(unknown_sharp_constant(sc, name));

#if (!WITH_PURE_S7)
	if ((!to_exact) && (!to_inexact))
	  return(x);

	if ((s7_imag_part(x) != 0.0) && (to_exact))  /* #x#e1+i */
	  return(unknown_sharp_constant(sc, name));

#if WITH_GMP
	if (s7_is_bignum(x))
	  {
	    if (to_exact)
	      return(big_inexact_to_exact(sc, set_plist_1(sc, x)));
	    return(big_exact_to_inexact(sc, set_plist_1(sc, x)));
	  }
#endif
	if (to_exact)
	  return(inexact_to_exact(sc, x, with_error));
	return(exact_to_inexact(sc, x));
#else
	return(x);
#endif
      }
      break;

#if (!WITH_PURE_S7)
      /* -------- #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(unknown_sharp_constant(sc, name));

	  x = make_sharp_constant(sc, (char *)(name + 2), NESTED_SHARP, radix, with_error);
	  if (s7_is_number(x))
	    {
	      if (is_abnormal(x))
		return(unknown_sharp_constant(sc, name));
#if WITH_GMP
	      if (s7_is_bignum(x))                        /* (string->number "#b#e-11e+111") */
		return(big_exact_to_inexact(sc, set_plist_1(sc, x)));
#endif
	      return(exact_to_inexact(sc, x));
	    }
	  return(unknown_sharp_constant(sc, name));
	}
      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(unknown_sharp_constant(sc, name));
#if WITH_GMP
      if (s7_is_bignum(x))
	return(big_exact_to_inexact(sc, set_plist_1(sc, x)));
#endif
      return(exact_to_inexact(sc, x));


      /* -------- #e -------- */
    case 'e':   /* #e<num> = ->exact */
      if (name[1] == '#')
	{
	  if ((name[2] == 'e') ||                        /* #e#e1 */
	      (name[2] == 'i'))
	    return(unknown_sharp_constant(sc, name));

	  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(unknown_sharp_constant(sc, name));
	      if (!s7_is_real(x))                        /* (string->number "#e#b1+i") */
		return(unknown_sharp_constant(sc, name));
#if WITH_GMP
	      return(big_inexact_to_exact(sc, set_plist_1(sc, x)));
#endif
	      return(inexact_to_exact(sc, x, with_error));
	    }
	  return(unknown_sharp_constant(sc, name));
	}

      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, set_plist_1(sc, x)));
#endif
      if (is_abnormal(x))                                /* (string->number "#e0/0") */
	return(unknown_sharp_constant(sc, name));
      if (!s7_is_real(x))                                /* (string->number "#e1+i") */
	return(unknown_sharp_constant(sc, name));

#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, set_plist_1(sc, x)));
#endif
      return(inexact_to_exact(sc, x, with_error));
#endif /* !WITH_PURE_S7 */


      /* -------- #_... -------- */
    case '_':
      {
	s7_pointer sym;
	sym = make_symbol(sc, (char *)(name + 1));
	if (is_slot(initial_slot(sym)))
	  return(slot_value(initial_slot(sym)));
	return(s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "#~A is undefined"), make_string_wrapper(sc, name))));
	/* return(sc->undefined); */
      }


      /* -------- #\... -------- */
    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!! */
      switch (name[1])
	{
	case 'n':
	  if ((strings_are_equal(name + 1, "null")) ||
	      (strings_are_equal(name + 1, "nul")))
	    return(chars[0]);

	  if (strings_are_equal(name + 1, "newline"))
	    return(chars[(unsigned char)'\n']);
	  break;

	case 's':
	  if (strings_are_equal(name + 1, "space"))
	    return(chars[(unsigned char)' ']);
	  break;

	case 'r':
	  if (strings_are_equal(name + 1, "return"))
	    return(chars[(unsigned char)'\r']);
	  break;

	case 'l':
	  if (strings_are_equal(name + 1, "linefeed"))
	    return(chars[(unsigned char)'\n']);
	  break;

	case 't':
	  if (strings_are_equal(name + 1, "tab"))
	    return(chars[(unsigned char)'\t']);
	  break;

	case 'a':
	  /* the next 4 are for r7rs */
	  if (strings_are_equal(name + 1, "alarm"))
	    return(chars[7]);
	  break;

	case 'b':
	  if (strings_are_equal(name + 1, "backspace"))
	    return(chars[8]);
	  break;

	case 'e':
	  if (strings_are_equal(name + 1, "escape"))
	    return(chars[0x1b]);
	  break;

	case 'd':
	  if (strings_are_equal(name + 1, "delete"))
	    return(chars[0x7f]);
	  break;

	case 'x':
	  /* #\x is just x, but apparently #\x<num> is int->char? #\x65 -> #\e -- 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]);
	  }
	  break;
	}
    }
  return(unknown_sharp_constant(sc, name));
}


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 > 9) break;
#if HAVE_OVERFLOW_CHECKS
	  if (multiply_overflow(lval, (s7_int)10, &lval)) break;
	  if (add_overflow(lval, (s7_int)dig, &lval)) break;
#else
	  lval = dig + (lval * 10);
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig > 9) break;
	  lval = dig + (lval * 10);
#endif
	}
    }
  else
    {
      while (true)
	{
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig >= radix) break;
#if HAVE_OVERFLOW_CHECKS
	  if (multiply_overflow(lval, (s7_int)radix, &lval)) break;
	  if (add_overflow(lval, (s7_int)dig, &lval)) break;
#else
	  lval = dig + (lval * radix);
	  dig = digits[(unsigned char)(*tmp++)];
	  if (dig >= radix) break;
	  lval = dig + (lval * radix);
#endif
	}
    }

#if WITH_GMP
  (*overflow) = ((lval > s7_int32_max) ||
		 ((tmp - tmp1) > s7_int_digits_by_radix[radix]));
  /* this tells the string->number readers to create a bignum.  We need to be very
   *    conservative here to catch contexts such as (/ 1/524288 19073486328125)
   */
#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 */
	{
#if HAVE_OVERFLOW_CHECKS
	  if ((int_multiply_overflow(exponent, 10, &exponent)) ||
	      (int_add_overflow(exponent, dig, &exponent)))
	    {
	      exponent = 1000000; /* see below */
	      break;
	    }
#else
	  exponent = dig + (exponent * 10);
#endif
	}
#if (!defined(__GNUC__)) || (__GNUC__ < 5)
      if (exponent < 0)         /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */
	exponent = 1000000;     /*   see below for examples -- this number needs to be very big but not too big for add */
#endif
      if (exp_negative)
	exponent = -exponent;

      /*           2e12341234123123123123213123123123 -> 0.0
       * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0
       * first zero: 2e123412341231231231231
       * then:     2e12341234123123123123123123 -> inf
       * then:     2e123412341231231231231231231231231231 -> 0.0
       *           2e-123412341231231231231 -> inf
       * but:      0e123412341231231231231231231231231231
       */
    }

#if WITH_GMP
  /* 9007199254740995.0 */
  if (int_len + frac_len >= max_len)
    {
      (*overflow) = true;
      return(0.0);
    }
#endif

  str = ipart;
  if ((int_len + exponent) > max_len)
    {
      /*  12341234.56789e12                   12341234567889999872.0              1.234123456789e+19
       * -1234567890123456789.0              -1234567890123456768.0              -1.2345678901235e+18
       *  12345678901234567890.0              12345678901234567168.0              1.2345678901235e+19
       *  123.456e30                          123456000000000012741097792995328.0 1.23456e+32
       *  12345678901234567890.0e12           12345678901234569054409354903552.0  1.2345678901235e+31
       *  1.234567890123456789012e30          1234567890123456849145940148224.0   1.2345678901235e+30
       *  1e20                                100000000000000000000.0             1e+20
       *  1234567890123456789.0               1234567890123456768.0               1.2345678901235e+18
       *  123.456e16                          1234560000000000000.0               1.23456e+18
       *  98765432101234567890987654321.0e-5  987654321012345728401408.0          9.8765432101235e+23
       *  98765432101234567890987654321.0e-10 9876543210123456512.0               9.8765432101235e+18
       *  0.00000000000000001234e20           1234.0
       *  0.000000000000000000000000001234e30 1234.0
       *  0.0000000000000000000000000000000000001234e40 1234.0
       *  0.000000000012345678909876543210e15 12345.678909877
       *  0e1000                              0.0
       */

      for (i = 0; i < max_len; i++)
	{
	  dig = digits[(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 propagates
			  */
	{
	  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)
    {
      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)
	{
	  char *iend;
	  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 frpart = 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++)
	frpart = digits[(int)(*str++)] + (frpart * radix);

      if (len <= 0)
	dval = int_part + frpart * ipow(radix, len - flen);
      else dval = int_part + frpart * 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);
}


static s7_pointer make_atom(s7_scheme *sc, char *q, int radix, bool want_symbol, bool with_error)
{
  /* make symbol or number from string */
  #define IS_DIGIT(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) || (!IS_DIGIT(c, radix)))
	return((want_symbol) ? make_symbol(sc, q) : sc->F);
      break;

    case '.':
      has_dec_point1 = true;
      c = *p++;

      if ((!c) || (!IS_DIGIT(c, radix)))
	return((want_symbol) ? make_symbol(sc, q) : sc->F);
      break;

    case '0':        /* these two are always digits */
    case '1':
      break;

    default:
      if (!IS_DIGIT(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 (!IS_DIGIT(c, current_radix))         /* moving this inside the switch statement was much slower */
	  {
	    current_radix = radix;

	    switch (c)
	      {
		/* -------- decimal point -------- */
	      case '.':
		if ((!IS_DIGIT(p[1], current_radix)) &&
		    (!IS_DIGIT(p[-1], current_radix)))
		  return((want_symbol) ? make_symbol(sc, q) : sc->F);

		if (has_plus_or_minus == 0)
		  {
		    if ((has_dec_point1) || (slash1))
		      return((want_symbol) ? make_symbol(sc, q) : sc->F);
		    has_dec_point1 = true;
		  }
		else
		  {
		    if ((has_dec_point2) || (slash2))
		      return((want_symbol) ? make_symbol(sc, q) : sc->F);
		    has_dec_point2 = true;
		  }
		continue;


		/* -------- exponent marker -------- */
#if WITH_EXTRA_EXPONENT_MARKERS
		/* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */
	      case 's': case 'S':
	      case 'd': case 'D':
	      case 'f': case 'F':
	      case 'l': case 'L':
#endif
	      case 'e': case 'E':
		if (current_radix > 10)
		  return((want_symbol) ? make_symbol(sc, q) : sc->F);
		/* see note above */
		/* fall through -- if '@' used, radices>10 are ok */

	      case '@':
		current_radix = 10;

		if (((ex1) ||
		     (slash1)) &&
		    (has_plus_or_minus == 0)) /* ee */
		  return((want_symbol) ? make_symbol(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 ((!IS_DIGIT(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 (IS_DIGIT(*p, current_radix))
		  continue;
		break;


		/* -------- internal + or - -------- */
	      case '+':
	      case '-':
		if (has_plus_or_minus != 0) /* already have the separator */
		  return((want_symbol) ? make_symbol(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 ((!IS_DIGIT(p[1], current_radix)) ||
		    (!IS_DIGIT(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 (den == 0)
		  rl = NAN;
		else
		  {
		    if (num == 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 (den == 0)
		  im = NAN;
		else
		  {
		    if (num == 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);
	      (*ex1) = '@';
	    }
	  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((q[0] == '-') ? real_minus_infinity : real_infinity);
      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' it is ignored: (string->number \"#x11\" 2) -> 17 not 3."
  #define Q_string_to_number s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_boolean_symbol), sc->is_string_symbol, sc->is_integer_symbol)

  s7_int radix = 0;
  char *str;

  if (!is_string(car(args)))
    method_or_bust(sc, car(args), caller, args, T_STRING, 1);

  if (is_pair(cdr(args)))
    {
      s7_pointer rad, p;
      rad = cadr(args);
      if (!s7_is_integer(rad))
	{
	  if (!s7_is_integer(p = check_values(sc, rad, cdr(args))))
	    method_or_bust(sc, rad, caller, args, T_INTEGER, 2);
	  rad = p;
	}
      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, a_valid_radix_string));
    }
  else radix = 10;

  str = (char *)string_value(car(args));
  if ((!str) || (!(*str)))
    return(sc->F);

  switch (str[0])
    {
    case 'n':
      if (safe_strcmp(str, "nan.0"))
	return(real_NaN);
      break;

    case 'i':
      if (safe_strcmp(str, "inf.0"))
	return(real_infinity);
      break;

    case '-':
      if ((str[1] == 'i') && (safe_strcmp((const char *)(str + 1), "inf.0")))
	return(real_minus_infinity);
      break;

    case '+':
      if ((str[1] == 'i') && (safe_strcmp((const char *)(str + 1), "inf.0")))
	return(real_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_symbol));
}

static s7_pointer c_string_to_number(s7_scheme *sc, s7_pointer n)
{
  return(g_string_to_number_1(sc, set_plist_1(sc, n), sc->string_to_number_symbol));
}

PF_TO_PF(string_to_number, c_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));

    case T_COMPLEX:
      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)));

    default:
#if WITH_GMP
      if ((is_big_number(a)) || (is_big_number(b))) /* this can happen if (member bignum ...) -> memv */
	return(big_numbers_are_eqv(a, b));
#endif
      break;
    }
  return(false);
}


static bool is_rational_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_rational(p))
    return(true);
  if (has_methods(p))
    {
      s7_pointer f;
      f = find_method(sc, find_let(sc, p), sc->is_rational_symbol);
      if (f != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
    }
  return(false);
}


/* -------------------------------- abs -------------------------------- */
#if (!WITH_GMP)
static s7_pointer g_abs(s7_scheme *sc, s7_pointer args)
{
  #define H_abs "(abs x) returns the absolute value of the real number x"
  #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)  

  s7_pointer x;
  x = car(args);
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) < 0)
	{
	  if (integer(x) == s7_int_min)
	    return(make_integer(sc, s7_int_max));
	  return(make_integer(sc, -integer(x)));
	}
      return(x);

    case T_RATIO:
      if (numerator(x) < 0)
	{
	  if (numerator(x) == s7_int_min)
	    return(s7_make_ratio(sc, s7_int_max, denominator(x)));
	  return(s7_make_ratio(sc, -numerator(x), denominator(x)));
	}
      return(x);

    case T_REAL:
      if (is_NaN(real(x)))                  /* (abs -nan.0) -> nan.0, not -nan.0 */
	return(real_NaN);
      if (real(x) < 0.0)
	return(make_real(sc, -real(x)));
      return(x);

    default:
      method_or_bust(sc, x, sc->abs_symbol, args, T_REAL, 0);
    }
}

static s7_int c_abs_i(s7_scheme *sc, s7_int arg) {return((arg < 0) ? (-arg) : arg);}
IF_TO_IF(abs, c_abs_i)

static s7_double c_abs_r(s7_scheme *sc, s7_double arg) {return((arg < 0.0) ? (-arg) : arg);} 
DIRECT_RF_TO_RF(fabs)


/* -------------------------------- magnitude -------------------------------- */

static double my_hypot(double x, double y)
{
  /* according to callgrind, this is much faster than libc's hypot */
  if (x == 0.0) return(fabs(y));
  if (y == 0.0) return(fabs(x));
  if (x == y) return(1.414213562373095 * fabs(x));
  if ((is_NaN(x)) || (is_NaN(y))) return(NAN);
  return(sqrt(x * x + y * y));
}

static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
{
  #define H_magnitude "(magnitude z) returns the magnitude of z"
  #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
  s7_pointer x;
  x = car(args);

  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == s7_int_min)
	return(make_integer(sc, s7_int_max));
      /* (magnitude -9223372036854775808) -> -9223372036854775808
       *   same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808
       */
      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 (is_NaN(real(x)))                 /* (magnitude -nan.0) -> nan.0, not -nan.0 */
	return(real_NaN);
      if (real(x) < 0.0)
	return(make_real(sc, -real(x)));
      return(x);

    case T_COMPLEX:
      return(make_real(sc, my_hypot(imag_part(x), real_part(x))));

    default:
      method_or_bust_with_type(sc, x, sc->magnitude_symbol, args, a_number_string, 0);
    }
}

IF_TO_IF(magnitude, c_abs_i)
RF_TO_RF(magnitude, c_abs_r)



/* -------------------------------- rationalize -------------------------------- */
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"
  #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
  s7_double err;
  s7_pointer x;

  x = car(args);
  if (!s7_is_real(x))
    method_or_bust(sc, x, sc->rationalize_symbol, args, T_REAL, 1);

  if (is_not_null(cdr(args)))
    {
      s7_pointer ex;
      ex = cadr(args);
      if (!s7_is_real(ex))
	method_or_bust(sc, ex, sc->rationalize_symbol, args, T_REAL, 2);

      err = real_to_double(sc, ex, "rationalize");
      if (is_NaN(err))
	return(out_of_range(sc, sc->rationalize_symbol, small_int(2), cadr(args), its_nan_string));
      if (err < 0.0) err = -err;
    }
  else err = sc->default_rationalize_error;

  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 = real_to_double(sc, x, "rationalize");

	if ((is_NaN(rat)) || (is_inf(rat)))
	  return(wrong_type_argument_with_type(sc, sc->rationalize_symbol, 1, x, a_normal_real_string));

	if (err >= fabs(rat))
	  return(small_int(0));

	if ((rat > 9.2233720368548e+18) || (rat < -9.2233720368548e+18))
	  return(out_of_range(sc, sc->rationalize_symbol, small_int(1), x, its_too_large_string));

	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);
      }
    }
  return(sc->F); /* make compiler happy */
}

static s7_pointer c_rats(s7_scheme *sc, s7_pointer x) {return(g_rationalize(sc, set_plist_1(sc, x)));}
PF_TO_PF(rationalize, c_rats)


/* -------------------------------- angle -------------------------------- */
static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
{
  #define H_angle "(angle z) returns the angle of z"
  #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
  s7_pointer x;
  /* (angle inf+infi) -> 0.78539816339745 ? 
   *   I think this should be -pi < ang <= pi
   */

  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:
      method_or_bust_with_type(sc, x, sc->angle_symbol, args, a_number_string, 0);
    }
}


/* -------------------------------- make-polar -------------------------------- */
#if (!WITH_PURE_S7)
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"
  #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)

  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:
	  method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
	}
      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 = (s7_double)fraction(x);
	  break;

	default:
	  method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
	}
      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:
	  method_or_bust(sc, y, sc->make_polar_symbol, args, T_REAL, 2);
	}
      break;

    default:
      method_or_bust(sc, x, sc->make_polar_symbol, args, T_REAL, 1);
    }

  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 c_make_polar_2(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_make_polar(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(make_polar, c_make_polar_2)
#endif


/* -------------------------------- complex -------------------------------- */
static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, y;
  #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
  #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)

  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:
	  method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
	}

    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:
	  method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
	}

    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:
	  method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1);
	}

    default:
      method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, args, T_REAL, 2);
    }
}

static s7_pointer c_make_complex_2(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_complex(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(make_complex, c_make_complex_2)


/* -------------------------------- exp -------------------------------- */
static s7_pointer g_exp(s7_scheme *sc, s7_pointer args)
{
  #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
  #define Q_exp pcl_n  

  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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->exp_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(exp)


/* -------------------------------- log -------------------------------- */

#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"
  #define Q_log pcl_n

  s7_pointer x;
  x = car(args);
  if (!s7_is_number(x))
    method_or_bust_with_type(sc, x, sc->log_symbol, args, a_number_string, 1);

  if (is_pair(cdr(args)))
    {
      s7_pointer y;

      y = cadr(args);
      if (!(s7_is_number(y)))
	method_or_bust_with_type(sc, y, sc->log_symbol, args, a_number_string, 2);

      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
		  /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */
#if ((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4))))
		  return(make_real(sc, fx));
#else
		  if ((ix & (ix - 1)) == 0)
		    return(make_integer(sc, (s7_int)s7_round(fx)));
		  return(make_real(sc, fx));
#endif
		}
	    }
	  if ((s7_is_real(x)) &&
	      (s7_is_positive(x)))
	    return(make_real(sc, log(real_to_double(sc, x, "log")) * LOG_2));
	  return(s7_from_c_complex(sc, clog(s7_to_c_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_symbol, small_int(2), y, make_string_wrapper(sc, "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(real_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(rational_to_double(sc, x)) / log(rational_to_double(sc, 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(real_to_double(sc, x, "log")) / log(real_to_double(sc, y, "log"))));
	}
      return(s7_from_c_complex(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y))));
    }

  if (s7_is_real(x))
    {
      if (s7_is_positive(x))
	return(make_real(sc, log(real_to_double(sc, x, "log"))));
      return(s7_make_complex(sc, log(-real_to_double(sc, x, "log")), M_PI));
    }
  return(s7_from_c_complex(sc, clog(s7_to_c_complex(x))));
}


/* -------------------------------- sin -------------------------------- */
static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
{
  #define H_sin "(sin z) returns sin(z)"
  #define Q_sin pcl_n  

  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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->sin_symbol, args, a_number_string, 0);
    }

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

DIRECT_RF_TO_RF(sin)


/* -------------------------------- cos -------------------------------- */
static s7_pointer g_cos(s7_scheme *sc, s7_pointer args)
{
  #define H_cos "(cos z) returns cos(z)"
  #define Q_cos pcl_n  

  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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->cos_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(cos)


/* -------------------------------- tan -------------------------------- */
static s7_pointer g_tan(s7_scheme *sc, s7_pointer args)
{
  #define H_tan "(tan z) returns tan(z)"
  #define Q_tan pcl_n  

  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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->tan_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(tan)


/* -------------------------------- asin -------------------------------- */
static s7_pointer c_asin(s7_scheme *sc, s7_double x)
{
  s7_double absx, recip;
  s7_complex result;

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

static s7_pointer g_asin_1(s7_scheme *sc, s7_pointer n)
{
  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 */
      return(c_asin(sc, (s7_double)integer(n)));

    case T_RATIO:
      return(c_asin(sc, (s7_double)numerator(n) / (s7_double)denominator(n)));

    case T_REAL:
      return(c_asin(sc, real(n)));

    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_symbol, small_int(1), n, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, n, sc->asin_symbol, list_1(sc, n), a_number_string, 0);
    }
}

static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
{
  #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x"
  #define Q_asin pcl_n  

  return(g_asin_1(sc, car(args)));
}

R_P_F_TO_PF(asin, c_asin, g_asin_1, g_asin_1)
/* g_asin_1 is safe for the gf case because it won't trigger the GC before it is done with its argument */


/* -------------------------------- acos -------------------------------- */
static s7_pointer c_acos(s7_scheme *sc, s7_double x)
{
  s7_double absx, recip;
  s7_complex result;

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

static s7_pointer g_acos_1(s7_scheme *sc, s7_pointer n)
{
  switch (type(n))
    {
    case T_INTEGER:
      if (integer(n) == 1) return(small_int(0));
      return(c_acos(sc, (s7_double)integer(n)));

    case T_RATIO:
      return(c_acos(sc, (s7_double)numerator(n) / (s7_double)denominator(n)));

    case T_REAL:
      return(c_acos(sc, real(n)));

    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_to_c_complex(n))));
#else
      return(out_of_range(sc, sc->acos_symbol, small_int(1), n, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, n, sc->acos_symbol, list_1(sc, n), a_number_string, 0);
    }
}

static s7_pointer g_acos(s7_scheme *sc, s7_pointer args)
{
  #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
  #define Q_acos pcl_n  
  return(g_acos_1(sc, car(args)));
}

R_P_F_TO_PF(acos, c_acos, g_acos_1, g_acos_1)


/* -------------------------------- atan -------------------------------- */

static s7_double c_atan(s7_scheme *sc, s7_double x, s7_double y)
{
  return(atan2(x, y));
}

static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
{
  #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
  #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
  /* actually if there are two args, both should be real, but how to express that in the signature? */
  s7_pointer x, y;
  s7_double x1, x2;

  /* 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_RATIO:
	case T_REAL:
	  return(make_real(sc, atan(real_to_double(sc, x, "atan"))));

	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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

	default:
	  method_or_bust_with_type(sc, x, sc->atan_symbol, args, a_number_string, 0);
	}
    }

  if (!s7_is_real(x))
    method_or_bust(sc, x, sc->atan_symbol, args, T_REAL, 1);

  y = cadr(args);
  if (!s7_is_real(y))
    method_or_bust(sc, y, sc->atan_symbol, args, T_REAL, 2);
  
  x1 = real_to_double(sc, x, "atan");
  x2 = real_to_double(sc, y, "atan");
  return(make_real(sc, atan2(x1, x2)));
}

RF2_TO_RF(atan, c_atan)


/* -------------------------------- sinh -------------------------------- */
static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args)
{
  #define H_sinh "(sinh z) returns sinh(z)"
  #define Q_sinh pcl_n  

  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(real_to_double(sc, x, "sinh"))));

    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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->sinh_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(sinh)


/* -------------------------------- cosh -------------------------------- */
static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args)
{
  #define H_cosh "(cosh z) returns cosh(z)"
  #define Q_cosh pcl_n  

  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(real_to_double(sc, x, "cosh"))));

    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_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->cosh_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(cosh)


/* -------------------------------- tanh -------------------------------- */
static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args)
{
  #define H_tanh "(tanh z) returns tanh(z)"
  #define Q_tanh pcl_n  

  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(real_to_double(sc, x, "tanh"))));

    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 ctanh's -0.0 */
      return(s7_from_c_complex(sc, ctanh(as_c_complex(x))));
#else
      return(out_of_range(sc, sc->tanh_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->tanh_symbol, args, a_number_string, 0);
    }
}

DIRECT_RF_TO_RF(tanh)


/* -------------------------------- asinh -------------------------------- */
static s7_pointer c_asinh_1(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));
      return(make_real(sc, asinh((s7_double)integer(x))));

    case T_RATIO:
      return(make_real(sc, asinh((s7_double)numerator(x) / (s7_double)denominator(x))));

    case T_REAL:
      return(make_real(sc, asinh(real(x))));

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
  #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
      return(s7_from_c_complex(sc, casinh_1(as_c_complex(x))));
  #else
      return(s7_from_c_complex(sc, casinh(as_c_complex(x))));
  #endif
#else
      return(out_of_range(sc, sc->asinh_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->asinh_symbol, list_1(sc, x), a_number_string, 0);
    }
}

static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args)
{
  #define H_asinh "(asinh z) returns asinh(z)"
  #define Q_asinh pcl_n  

  return(c_asinh_1(sc, car(args)));
}

static s7_pointer c_asinh(s7_scheme *sc, s7_double x)
{
  return(make_real(sc, asinh(x)));
}

R_P_F_TO_PF(asinh, c_asinh, c_asinh_1, c_asinh_1)


/* -------------------------------- acosh -------------------------------- */
static s7_pointer c_acosh_1(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 1) return(small_int(0));

    case T_REAL:
    case T_RATIO:
      {
	double x1;
	x1 = real_to_double(sc, x, "acosh");
	if (x1 >= 1.0)
	  return(make_real(sc, acosh(x1)));
      }

    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
  #ifdef __OpenBSD__
      return(s7_from_c_complex(sc, cacosh_1(s7_to_c_complex(x))));
  #else
      return(s7_from_c_complex(sc, cacosh(s7_to_c_complex(x)))); /* not as_c_complex because x might not be complex */
  #endif
#else
      /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
      return(out_of_range(sc, sc->acosh_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->acosh_symbol, list_1(sc, x), a_number_string, 0);
    }
}

static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args)
{
  #define H_acosh "(acosh z) returns acosh(z)"
  #define Q_acosh pcl_n  
  return(c_acosh_1(sc, car(args)));
}

static s7_pointer c_acosh(s7_scheme *sc, s7_double x)
{
  if (x >= 1.0)
    return(make_real(sc, acosh(x)));
  return(c_acosh_1(sc, set_plist_1(sc, make_real(sc, x))));
}

R_P_F_TO_PF(acosh, c_acosh, c_acosh_1, c_acosh_1)


/* -------------------------------- atanh -------------------------------- */
static s7_pointer c_atanh_1(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_INTEGER:
      if (integer(x) == 0) return(small_int(0));                    /* (atanh 0) -> 0 */

    case T_REAL:
    case T_RATIO:
      {
	double x1;
	x1 = real_to_double(sc, x, "atanh");
	if (fabs(x1) < 1.0)
	  return(make_real(sc, atanh(x1)));
      }

      /* if we can't distinguish x from 1.0 even with long doubles, we'll get inf.0:
       *    (atanh 9223372036854775/9223372036854776) -> 18.714973875119
       *    (atanh 92233720368547758/92233720368547757) -> inf.0
       */
    case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
  #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
      return(s7_from_c_complex(sc, catanh_1(s7_to_c_complex(x))));
  #else
      return(s7_from_c_complex(sc, catanh(s7_to_c_complex(x))));
  #endif
#else
      return(out_of_range(sc, sc->atanh_symbol, small_int(1), x, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->atanh_symbol, list_1(sc, x), a_number_string, 0);
    }
}

static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args)
{
  #define H_atanh "(atanh z) returns atanh(z)"
  #define Q_atanh pcl_n  
  return(c_atanh_1(sc, car(args)));
}

static s7_pointer c_atanh(s7_scheme *sc, s7_double x)
{
  if (fabs(x) < 1.0)
    return(make_real(sc, atanh(x)));
  return(c_atanh_1(sc, set_plist_1(sc, make_real(sc, x))));
}

R_P_F_TO_PF(atanh, c_atanh, c_atanh_1, c_atanh_1)


/* -------------------------------- sqrt -------------------------------- */
static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args)
{
  #define H_sqrt "(sqrt z) returns the square root of z"
  #define Q_sqrt pcl_n  

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

    case T_RATIO:
      sqx = (s7_double)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 HAVE_OVERFLOW_CHECKS
	      s7_int nm2, dn2;
	      if ((multiply_overflow(nm, nm, &nm2)) ||
		  (multiply_overflow(dn, dn, &dn2)))
		return(make_real(sc, sqrt(sqx)));
	      if ((nm2 == numerator(n)) &&
		  (dn2 == denominator(n)))
		return(s7_make_ratio(sc, nm, dn));
#else
	      if ((nm * nm == numerator(n)) &&
		  (dn * dn == denominator(n)))
		return(s7_make_ratio(sc, nm, dn));
#endif
	    }
	  return(make_real(sc, sqrt(sqx)));
	}
      return(s7_make_complex(sc, 0.0, sqrt(-sqx)));

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

    case T_COMPLEX:
      /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */
#if HAVE_COMPLEX_NUMBERS
      return(s7_from_c_complex(sc, csqrt(as_c_complex(n))));
#else
      return(out_of_range(sc, sc->sqrt_symbol, small_int(1), n, no_complex_numbers_string));
#endif

    default:
      method_or_bust_with_type(sc, n, sc->sqrt_symbol, args, a_number_string, 0);
    }
}


/* -------------------------------- expt -------------------------------- */

static s7_int int_to_int(s7_int x, s7_int n)
{
  /* from GSL */
  s7_int value = 1;
  do {
    if (n & 1) value *= x;
    n >>= 1;
#if HAVE_OVERFLOW_CHECKS
    if (multiply_overflow(x, x, &x))
      break;
#else
    x *= x;
#endif
  } while (n);
  return(value);
}


static const 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"
  #define Q_expt pcl_n
  s7_pointer n, pw;

  n = car(args);
  if (!s7_is_number(n))
    method_or_bust_with_type(sc, n, sc->expt_symbol, args, a_number_string, 1);

  pw = cadr(args);
  if (!s7_is_number(pw))
    method_or_bust_with_type(sc, pw, sc->expt_symbol, args, a_number_string, 2);

  /* 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_symbol, 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_symbol, args));
	  if ((is_NaN(real_part(pw))) ||                       /* (expt 0 0+1/0i) */
	      (is_NaN(imag_part(pw))))
	    return(real_NaN);
	}

      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, rational_to_double(sc, n)));
      return(n);
    }

  if (is_t_integer(pw))
    {
      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 (complex 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_int_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_int_min)                            /* (expt x most-negative-fixnum) */
	      return(small_int(0));
	    if (x == s7_int_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_int_min)
	      {
		if (s7_int_abs(nm) > dn)
		  return(small_int(0));              /* (expt 4/3 most-negative-fixnum) -> 0? */
		return(real_infinity);               /* (expt 3/4 most-negative-fixnum) -> inf? */
	      }

	    if ((int_pow_ok(nm, s7_int_abs(y))) &&
		(int_pow_ok(dn, s7_int_abs(y))))
	      {
		if (y > 0)
		  return(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_int_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_symbol, small_int(2), n, no_complex_numbers_string));
#endif
	  break;
	}
    }

  if ((s7_is_real(n)) &&
      (s7_is_real(pw)))
    {
      s7_double x, y;

      if ((is_t_ratio(pw)) &&
	  (numerator(pw) == 1))
	{
	  if (denominator(pw) == 2)
	    return(g_sqrt(sc, args));
	  if (denominator(pw) == 3)
	    return(make_real(sc, cbrt(real_to_double(sc, n, "expt")))); /* (expt 27 1/3) should be 3, not 3.0... */

	  /* but: (expt 512/729 1/3) -> 0.88888888888889
	   */
	  /* and 4 -> sqrt(sqrt...) etc? */
	}

      x = real_to_double(sc, n, "expt");
      y = real_to_double(sc, pw, "expt");

      if (is_NaN(x)) return(n);
      if (is_NaN(y)) return(pw);
      if (y == 0.0) return(real_one);

      if (x > 0.0)
	return(make_real(sc, pow(x, y)));
      /* tricky cases abound here: (expt -1 1/9223372036854775807)
       */
    }

  /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ?
   * (expt 0+i 1+1/0i) = 0.0 ??
   */
  return(s7_from_c_complex(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw))));
}


#if (!WITH_GMP)
static s7_pointer c_expt_i(s7_scheme *sc, s7_int x, s7_int y)
{
  if (y == 0) return(small_int(1));
  if (y == 1) return(make_integer(sc, x));
  return(g_expt(sc, set_plist_2(sc, make_integer(sc, x), make_integer(sc, y))));
}

static s7_pointer c_expt_r(s7_scheme *sc, s7_double x, s7_double y)
{
  if (y > 0.0)
    return(make_real(sc, pow(x, y)));
  return(g_expt(sc, set_plist_2(sc, make_real(sc, x), make_real(sc, y))));
}

static s7_pointer c_expt_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  return(g_expt(sc, set_plist_2(sc, x, y)));
}

XF2_TO_PF(expt, c_expt_i, c_expt_r, c_expt_2)
#endif


/* -------------------------------- lcm -------------------------------- */
static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
{
  #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
  #define Q_lcm pcl_f

  s7_int n = 1, d = 0;
  s7_pointer p;

  if (!is_pair(args))
    return(small_int(1));

  if (!is_pair(cdr(args)))
    {
      if (!is_rational(car(args)))
	method_or_bust_with_type(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1);
      return(g_abs(sc, args));
    }

  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer x;
      s7_int b;
      x = car(p);
      switch (type(x))
	{
	case T_INTEGER:
	  if (integer(x) == 0)
	    n = 0;
	  else 
	    {
	      b = integer(x);
	      if (b < 0) b = -b;
	      n = (n / c_gcd(n, b)) * b;
	    }
	  if (d != 0) d = 1;
	  break;

	case T_RATIO:
	  b = numerator(x);
	  if (b < 0) b = -b;
	  n = (n / c_gcd(n, b)) * b;
	  if (d == 0)
	    {
	      if (p == args)
		d = s7_denominator(x);
	      else d = 1;
	    }
	  else d = c_gcd(d, s7_denominator(x));
	  break;

	default:
	  method_or_bust_with_type(sc, x, sc->lcm_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args));
	}
      if (n < 0) return(simple_out_of_range(sc, sc->lcm_symbol, args, result_is_too_large_string));
      if (n == 0)
	{
	  for (p = cdr(p); is_pair(p); p = cdr(p))
	    if (!is_rational_via_method(sc, car(p)))
	      return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string));
	  return(small_int(0));
	}
    }

  if (d <= 1)
    return(make_integer(sc, n));
  return(s7_make_ratio(sc, n, d));
}

static s7_int c_lcm(s7_scheme *sc, 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);
}

IF2_TO_IF(lcm, c_lcm)


/* -------------------------------- gcd -------------------------------- */
static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
{
  #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
  #define Q_gcd pcl_f
  s7_int n = 0, d = 1;
  s7_pointer p;

  if (!is_pair(args))
    return(small_int(0));

  if (!is_pair(cdr(args)))
    {
      if (!is_rational(car(args)))
	method_or_bust_with_type(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1);
      return(g_abs(sc, args));
    }

  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer x;
      s7_int b;
      x = car(p);
      switch (type(x))
	{
	case T_INTEGER:
	  n = c_gcd(n, integer(x));
	  break;

	case T_RATIO:
	  n = c_gcd(n, s7_numerator(x));
	  b = s7_denominator(x);
	  if (b < 0) b = -b;
	  d = (d / c_gcd(d, b)) * b;
	  if (d < 0) return(simple_out_of_range(sc, sc->gcd_symbol, args, result_is_too_large_string));
	  break;

	default:
	  method_or_bust_with_type(sc, x, sc->gcd_symbol, cons(sc, (d <= 1) ? make_integer(sc, n) : s7_make_ratio(sc, n, d), p), a_rational_string, position_of(p, args));
	}
      if (n < 0) return(simple_out_of_range(sc, sc->gcd_symbol, args, result_is_too_large_string));
    }

  if (d <= 1)
    return(make_integer(sc, n));
  return(s7_make_ratio(sc, n, d));
}

static s7_int c_gcd_1(s7_scheme *sc, s7_int a, s7_int b) {return(c_gcd(a, b));}

IF2_TO_IF(gcd, c_gcd_1)


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_int_max) ||
      (xf < s7_int_min))
    return(simple_out_of_range(sc, caller, make_real(sc, xf), its_too_large_string));

  if (xf > 0.0)
    return(make_integer(sc, (s7_int)floor(xf)));
  return(make_integer(sc, (s7_int)ceil(xf)));
}

static s7_int c_quo_int(s7_scheme *sc, s7_int x, s7_int y)
{
  if (y == 0)
    division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
  if ((y == -1) && (x == s7_int_min))   /* (quotient most-negative-fixnum -1) */
    simple_out_of_range(sc, sc->quotient_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)), its_too_large_string);
  return(x / y);
}

static s7_double c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y)
{
  s7_double xf;

  if (y == 0.0)
    division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
  if ((is_inf(y)) || (is_NaN(y)))
    wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, make_real(sc, y), a_normal_real_string);

  xf = x / y;
  if ((xf > s7_int_max) ||
      (xf < s7_int_min))
    simple_out_of_range(sc, sc->quotient_symbol, make_real(sc, xf), its_too_large_string);

  if (xf > 0.0)
    return(floor(xf));
  return(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 Q_quotient pcl_r
  /* (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:
	  return(make_integer(sc, c_quo_int(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_symbol, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string));
	  return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y)));

	default:
	  method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    return(division_by_zero_error(sc, sc->quotient_symbol, args));
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = integer(y);
	  d2 = 1;
	  goto RATIO_QUO_RATIO;
	  /* this can lose:
	   *   (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1
	   *   (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0
	   */

	case T_RATIO:
	  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 HAVE_OVERFLOW_CHECKS
	  {
	    s7_int n1d2, n2d1;
	    if ((multiply_overflow(n1, d2, &n1d2)) ||
		(multiply_overflow(n2, d1, &n2d1)))
	      return(s7_truncate(sc, sc->quotient_symbol, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
	    return(make_integer(sc, n1d2 / n2d1));
	  }
#else
	  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_symbol, ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1)));
	  return(make_integer(sc, (n1 * d2) / (n2 * d1)));
#endif

	case T_REAL:
	  if (real(y) == 0.0)
	    return(division_by_zero_error(sc, sc->quotient_symbol, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string));
	  return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y)));

	default:
	  method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
	}

    case T_REAL:
      if ((is_inf(real(x))) || (is_NaN(real(x))))
	return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 1, x, a_normal_real_string));

      /* 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_symbol, args));
	  return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)integer(y)));

	case T_RATIO:
	  return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y)));

	case T_REAL:
	  return(make_real(sc, c_quo_dbl(sc, real(x), real(y))));

	default:
	  method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);
	}

    default:
      method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 2);
    }
}


IF2_TO_IF(quotient, c_quo_int)
RF2_TO_RF(quotient, c_quo_dbl)


static s7_int c_rem_int(s7_scheme *sc, s7_int x, s7_int y)
{
  if (y == 0)
    division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, make_integer(sc, x), make_integer(sc, y)));
  if ((y == 1) || (y == -1))   /* (remainder most-negative-fixnum -1) will segfault with arithmetic exception */
    return(0);
  return(x % y);
}

static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y)
{
  s7_int quo;
  s7_double pre_quo;
  if (y == 0.0)
    division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)));
  if ((is_inf(y)) || (is_NaN(y)))
    wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, set_elist_1(sc, make_real(sc, y)), a_normal_real_string);

  pre_quo = x / y;
  if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
    simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, make_real(sc, x), make_real(sc, y)), its_too_large_string);
  if (pre_quo > 0.0) 
    quo = (s7_int)floor(pre_quo); 
  else quo = (s7_int)ceil(pre_quo);
  return(x - (y * quo));
}

static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
{
  #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1"
  #define Q_remainder pcl_r
  /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */

  s7_pointer x, 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:
	  return(make_integer(sc, c_rem_int(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_symbol, args));
	  if ((is_inf(real(y))) || (is_NaN(real(y))))
	    return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string));

	  pre_quo = (s7_double)integer(x) / real(y);
	  if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
	    return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
	  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:
	  method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  n2 = integer(y);
	  if (n2 == 0)
	    return(division_by_zero_error(sc, sc->remainder_symbol, 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 HAVE_OVERFLOW_CHECKS
		  s7_int n1d2, n2d1;
		  if ((multiply_overflow(n1, d2, &n1d2)) ||
		      (multiply_overflow(n2, d1, &n2d1)))
		    {
		      pre_quo = ((long double)n1 / (long double)n2) * ((long double)d2 / (long double)d1);
		      if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
			return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
		      if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
		    }
		  else quo = n1d2 / n2d1;
#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_int_max) || (pre_quo < s7_int_min))
			return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
		      if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo);
		    }
		  else quo = (n1 * d2) / (n2 * d1);
#endif
		}
	    }
	  if (quo == 0)
	    return(x);

#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn, nq;
	    if (!multiply_overflow(n2, quo, &nq))
	      {
		if ((d1 == d2) &&
		    (!subtract_overflow(n1, nq, &dn)))
		  return(s7_make_ratio(sc, dn, d1));

		if ((!multiply_overflow(n1, d2, &dn)) &&
		    (!multiply_overflow(nq, d1, &nq)) &&
		    (!subtract_overflow(dn, nq, &nq)) &&
		    (!multiply_overflow(d1, d2, &d1)))
		  return(s7_make_ratio(sc, nq, d1));
	      }
	  }
#else
	  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));
#endif
	  return(simple_out_of_range(sc, sc->remainder_symbol, args, make_string_wrapper(sc, "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_symbol, args));
	    if ((is_inf(real(y))) || (is_NaN(real(y))))
	      return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string));
	    frac = (s7_double)fraction(x);
	    pre_quo = frac / real(y);
	    if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
	      return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
	    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:
	  method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
	}

    case T_REAL:
      if ((is_inf(real(x))) || (is_NaN(real(x))))
	return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 1, x, a_normal_real_string));

      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0)
	    return(division_by_zero_error(sc, sc->remainder_symbol, args));
	  pre_quo = real(x) / (s7_double)integer(y);
	  if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
	    return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
	  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));
	  /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */

	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 = (s7_double)fraction(y);
	    pre_quo = real(x) / frac;
	    if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min))
	      return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string));
	    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:
	  return(make_real(sc, c_rem_dbl(sc, real(x), real(y))));

	  /* see under sin -- this calculation is completely bogus if "a" is large
	   * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 -- 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:
	  method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);
	}

    default:
      method_or_bust(sc, x, sc->remainder_symbol, args, T_REAL, 1);
    }
}

IF2_TO_IF(remainder, c_rem_int)
RF2_TO_RF(remainder, c_rem_dbl)


/* -------------------------------- floor -------------------------------- */

#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"
  #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  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_symbol, x, its_nan_string));
	if (fabs(z) > REAL_TO_INT_LIMIT)
	  return(simple_out_of_range(sc, sc->floor_symbol, x, its_too_large_string));
	return(make_integer(sc, (s7_int)floor(z)));
	/* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */
      }

    case T_COMPLEX:
    default:
      method_or_bust(sc, x, sc->floor_symbol, args, T_REAL, 0);
    }
}

static s7_int c_floor(s7_scheme *sc, s7_double x) {return((s7_int)floor(x));}
RF_TO_IF(floor, c_floor)


/* -------------------------------- ceiling -------------------------------- */
static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
{
  #define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
  #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  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_symbol, x, its_nan_string));
	if ((is_inf(z)) ||
	    (z > REAL_TO_INT_LIMIT) ||
	    (z < -REAL_TO_INT_LIMIT))
	  return(simple_out_of_range(sc, sc->ceiling_symbol, x, its_too_large_string));
	return(make_integer(sc, (s7_int)ceil(real(x))));
      }

    case T_COMPLEX:
    default:
      method_or_bust(sc, x, sc->ceiling_symbol, args, T_REAL, 0);
    }
}

static s7_int c_ceiling(s7_scheme *sc, s7_double x) {return((s7_int)ceil(x));}
RF_TO_IF(ceiling, c_ceiling)


/* -------------------------------- truncate -------------------------------- */
static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args)
{
  #define H_truncate "(truncate x) returns the integer closest to x toward 0"
  #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  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_symbol, x, its_nan_string));
	if (is_inf(z))
	  return(simple_out_of_range(sc, sc->truncate_symbol, x, its_infinite_string));
	return(s7_truncate(sc, sc->truncate_symbol, real(x)));
      }

    case T_COMPLEX:
    default:
      method_or_bust(sc, x, sc->truncate_symbol, args, T_REAL, 0);
    }
}

static s7_int c_trunc(s7_scheme *sc, s7_double x)
{
  if ((x > s7_int_max) || (x < s7_int_min))
    simple_out_of_range(sc, sc->truncate_symbol, make_real(sc, x), its_too_large_string);
  if (x > 0.0)
    return((s7_int)floor(x));
  return((s7_int)ceil(x));
}

RF_TO_IF(truncate, c_trunc)


/* -------------------------------- round -------------------------------- */
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"
  #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  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_symbol, x, its_nan_string));
	if ((is_inf(z)) ||
	    (z > REAL_TO_INT_LIMIT) ||
	    (z < -REAL_TO_INT_LIMIT))
	  return(simple_out_of_range(sc, sc->round_symbol, x, its_too_large_string));
	return(make_integer(sc, (s7_int)round_per_R5RS(z)));
      }

    case T_COMPLEX:
    default:
      method_or_bust(sc, x, sc->round_symbol, args, T_REAL, 0);
    }
}

static s7_int c_round(s7_scheme *sc, s7_double x) {return((s7_int)round_per_R5RS(x));}
RF_TO_IF(round, c_round)


static s7_int c_mod(s7_scheme *sc, 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);
}

static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
{
  #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1.  The arguments can be real numbers."
  #define Q_modulo pcl_r
  /* (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(sc, 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:
	  method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
	}

    case T_RATIO:
      switch (type(y))
	{
	case T_INTEGER:
	  if (integer(y) == 0) return(x);
	  n1 = numerator(x);
	  d1 = denominator(x);
	  n2 = integer(y);

	  if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x);
	  if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x);

	  if (n2 == s7_int_min)
	    return(simple_out_of_range(sc, sc->modulo_symbol, y, make_string_wrapper(sc, "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(sc, n1, n2), d1));

	RATIO_MOD_RATIO:

	  if ((n1 == n2) &&
	      (d1 > d2))
	    return(x);                 /* signs match so this should be ok */
#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int n2d1, n1d2, d1d2, fl;
	    if (!multiply_overflow(n2, d1, &n2d1))
	      {
		if (n2d1 == 1)
		  return(small_int(0));
		
		if (!multiply_overflow(n1, d2, &n1d2))
		  {
		    /* 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 ((!multiply_overflow(d1, d2, &d1d2)) &&
			(!multiply_overflow(fl, n2d1, &fl)) &&
			(!subtract_overflow(n1d2, fl, &fl)))
		      return(s7_make_ratio(sc, fl, d1d2));
		  }
	      }
	  }
#else
	  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));
	    }
#endif

	  /* 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_symbol, x, make_string_wrapper(sc, "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:
	  method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
	}

    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:
	  method_or_bust(sc, y, sc->modulo_symbol, args, T_REAL, 2);
	}

    default:
      method_or_bust(sc, x, sc->modulo_symbol, args, T_REAL, 1);
    }
}

IF2_TO_IF(modulo, c_mod)
static s7_double c_mod_r(s7_scheme *sc, s7_double x, s7_double y) {return(x - y * (s7_int)floor(x / y));}
RF2_TO_RF(modulo, c_mod_r)

static s7_pointer mod_si;
static s7_pointer g_mod_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_int y;

  x = find_symbol_checked(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_t_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, set_plist_2(sc, x, cadr(args))));

  method_or_bust(sc, x, sc->modulo_symbol, list_2(sc, x, cadr(args)), T_REAL, 1);
}

static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args);
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 = find_symbol_checked(sc, cadar(args));
  y = integer(caddar(args));

  if (is_integer(x))
    return(make_boolean(sc, (integer(x) % y) == 0));

  if (is_t_real(x))
    return(make_boolean(sc, (fmod(real(x), (s7_double)y) == 0.0)));

  if (s7_is_ratio(x))
    return(sc->F);

  {
    s7_pointer func;
    if ((func = find_method(sc, find_let(sc, x), sc->modulo_symbol)) != sc->undefined)
      return(g_is_zero(sc, set_plist_1(sc, s7_apply_function(sc, func, list_2(sc, x, caddar(args))))));
  }
  return(wrong_type_argument(sc, sc->modulo_symbol, 1, x, T_REAL));
}
#endif
/* !WITH_GMP */


static int reduce_fraction(s7_scheme *sc, 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)
    {
      if (*denom == *numer)
	{
	  *denom = 1;
	  *numer = 1;
	  return(T_INTEGER);
	}
      if (*denom == s7_int_min)
	{
	  if (*numer & 1)
	    return(T_RATIO);
	  *denom /= 2;
	  *numer /= 2;
	}
      else
	{
	  if (*numer == s7_int_min)
	    {
	      if (*denom & 1)
		return(T_RATIO);
	      *denom /= 2;
	      *numer /= 2;
	    }
	}
      *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"
  #define Q_add pcl_n
  s7_pointer x, p;
  s7_int num_a, den_a, dn;
  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))
	method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 0);
      return(x);
    }

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);

    ADD_INTEGERS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (num_a < s7_int32_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:
#if HAVE_OVERFLOW_CHECKS
	  if (add_overflow(num_a, integer(x), &den_a))
	    {
	      rl_a = (s7_double)num_a + (s7_double)integer(x);
	      if (is_null(p)) return(make_real(sc, rl_a));
	      goto ADD_REALS;
	    }
#else	    
	  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;
		}
	    }
#endif
	  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 HAVE_OVERFLOW_CHECKS
	  if ((multiply_overflow(den_a, num_a, &dn)) || 
	      (add_overflow(dn, numerator(x), &dn)))
#else
	  if ((integer_length(num_a) + integer_length(den_a) + integer_length(numerator(x))) < s7_int_bits)
	    dn = numerator(x) + (num_a * den_a);
	  else
#endif
	    {
	      if (is_null(p))
		{
		  if (num_a == 0)                /* (+ 0 1/9223372036854775807) */
		    return(x);
		  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, dn, den_a));
	  num_a = dn;

	  /* overflow examples:
	   *   (+ 100000 1/142857142857140) -> -832205957599110323/28571428571428
	   *   (+ 4611686018427387904 3/4) -> 3/4
	   * see s7test for more
	   */
	  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:
	  method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    ADD_RATIOS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (den_a > s7_int32_max) ||
	  (num_a < s7_int32_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 HAVE_OVERFLOW_CHECKS
	  if ((multiply_overflow(den_a, integer(x), &dn)) || 
	      (add_overflow(dn, num_a, &dn)))
#else
	  if ((integer_length(integer(x)) + integer_length(den_a) + integer_length(num_a)) < s7_int_bits)
	    dn = num_a + (integer(x) * den_a);
	  else
#endif
	    {
	      /* (+ 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, dn, den_a));
	  num_a = dn;
	  if (reduce_fraction(sc, &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 HAVE_OVERFLOW_CHECKS
		s7_int n1d2, n2d1;
		if ((multiply_overflow(d1, d2, &den_a)) ||
		    (multiply_overflow(n1, d2, &n1d2)) ||
		    (multiply_overflow(n2, d1, &n2d1)) ||
		    (add_overflow(n1d2, n2d1, &num_a)))
		  {
		    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 ADD_REALS;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		      }
		  }
		num_a = n1 * d2 + n2 * d1;
		den_a = d1 * d2;
#endif
#else
		num_a = n1 * d2 + n2 * d1;
		den_a = d1 * d2;
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, num_a, den_a));
	      }
	    /* (+ 1/100 99/100 (- most-positive-fixnum 2)) should not be converted to real
	     */
	    if (reduce_fraction(sc, &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:
	  method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    default:
      method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
    }
}


static s7_pointer add_2, add_1s, add_s1, add_cs1, add_si, add_sf, add_fs;

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 HAVE_OVERFLOW_CHECKS
  {
    s7_int n1d2, n2d1, d1d2, dn;
    if ((multiply_overflow(d1, d2, &d1d2)) ||
	(multiply_overflow(n1, d2, &n1d2)) ||
	(multiply_overflow(n2, d1, &n2d1)) ||
	(add_overflow(n1d2, n2d1, &dn)))
      return(make_real(sc, ((long double)n1 / (long double)d1) + ((long double)n2 / (long double)d2)));
    return(s7_make_ratio(sc, dn, d1d2));
  }
#else
  if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
      (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
      (n1 < s7_int32_min) || (n2 < s7_int32_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
}


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 (is_t_real(x))
	return(make_real(sc, real(x) + real(y)));
      else
	{
	  switch (type(x))
	    {
#if HAVE_OVERFLOW_CHECKS
	    case T_INTEGER:
	      {
		s7_int val;
		if (add_overflow(integer(x), integer(y), &val))
		  return(make_real(sc, (double)integer(x) + (double)integer(y)));
		return(make_integer(sc, val));
	      }
#else
	    case T_INTEGER: return(make_integer(sc, integer(x) + integer(y)));
#endif
	    case T_RATIO:   return(add_ratios(sc, x, y));
	    case T_REAL:    return(make_real(sc, real(x) + real(y)));
	    case T_COMPLEX: return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
	    default:
	      if (!is_number(x))
		method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
	      method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
	    }
	}
    }

  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(make_complex(sc, integer(x) + real_part(y), imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
	}

    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:
	  method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
	}

    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(make_complex(sc, real(x) + real_part(y), imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
	}

    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(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->add_symbol, args, a_number_string, 2);
	}

    default:
      method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_add_s1_1(s7_scheme *sc, s7_pointer x, s7_pointer args)
{
  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER:
      {
	s7_int val;
	if (add_overflow(integer(x), 1, &val))
	  return(make_real(sc, (double)integer(x) + 1.0));
	return(make_integer(sc, val));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) + 1));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->add_symbol, cons(sc, x, cdr(args)), a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_add_s1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = car(args);
  if (is_t_integer(x))
    return(make_integer(sc, integer(x) + 1));
  return(g_add_s1_1(sc, x, args));
}

static s7_pointer c_add_s1(s7_scheme *sc, s7_pointer x)
{
  if (is_t_integer(x))
    return(make_integer(sc, integer(x) + 1));
  return(g_add_s1_1(sc, x, set_plist_1(sc, x)));
}

static s7_pointer g_add_cs1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = find_symbol_checked(sc, car(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) + 1));
  return(g_add_s1_1(sc, x, args));
}

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:
      method_or_bust_with_type(sc, x, sc->add_symbol, args, a_number_string, 2);
    }
  return(x);
}

static s7_pointer g_add_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_int n;

  x = find_symbol_checked(sc, car(args));
  n = integer(cadr(args));
  if (is_integer(x))
#if HAVE_OVERFLOW_CHECKS
    {
      s7_int val;
      if (add_overflow(integer(x), n, &val))
	return(make_real(sc, (double)integer(x) + (double)n));
      return(make_integer(sc, val));
    }
#else
    return(make_integer(sc, integer(x) + n));
#endif
  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:
      method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_add_sf(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_double n;

  x = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_add_fs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_double n;

  x = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, car(args)), a_number_string, 2);
    }
  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 = find_symbol_checked(sc, car(vargs));
  y = real(cadr(vargs));

  if (is_t_real(s))
    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:
      {
	s7_pointer func;
	if ((func = find_method(sc, find_let(sc, s), sc->multiply_symbol)) != sc->undefined)
	  return(g_add_2(sc, set_plist_2(sc, car(args), s7_apply_function(sc, func, list_2(sc, s, cadr(vargs))))));
	return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 1, s, a_number_string));
      }
    }
  return(s);
}


static s7_pointer add_ss_1ss_1(s7_scheme *sc, s7_pointer s1, s7_pointer s2, s7_pointer s3)
{
  s7_double r1, r2, r3, loc, i1, i2, i3, is1;
  if ((is_t_real(s1)) &&
      (is_t_real(s2)) &&
      (is_t_real(s3)))
    return(make_real(sc, (real(s1) * real(s2))  + ((1.0 - real(s1)) * real(s3))));

  if ((is_real(s1)) &&
      (is_real(s2)) &&
      (is_real(s3)))
    {
      r1 = real_to_double(sc, s1, "*");
      r2 = real_to_double(sc, s2, "*");
      r3 = real_to_double(sc, s3, "*");
      return(make_real(sc, (r1 * r2)  + ((1.0 - r1) * r3)));
    }

  r1 = s7_real_part(s1);
  loc = 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) + (loc * r3 - is1 * i3),
			 (r1 * i2 + r2 * i1) + (loc * 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 add_ss_1ss;
static s7_pointer g_add_ss_1ss(s7_scheme *sc, s7_pointer args)
{
  /* (+ (* s1 s2) (* (- 1.0 s1) s3)) */
  s7_pointer s1, s2, s3;
  s1 = find_symbol_checked(sc, cadr(car(args)));
  s2 = find_symbol_checked(sc, opt_sym1(args)); /* caddr(car(args))) */
  s3 = find_symbol_checked(sc, opt_sym2(args)); /* caddr(cadr(args))) */

  return(add_ss_1ss_1(sc, s1, s2, s3));
}


#if (!WITH_GMP)
static s7_double add_rf_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t r1, r2;
  s7_double x, y;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y);
}

static s7_double add_rf_rx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_rf_t r1;
  s1 = **p; (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  return(r1(sc, p) + real_to_double(sc, s1, "+"));
}

static s7_double add_rf_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_rf_t r1;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  return(r1(sc, p) + real_to_double(sc, s1, "+"));
}

static s7_double add_rf_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_double x1;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "+");
  s2 = slot_value(**p); (*p)++;
  return(x1 + real_to_double(sc, s2, "+"));
}

static s7_double add_rf_rs(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_double x1;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  x1 = real_to_double(sc, c1, "+");
  return(x1 + real_to_double(sc, s1, "+"));
}


static s7_double add_rf_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t r1, r2, r3;
  s7_double x, y, z;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  r3 = (s7_rf_t)(**p); (*p)++;
  z = r3(sc, p);
  return(x + y + z);
}

static s7_double add_rf_rxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_rf_t r1, r2;
  s7_double x, y;
  c1 = **p; (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y + real_to_double(sc, c1, "+"));
}

static s7_double add_rf_sxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_rf_t r1, r2;
  s7_double x, y;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y + real_to_double(sc, s1, "+"));
}

static s7_double add_rf_rsx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_rf_t r1;
  s7_double x, x1, x2;
  s1 = slot_value(**p); (*p)++;
  x2 = real_to_double(sc, s1, "+");
  c1 = **p; (*p)++;
  x1 = real_to_double(sc, c1, "+");
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x + x1 + x2);
}

static s7_double add_rf_ssx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_rf_t r1;
  s7_double x, x1;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "+");
  s2 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x + x1 + real_to_double(sc, s2, "+"));
}

static s7_double add_rf_sss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2, s3;
  s7_double x1, x2;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "+");
  s2 = slot_value(**p); (*p)++;
  x2 = real_to_double(sc, s2, "+");
  s3 = slot_value(**p); (*p)++;
  return(x1 + x2 + real_to_double(sc, s3, "+"));
}

static s7_double add_rf_rss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1, s2;
  s7_double x1, x2;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "+");
  s2 = slot_value(**p); (*p)++;
  x2 = real_to_double(sc, s2, "+");
  c1 = **p; (*p)++;
  return(real_to_double(sc, c1, "+") + x1 + x2);
}

static s7_rf_t add_rf_1(s7_scheme *sc, s7_pointer expr, int len)
{
  if (len == 3)
    return(com_rf_2(sc, expr, add_r_ops));
  if (len == 4)
    return(com_rf_3(sc, expr, add_r_ops));

  if (len > 4)
    {
      s7_rf_t rf;
      ptr_int loc;
      int first_len;
      xf_t *rc;

      first_len = (int)(len / 2);
      xf_init(2);
      xf_save_loc(loc);
      rf = add_rf_1(sc, expr, first_len + 1);
      if (rf)
	{
	  int i;
	  s7_pointer p;
	  xf_store_at(loc, (s7_pointer)rf);
	  xf_save_loc(loc);
	  for (i = 0, p = expr; i < first_len; i++, p = cdr(p));
	  rf = add_rf_1(sc, p, len - first_len);
	  if (rf)
	    {
	      xf_store_at(loc, (s7_pointer)rf);
	      return(add_rf_xx);
	    }
	  else return(NULL);
	}
      else return(NULL);
    }
  return(NULL);
}

static s7_rf_t add_rf(s7_scheme *sc, s7_pointer expr)
{
  return(add_rf_1(sc, expr, s7_list_length(sc, expr)));
}


static s7_int add_if_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t r1, r2;
  s7_int x, y;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y);
}

static s7_int add_if_rx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t r1;
  s1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  return(r1(sc, p) + integer(s1));
}

static s7_int add_if_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t r1;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  return(r1(sc, p) + integer(s1));
}

static s7_int add_if_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  return(integer(s1) + integer(s2));
}

static s7_int add_if_rs(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  return(integer(c1) + integer(s1));
}


static s7_int add_if_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t r1, r2, r3;
  s7_int x, y, z;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  r3 = (s7_if_t)(**p); (*p)++;
  z = r3(sc, p);
  return(x + y + z);
}

static s7_int add_if_rxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_if_t r1, r2;
  s7_int x, y;
  c1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y + integer(c1));
}

static s7_int add_if_sxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t r1, r2;
  s7_int x, y;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x + y + integer(s1));
}

static s7_int add_if_rsx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_if_t r1;
  s7_int x;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x + integer(c1) + integer(s1));
}

static s7_int add_if_ssx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_if_t r1;
  s7_int x;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x + integer(s1) + integer(s2));
}

static s7_int add_if_sss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2, s3;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  s3 = slot_value(**p); (*p)++;
  return(integer(s1) + integer(s2) + integer(s3));
}

static s7_int add_if_rss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1, s2;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  return(integer(c1) + integer(s1) + integer(s2));
}

static s7_if_t add_if_1(s7_scheme *sc, s7_pointer expr, int len)
{
  if (len == 3)
    return(com_if_2(sc, expr, add_i_ops));
  if (len == 4)
    return(com_if_3(sc, expr, add_i_ops));

  if (len > 4)
    {
      s7_if_t xf;
      ptr_int loc;
      int first_len;
      xf_t *rc;

      xf_init(2);
      xf_save_loc(loc);
      first_len = (int)(len / 2);
      xf = add_if_1(sc, expr, first_len + 1);
      if (xf)
	{
	  int i;
	  s7_pointer p;
	  xf_store_at(loc, (s7_pointer)xf);
	  xf_save_loc(loc);
	  for (i = 0, p = expr; i < first_len; i++, p = cdr(p));
	  xf = add_if_1(sc, p, len - first_len);
	  if (xf)
	    {
	      xf_store_at(loc, (s7_pointer)xf);
	      return(add_if_xx);
	    }
	  else return(NULL);
	}
      else return(NULL);
    }
  return(NULL);
}

static s7_if_t add_if(s7_scheme *sc, s7_pointer expr)
{
  return(add_if_1(sc, expr, s7_list_length(sc, expr)));
}


static void init_add_ops(void)
{
  add_r_ops = (rf_ops *)calloc(1, sizeof(rf_ops));
  add_r_ops->r = rf_c;
  add_r_ops->s = rf_s;

  add_r_ops->rs = add_rf_rs;
  add_r_ops->rp = add_rf_rx;
  add_r_ops->sp = add_rf_sx;
  add_r_ops->ss = add_rf_ss;
  add_r_ops->pp = add_rf_xx;

  add_r_ops->rss = add_rf_rss;
  add_r_ops->rsp = add_rf_rsx;
  add_r_ops->rpp = add_rf_rxx;
  add_r_ops->sss = add_rf_sss;
  add_r_ops->ssp = add_rf_ssx;
  add_r_ops->spp = add_rf_sxx;
  add_r_ops->ppp = add_rf_xxx;

  add_i_ops = (if_ops *)calloc(1, sizeof(if_ops));
  add_i_ops->r = if_c;
  add_i_ops->s = if_s;

  add_i_ops->rs = add_if_rs;
  add_i_ops->rp = add_if_rx;
  add_i_ops->sp = add_if_sx;
  add_i_ops->ss = add_if_ss;
  add_i_ops->pp = add_if_xx;

  add_i_ops->rss = add_if_rss;
  add_i_ops->rsp = add_if_rsx;
  add_i_ops->rpp = add_if_rxx;
  add_i_ops->sss = add_if_sss;
  add_i_ops->ssp = add_if_ssx;
  add_i_ops->spp = add_if_sxx;
  add_i_ops->ppp = add_if_xxx;
}

#if WITH_ADD_PF
static s7_pointer c_add_pf2(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf;
  s7_pointer x, y;
  pf = (s7_pf_t)(**p); (*p)++;
  x = pf(sc, p);
  xf_push(sc, x);
  pf = (s7_pf_t)(**p); (*p)++;
  y = pf(sc, p);
  x = g_add_2(sc, set_plist_2(sc, x, y));
  xf_pop(sc);
  return(x);
}

static s7_pf_t add_pf(s7_scheme *sc, s7_pointer expr)
{
  int len;
  len = s7_list_length(sc, expr);
  if (len == 3)
    {
      if ((s7_arg_to_pf(sc, cadr(expr))) &&
	  (s7_arg_to_pf(sc, caddr(expr))))
	return(c_add_pf2);
    }
  return(NULL);
}
#endif

#endif


/* ---------------------------------------- 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 it is given"
  #define Q_subtract pcl_n

  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))
	method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 0);
      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_int32_max) ||
	  (num_a < s7_int32_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:
#if HAVE_OVERFLOW_CHECKS
	  if (subtract_overflow(num_a, integer(x), &den_a))
	    {
	      rl_a = (s7_double)num_a - (s7_double)integer(x);
	      if (is_null(p)) return(make_real(sc, rl_a));
	      goto SUBTRACT_REALS;
	    }
#else
	  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)
	       */
	    }
#endif
	  if (is_null(p)) return(make_integer(sc, den_a));
	  num_a = den_a;
	  goto SUBTRACT_INTEGERS;

	case T_RATIO:
	  {
	    s7_int dn;
	    den_a = denominator(x);
#if HAVE_OVERFLOW_CHECKS
	    if ((multiply_overflow(num_a, den_a, &dn)) ||
		(subtract_overflow(dn, numerator(x), &dn)))
	      {
		if (is_null(p)) return(make_real(sc, num_a - fraction(x)));
		rl_a = (s7_double)num_a - fraction(x);
		goto SUBTRACT_REALS;
	      }
#else
	    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;
	      }
	    dn = (num_a * den_a) - numerator(x);
#endif
	    if (is_null(p)) return(s7_make_ratio(sc, dn, den_a));
	    num_a = dn;
	    if (reduce_fraction(sc, &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:
	  method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    SUBTRACT_RATIOS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (den_a > s7_int32_max) ||
	  (num_a < s7_int32_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 HAVE_OVERFLOW_CHECKS
	  {
	    s7_int di;
	    if ((multiply_overflow(den_a, integer(x), &di)) ||
		(subtract_overflow(num_a, di, &di)))
	      {
		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, di, den_a));
	    num_a = di;
	  }
#else
	  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));
#endif
	  if (reduce_fraction(sc, &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 HAVE_OVERFLOW_CHECKS
		s7_int n1d2, n2d1;
		if ((multiply_overflow(d1, d2, &den_a)) ||
		    (multiply_overflow(n1, d2, &n1d2)) ||
		    (multiply_overflow(n2, d1, &n2d1)) ||
		    (subtract_overflow(n1d2, n2d1, &num_a)))
		  {
		    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;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		      }
		  }
		num_a = n1 * d2 - n2 * d1;
		den_a = d1 * d2;
#endif
#else
		num_a = n1 * d2 - n2 * d1;
		den_a = d1 * d2;
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, num_a, den_a));
	      }
	    if (reduce_fraction(sc, &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:
	  method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->subtract_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    default:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
    }
}


static s7_pointer subtract_1, subtract_s1, subtract_cs1, subtract_2, subtract_csn;
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 (integer(p) == s7_int_min)
#if WITH_GMP
	return(big_negate(sc, set_plist_1(sc, promote_number(sc, T_BIG_INTEGER, p))));
#else
        return(make_integer(sc, s7_int_max));
#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:
      method_or_bust_with_type(sc, p, sc->subtract_symbol, args, a_number_string, 1);
    }
}

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 (is_t_real(x))
	return(make_real(sc, real(x) - real(y)));
      else
	{
	  switch (type(x))
	    {
#if HAVE_OVERFLOW_CHECKS
	    case T_INTEGER:
	      {
		s7_int val;
		if (subtract_overflow(integer(x), integer(y), &val))
		  return(make_real(sc, (double)integer(x) - (double)integer(y)));
		return(make_integer(sc, val));
	      }
#else
	    case T_INTEGER: return(make_integer(sc, integer(x) - integer(y)));
#endif
	    case T_RATIO:   return(g_subtract(sc, args));
	    case T_REAL:    return(make_real(sc, real(x) - real(y)));
	    case T_COMPLEX: return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
	    default:
	      if (!is_number(x))
		method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
	      method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
	    }
	}
    }

  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(make_complex(sc, integer(x) - real_part(y), -imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
	}

    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:
	  method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
	}

    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(make_complex(sc, real(x) - real_part(y), -imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
	}

    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(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y)));
	default:
	  method_or_bust_with_type(sc, y, sc->subtract_symbol, args, a_number_string, 2);
	}

    default:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
    }
  return(x);
}


static s7_pointer g_subtract_cs1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = find_symbol_checked(sc, car(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) - 1));

  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER:
      {
	s7_int val;
	if (subtract_overflow(integer(x), 1, &val))
	  return(make_real(sc, (double)integer(x) - 1.0));
	return(make_integer(sc, val));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) - 1));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, small_int(1)), a_number_string, 1);
    }
  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))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER:
      {
	s7_int val;
	if (subtract_overflow(integer(x), 1, &val))
	  return(make_real(sc, (double)integer(x) - 1.0));
	return(make_integer(sc, val));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) - 1));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_subtract_csn(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_int n;

  x = find_symbol_checked(sc, car(args));
  n = s7_integer(cadr(args));
  if (is_integer(x))
    return(make_integer(sc, integer(x) - n));

  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER:
      {
	s7_int val;
	if (subtract_overflow(integer(x), n, &val))
	  return(make_real(sc, (double)integer(x) - (double)n));
	return(make_integer(sc, val));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) - n));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
    }
  return(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 = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
    }
  return(x);
}

static s7_pointer subtract_2f;
static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_double n;

  x = 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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, args, a_number_string, 1);
    }
  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 = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, car(args), x), a_number_string, 2);
    }
  return(x);
}

static s7_pointer subtract_f_sqr;
static s7_pointer g_subtract_f_sqr(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_double y;

  y = real(car(args));
  x = find_symbol_checked(sc, cadr(cadr(args)));
  if (is_t_real(x))
    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(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:
      /* complicated -- look for * method, if any get (* x x), then go to g_subtract_2 with that and the original y
       *   can't use check_method here because it returns from the caller.
       */
      {
        s7_pointer func;
	if ((func = find_method(sc, find_let(sc, x), sc->multiply_symbol)) != sc->undefined)
	  return(g_subtract_2(sc, set_plist_2(sc, car(args), s7_apply_function(sc, func, list_2(sc, x, x)))));
	return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 1, x, a_number_string));
      }
    }
  return(x);
}

#if (!WITH_GMP)
/* (define (hi) (- (random 100) 50)) (define (ho) (- (random 1.0) 0.5)) */
static s7_pointer sub_random_ic, sub_random_rc;
static s7_pointer g_sub_random_ic(s7_scheme *sc, s7_pointer args)
{
  return(make_integer(sc, ((s7_int)(integer(cadar(args)) * next_random(sc->default_rng))) - integer(cadr(args))));
}

static s7_pointer g_sub_random_rc(s7_scheme *sc, s7_pointer args)
{
  return(make_real(sc, real(cadar(args)) * next_random(sc->default_rng) - real(cadr(args))));
}


static s7_int negate_if_c(s7_scheme *sc, s7_pointer **p) {s7_pointer x; x = (**p); (*p)++; return(-integer(x));}
static s7_int negate_if_s(s7_scheme *sc, s7_pointer **p) {s7_pointer x; x = slot_value(**p); (*p)++; return(-integer(x));}
static s7_int negate_if_p(s7_scheme *sc, s7_pointer **p) {s7_if_t f; f = (s7_if_t)(**p); (*p)++; return(f(sc, p));}

static s7_int sub_if_cc(s7_scheme *sc, s7_pointer **p) {s7_pointer x, y; x = (**p); (*p)++; y = (**p); (*p)++; return(integer(x) - integer(y));}
static s7_int sub_if_cs(s7_scheme *sc, s7_pointer **p) {s7_pointer x, y; x = (**p); (*p)++; y = slot_value(**p); (*p)++; return(integer(x) - integer(y));}
static s7_int sub_if_ss(s7_scheme *sc, s7_pointer **p) {s7_pointer x, y; x = slot_value(**p); (*p)++; y = slot_value(**p); (*p)++; return(integer(x) - integer(y));}
static s7_int sub_if_sc(s7_scheme *sc, s7_pointer **p) {s7_pointer x, y; x = slot_value(**p); (*p)++; y = (**p); (*p)++; return(integer(x) - integer(y));}

static s7_int sub_if_cp(s7_scheme *sc, s7_pointer **p) 
{
  s7_if_t xf;
  s7_pointer x; 
  x = (**p); (*p)++; 
  xf = (s7_if_t)(**p); (*p)++; 
  return(integer(x) - xf(sc, p));
}

static s7_int sub_if_pc(s7_scheme *sc, s7_pointer **p) 
{
  s7_if_t xf; 
  s7_int x; 
  s7_pointer y; 
  xf = (s7_if_t)(**p); (*p)++; x = xf(sc,p); 
  y = (**p); (*p)++; 
  return(x - integer(y));
}

static s7_int sub_if_sp(s7_scheme *sc, s7_pointer **p) 
{
  s7_if_t xf; 
  s7_pointer x; 
  x = slot_value(**p); (*p)++; 
  xf = (s7_if_t)(**p); (*p)++; 
  return(integer(x) - xf(sc, p));
}

static s7_int sub_if_ps(s7_scheme *sc, s7_pointer **p) 
{
  s7_if_t xf; 
  s7_int x; 
  s7_pointer y; 
  xf = (s7_if_t)(**p); (*p)++; x = xf(sc,p); 
  y = slot_value(**p); (*p)++;
  return(x - integer(y));
}

static s7_int sub_if_pp(s7_scheme *sc, s7_pointer **p) 
{
  s7_if_t xf; 
  s7_int x, y;
  xf = (s7_if_t)(**p); (*p)++; x = xf(sc,p); 
  xf = (s7_if_t)(**p); (*p)++; y = xf(sc,p); 
  return(x - y);
}


static s7_if_t subtract_if(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1, a2, slot;
  xf_t *rc;
  if (!is_pair(cdr(expr))) return(NULL);
  
  xf_init(2);
  a1 = cadr(expr);
  if (is_null(cddr(expr)))
    {
      if (is_t_integer(a1))
	{
	  xf_store(a1);
	  return(negate_if_c);
	}
      if (is_symbol(a1))
	{
	  s7_pointer s1;
	  s1 = s7_slot(sc, a1);
	  if ((!is_slot(s1)) || (is_unsafe_stepper(s1)) || (!is_t_integer(slot_value(s1)))) return(NULL);
	  xf_store(s1);
	  return(negate_if_s);
	}
      if ((is_pair(a1)) &&
	  (s7_arg_to_if(sc, a1)))
	return(negate_if_p);
      return(NULL);
    }
  
  a2 = caddr(expr);
  if (is_null(cdddr(expr)))
    {
      if (is_t_integer(a1))
	{
	  xf_store(a1);
	  if (is_t_integer(a2))
	    {
	      xf_store(a2);
	      return(sub_if_cc);
	    }
	  if (is_symbol(a2))
	    {
	      slot = s7_slot(sc, a2);
	      if ((!slot) || (!is_t_integer(slot_value(slot))) || (is_unsafe_stepper(slot))) return(NULL);
	      xf_store(slot);
	      return(sub_if_cs);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_if(sc, a2)))
	    return(sub_if_cp);
	  return(NULL);
	}
      if (is_symbol(a1))
	{
	  slot = s7_slot(sc, a1);
	  if ((!slot) || (!is_t_integer(slot_value(slot))) || (is_unsafe_stepper(slot))) return(NULL);
	  xf_store(slot);
	  if (is_t_integer(a2))
	    {
	      xf_store(a2);
	      return(sub_if_sc);
	    }
	  if (is_symbol(a2))
	    {
	      slot = s7_slot(sc, a2);
	      if ((!slot) || (!is_t_integer(slot_value(slot))) || (is_unsafe_stepper(slot))) return(NULL);
	      xf_store(slot);
	      return(sub_if_ss);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_if(sc, a2)))
	    return(sub_if_sp);
	  return(NULL);
	}
      if (is_pair(a1) &&
	  (s7_arg_to_if(sc, a1)))
	{
	  if (is_t_integer(a2))
	    {
	      xf_store(a2);
	      return(sub_if_pc);
	    }
	  if (is_symbol(a2))
	    {
	      slot = s7_slot(sc, a2);
	      if ((!slot) || (!is_t_integer(slot_value(slot))) || (is_unsafe_stepper(slot))) return(NULL);
	      xf_store(slot);
	      return(sub_if_ps);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_if(sc, a2)))
	    return(sub_if_pp);
	}
      return(NULL);
    }
  
  {
    s7_if_t xf, res;
    ptr_int loc;
    
    if (is_t_integer(a1))
      {
	xf_store(a1);
	res = sub_if_cp;
      }
    else
      {
	if (is_symbol(a1))
	  {
	    slot = s7_slot(sc, a1);
	    if ((!slot) || (!is_t_integer(slot_value(slot))) || (is_unsafe_stepper(slot))) return(NULL);
	    xf_store(slot);
	    res = sub_if_sp;
	  }
	else 
	  {
	    if ((!is_pair(a1)) || (!s7_arg_to_if(sc, a1))) return(NULL);
	    res = sub_if_pp;
	  }
      }
    
    xf_save_loc(loc);
    xf = add_if(sc, cdr(expr));
    if (xf)
      {
	xf_store_at(loc, (s7_pointer)xf);
	return(res);
      }
  }
  return(NULL);
}


static s7_double negate_rf_c(s7_scheme *sc, s7_pointer **p) {s7_pointer x; x = (**p); (*p)++; return(-(real_to_double(sc, x, "-")));}
static s7_double negate_rf_s(s7_scheme *sc, s7_pointer **p) {s7_pointer x; x = slot_value(**p); (*p)++; return(-(real_to_double(sc, x, "-")));}
static s7_double negate_rf_p(s7_scheme *sc, s7_pointer **p) {s7_rf_t f; f = (s7_rf_t)(**p); (*p)++; return(f(sc, p));}

static s7_double sub_rf_cc(s7_scheme *sc, s7_pointer **p) 
{
  s7_pointer x, y; 
  x = (**p); (*p)++; 
  y = (**p); (*p)++; 
  return(real(x) - real_to_double(sc, y, "-"));
}

static s7_double sub_rf_cs(s7_scheme *sc, s7_pointer **p) 
{
  s7_pointer x, y; 
  x = (**p); (*p)++;
  y = slot_value(**p); (*p)++; 
  return(real(x) - real_to_double(sc, y, "-"));
}

static s7_double sub_rf_ss(s7_scheme *sc, s7_pointer **p) 
{
  s7_pointer x, y; 
  s7_double x1;
  x = slot_value(**p); (*p)++; 
  y = slot_value(**p); (*p)++; 
  x1 = real_to_double(sc, x, "-");
  return(x1 - real_to_double(sc, y, "-"));
}

static s7_double sub_rf_sc(s7_scheme *sc, s7_pointer **p) 
{
  s7_pointer x, y; 
  x = slot_value(**p); (*p)++; 
  y = (**p); (*p)++; 
  return(real_to_double(sc, x, "-") - real(y));
}

static s7_double sub_rf_cp(s7_scheme *sc, s7_pointer **p) 
{
  s7_rf_t rf;
  s7_pointer x; 
  x = (**p); (*p)++; 
  rf = (s7_rf_t)(**p); (*p)++; 
  return(real_to_double(sc, x, "-") - rf(sc, p));
}

static s7_double sub_rf_pc(s7_scheme *sc, s7_pointer **p) 
{
  s7_rf_t rf; 
  s7_double x; 
  s7_pointer y; 
  rf = (s7_rf_t)(**p); (*p)++; x = rf(sc,p); 
  y = (**p); (*p)++; 
  return(x - real_to_double(sc, y, "-"));
}

static s7_double sub_rf_sp(s7_scheme *sc, s7_pointer **p) 
{
  s7_rf_t rf; 
  s7_pointer x; 
  x = slot_value(**p); (*p)++; 
  rf = (s7_rf_t)(**p); (*p)++; 
  return(real_to_double(sc, x, "-") - rf(sc, p));
}

static s7_double sub_rf_ps(s7_scheme *sc, s7_pointer **p) 
{
  s7_rf_t rf; 
  s7_double x; 
  s7_pointer y; 
  rf = (s7_rf_t)(**p); (*p)++; x = rf(sc,p); 
  y = slot_value(**p); (*p)++;
  return(x - real_to_double(sc, y, "-"));
}

static s7_double sub_rf_pp(s7_scheme *sc, s7_pointer **p) 
{
  s7_rf_t rf; 
  s7_double x, y;
  rf = (s7_rf_t)(**p); (*p)++; x = rf(sc,p); 
  rf = (s7_rf_t)(**p); (*p)++; y = rf(sc,p); 
  return(x - y);
}

static s7_rf_t subtract_rf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1, a2, slot1, slot2;
  xf_t *rc;
  if (!is_pair(cdr(expr))) return(NULL);
  
  xf_init(2);
  a1 = cadr(expr);
  if (is_null(cddr(expr)))
    {
      if (is_t_real(a1))
	{
	  xf_store(a1);
	  return(negate_rf_c);
	}
      if (is_symbol(a1))
	{
	  slot1 = s7_slot(sc, a1);
	  if ((!is_slot(slot1)) || (is_unsafe_stepper(slot1)) || (!(is_real(slot_value(slot1))))) return(NULL);
	  xf_store(slot1);
	  return(negate_rf_s);
	}
      if ((is_pair(a1)) &&
	  (s7_arg_to_if(sc, a1)))
	return(negate_rf_p);
      return(NULL);
    }
  
  a2 = caddr(expr);
  if (is_null(cdddr(expr)))
    {
      if (is_t_real(a1))
	{
	  xf_store(a1);
	  if (is_real(a2))
	    {
	      xf_store(a2);
	      return(sub_rf_cc);
	    }
	  if (is_symbol(a2))
	    {
	      slot2 = s7_slot(sc, a2);
	      if ((!slot2) || (!is_real(slot_value(slot2))) || (is_unsafe_stepper(slot2))) return(NULL);
	      xf_store(slot2);
	      return(sub_rf_cs);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_if(sc, a2)))
	    return(sub_rf_cp);
	  return(NULL);
	}
      if (is_symbol(a1))
	{
	  slot1 = s7_slot(sc, a1);
	  if ((!slot1) || (!is_real(slot_value(slot1))) || (is_unsafe_stepper(slot1))) return(NULL);
	  xf_store(slot1);
	  if (is_t_real(a2))
	    {
	      xf_store(a2);
	      return(sub_rf_sc);
	    }
	  if (is_symbol(a2))
	    {
	      slot2 = s7_slot(sc, a2);
	      if ((!slot2) || (!is_real(slot_value(slot2))) || (is_unsafe_stepper(slot2))) return(NULL);
	      if ((!is_t_real(slot_value(slot1))) && (!is_t_real(slot_value(slot2)))) return(NULL);
	      xf_store(slot2);
	      return(sub_rf_ss);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_rf(sc, a2)))
	    return(sub_rf_sp);
	  return(NULL);
	}
      if (is_pair(a1) &&
	  (s7_arg_to_rf(sc, a1)))
	{
	  if (is_real(a2))
	    {
	      xf_store(a2);
	      return(sub_rf_pc);
	    }
	  if (is_symbol(a2))
	    {
	      slot2 = s7_slot(sc, a2);
	      if ((!slot2) || (!is_real(slot_value(slot2))) || (is_unsafe_stepper(slot2))) return(NULL);
	      xf_store(slot2);
	      return(sub_rf_ps);
	    }
	  if ((is_pair(a2)) &&
	      (s7_arg_to_rf(sc, a2)))
	    return(sub_rf_pp);
	}
      return(NULL);
    }
  
  {
    s7_rf_t rf, res;
    ptr_int loc;
    
    if (is_real(a1))
      {
	xf_store(a1);
	res = sub_rf_cp;
      }
    else
      {
	if (is_symbol(a1))
	  {
	    slot1 = s7_slot(sc, a1);
	    if ((!slot1) || (!is_t_integer(slot_value(slot1))) || (is_unsafe_stepper(slot1))) return(NULL);
	    xf_store(slot1);
	    res = sub_rf_sp;
	  }
	else 
	  {
	    if ((!is_pair(a1)) || (!s7_arg_to_rf(sc, a1))) return(NULL);
	    res = sub_rf_pp;
	  }
      }
    
    xf_save_loc(loc);
    rf = add_rf(sc, cdr(expr));
    if (rf)
      {
	xf_store_at(loc, (s7_pointer)rf);
	return(res);
      }
  }
  return(NULL);
}

#if WITH_ADD_PF
static s7_pointer c_subtract_pf2(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf;
  s7_pointer x, y;
  pf = (s7_pf_t)(**p); (*p)++;
  x = pf(sc, p);
  xf_push(sc, x);
  pf = (s7_pf_t)(**p); (*p)++;
  y = pf(sc, p);
  x = g_subtract_2(sc, set_plist_2(sc, x, y));
  xf_pop(sc);
  return(x);
}

static s7_pf_t subtract_pf(s7_scheme *sc, s7_pointer expr)
{
  int len;
  len = s7_list_length(sc, expr);
  if (len == 3)
    {
      if ((s7_arg_to_pf(sc, cadr(expr))) &&
	  (s7_arg_to_pf(sc, caddr(expr))))
	return(c_subtract_pf2);
    }
  return(NULL);
}
#endif
#endif


/* ---------------------------------------- multiply ---------------------------------------- */

static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
{
  #define H_multiply "(* ...) multiplies its arguments"
  #define Q_multiply pcl_n

  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))
	method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 0);
      return(x);
    }

  switch (type(x))
    {
    case T_INTEGER:
      num_a = integer(x);

    MULTIPLY_INTEGERS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (num_a < s7_int32_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_int32_max) ||
	      (integer(x) < s7_int32_min))
	    return(big_multiply(sc, cons(sc, s7_int_to_big_integer(sc, num_a), cons(sc, x, p))));
#endif

#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn;
	    if (multiply_overflow(num_a, integer(x), &dn))
	      {
		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;
	      }
	    num_a = dn;
	  }
#else
	  /* 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;
	    }
	  num_a *= integer(x);
#endif
	  if (is_null(p)) return(make_integer(sc, num_a));
	  goto MULTIPLY_INTEGERS;

	case T_RATIO:
#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn;
	    if (multiply_overflow(numerator(x), num_a, &dn))
	      {
		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;
	      }
	    num_a = dn;
	  }
#else
	  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;
	    }
	  num_a *= numerator(x);
#endif
	  den_a = denominator(x);
	  if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a));
	  if (reduce_fraction(sc, &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:
	  method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    MULTIPLY_RATIOS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (den_a > s7_int32_max) ||
	  (num_a < s7_int32_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 HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn;
	    if (multiply_overflow(integer(x), num_a, &dn))
	      {
		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;
	      }
	    num_a = dn;
	  }
#else
	  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;
	    }
	  num_a *= integer(x);
#endif
	  if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a));
	  if (reduce_fraction(sc, &num_a, &den_a) == T_INTEGER)
	    goto MULTIPLY_INTEGERS;
	  goto MULTIPLY_RATIOS;

	case T_RATIO:
	  {
#if (!WITH_GMP)
	    s7_int d1, n1;
#endif
	    s7_int d2, n2;
	    d2 = denominator(x);
	    n2 = numerator(x);
#if (!WITH_GMP)
	    d1 = den_a;
	    n1 = num_a;
#if HAVE_OVERFLOW_CHECKS
	    if ((multiply_overflow(n1, n2, &num_a)) ||
		(multiply_overflow(d1, d2, &den_a)))
	      {
		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;
	      }
#else
	    if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		(n1 > s7_int32_max) || (n2 > s7_int32_max) ||     /*    (* 1/524288 1/19073486328125) for example */
		(n1 < s7_int32_min) || (n2 < s7_int32_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;
		  }
	      }
	    num_a *= n2;
	    den_a *= d2;
#endif
#else
	    num_a *= n2;
	    den_a *= d2;
#endif
	    if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a));
	    if (reduce_fraction(sc, &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:
	  method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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:
	  method_or_bust_with_type(sc, x, sc->multiply_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    default:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
    }
}

#if (!WITH_GMP)
static s7_pointer multiply_2, multiply_fs, multiply_sf, multiply_is, multiply_si;

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 (is_t_real(x))
	return(make_real(sc, real(x) * real(y)));
      else
	{
	  switch (type(x))
	    {
#if HAVE_OVERFLOW_CHECKS
	    case T_INTEGER:
	      {
		s7_int n;
		if (multiply_overflow(integer(x), integer(y), &n))
		  return(make_real(sc, ((s7_double)integer(x)) * ((s7_double)integer(y))));
		return(make_integer(sc, n));
	      }
#else
	    case T_INTEGER: return(make_integer(sc, integer(x) * integer(y)));
#endif
	    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))
		method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
	      method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
	    }
	}
    }

  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:
	  method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
	}

    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:
	  method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
	}

    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:
	  method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
	}

    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:
	  method_or_bust_with_type(sc, y, sc->multiply_symbol, args, a_number_string, 2);
	}

    default:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, args, a_number_string, 1);
    }
  return(x);
}

/* all of these mess up if overflows occur
 *  (let () (define (f x) (* x 9223372036854775806)) (f -63)) -> -9223372036854775682, but (* -63 9223372036854775806) -> -5.810724383218509e+20
 *  how to catch this?  (affects * - +)
 */

static s7_pointer g_multiply_si(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_int n;

  x = find_symbol_checked(sc, car(args));
  n = integer(cadr(args));

  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER: 
      {
	s7_int val;
	if (multiply_overflow(integer(x), n, &val))
	  return(make_real(sc, (double)integer(x) * (double)n));
	return(make_integer(sc, val));
      }
    case T_RATIO:
      {
	s7_int val;
	if (multiply_overflow(numerator(x), n, &val))
	  return(make_real(sc, fraction(x) * (double)n));
	return(s7_make_ratio(sc, val, denominator(x)));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) * n));
    case T_RATIO:   return(s7_make_ratio(sc, numerator(x) * n, denominator(x)));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, cadr(args)), a_number_string, 1);
    }
  return(x);
}

static s7_pointer g_multiply_is(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  s7_int n;

  x = find_symbol_checked(sc, cadr(args));
  n = integer(car(args));

  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER: 
      {
	s7_int val;
	if (multiply_overflow(integer(x), n, &val))
	  return(make_real(sc, (double)integer(x) * (double)n));
	return(make_integer(sc, val));
      }
    case T_RATIO:
      {
	s7_int val;
	if (multiply_overflow(numerator(x), n, &val))
	  return(make_real(sc, fraction(x) * (double)n));
	return(s7_make_ratio(sc, val, denominator(x)));
      }
#else
    case T_INTEGER: return(make_integer(sc, integer(x) * n));
    case T_RATIO:   return(s7_make_ratio(sc, numerator(x) * n, denominator(x)));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, car(args), x), a_number_string, 2);
    }
  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 = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, car(args), x), a_number_string, 1);
    }
  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 = find_symbol_checked(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:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, cadr(args)), a_number_string, 2);
    }
  return(x);
}

static s7_pointer sqr_ss;
static s7_pointer g_sqr_ss(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x;
  x = find_symbol_checked(sc, car(args));

  switch (type(x))
    {
#if HAVE_OVERFLOW_CHECKS
    case T_INTEGER: 
      {
	s7_int val;
	if (multiply_overflow(integer(x), integer(x), &val))
	  return(make_real(sc, (double)integer(x) * (double)integer(x)));
	return(make_integer(sc, val));
      }
    case T_RATIO:
      {
	s7_int num, den;
	if ((multiply_overflow(numerator(x), numerator(x), &num)) ||
	    (multiply_overflow(denominator(x), denominator(x), &den)))
	  return(make_real(sc, fraction(x) * fraction(x)));
	return(s7_make_ratio(sc, num, den));
      }
#else
    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)));
#endif
    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:
      method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, x), a_number_string, 1);
    }
  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 = find_symbol_checked(sc, caddr(car(args)));
  y = find_symbol_checked(sc, cadr(args));

  if ((is_t_real(x)) &&
      (is_t_real(y)))
    return(make_real(sc, real(y) * (1.0 - real(x))));

  if ((is_real(x)) &&
      (is_real(y)))
    {
      s7_double x1;
      x1 = real_to_double(sc, y, "*");
      return(make_real(sc, x1 * (1.0 - real_to_double(sc, x, "*"))));
    }
  else
    {
      s7_double r1, r2, i1, i2;
      if (!is_number(x))
	{
	  s7_pointer func;
	  if ((func = find_method(sc, find_let(sc, x), sc->subtract_symbol)) != sc->undefined)
	    return(g_multiply_2(sc, set_plist_2(sc, s7_apply_function(sc, func, list_2(sc, real_one, x)), y)));
	  return(wrong_type_argument_with_type(sc, sc->subtract_symbol, 2, x, a_number_string));
	}
      if (!is_number(y))
	{
	  s7_pointer func;
	  if ((func = find_method(sc, find_let(sc, y), sc->multiply_symbol)) != sc->undefined)
	    return(s7_apply_function(sc, func, list_2(sc, g_subtract(sc, list_2(sc, real_one, x)), y)));
	  return(wrong_type_argument_with_type(sc, sc->multiply_symbol, 2, y, a_number_string));
	}

      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 = find_symbol_checked(sc, cadr(args));
  x = find_symbol_checked(sc, cadr(caddr(args)));

  if ((is_t_real(r)) &&
      (is_t_real(x)))
    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)) * real_to_double(sc, r, "*") * cos(real_to_double(sc, x, "*"))));
  return(g_multiply(sc, set_plist_3(sc, car(args), r, g_cos(sc, set_plist_1(sc, x)))));
}

static s7_pointer mul_s_sin_s, mul_s_cos_s;
static s7_pointer g_mul_s_sin_s(s7_scheme *sc, s7_pointer args)
{
  /* (* s (sin s)) */
  s7_pointer x, y;

  x = find_symbol_checked(sc, car(args));
  y = find_symbol_checked(sc, cadadr(args));

  if ((is_real(x)) && (is_real(y)))
    return(make_real(sc, real_to_double(sc, x, "*") * sin(real_to_double(sc, y, "sin"))));

  return(g_multiply(sc, set_plist_2(sc, x, g_sin(sc, set_plist_1(sc, y)))));
}

static s7_pointer g_mul_s_cos_s(s7_scheme *sc, s7_pointer args)
{
  /* (* s (cos s)) */
  s7_pointer x, y;

  x = find_symbol_checked(sc, car(args));
  y = find_symbol_checked(sc, cadadr(args));

  if ((is_real(x)) && (is_real(y)))
    return(make_real(sc, real_to_double(sc, x, "*") * cos(real_to_double(sc, y, "cos"))));

  return(g_multiply(sc, set_plist_2(sc, x, g_cos(sc, set_plist_1(sc, y)))));
}


static s7_double multiply_rf_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t r1, r2;
  s7_double x, y;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y);
}

static s7_double multiply_rf_rx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_rf_t r1;
  s7_double x;
  c1 = **p; (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * real_to_double(sc, c1, "*"));
}

static s7_double multiply_rf_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_rf_t r1;
  s7_double x;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * real_to_double(sc, s1, "*"));
}

static s7_double multiply_rf_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_double x1;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "*");
  s2 = slot_value(**p); (*p)++;
  return(x1 * real_to_double(sc, s2, "*"));
}

static s7_double multiply_rf_rs(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_double x1;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  x1 = real_to_double(sc, c1, "*");
  return(x1 * real_to_double(sc, s1, "*"));
}


static s7_double multiply_rf_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t r1, r2, r3;
  s7_double x, y, z;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  r3 = (s7_rf_t)(**p); (*p)++;
  z = r3(sc, p);
  return(x * y * z);
}

static s7_double multiply_rf_rxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_rf_t r1, r2;
  s7_double x, y;
  c1 = **p; (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y * real_to_double(sc, c1, "*"));
}

static s7_double multiply_rf_sxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_rf_t r1, r2;
  s7_double x, y;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_rf_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y * real_to_double(sc, s1, "*"));
}

static s7_double multiply_rf_rsx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_rf_t r1;
  s7_double x, x1;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  x1 = real_to_double(sc, c1, "*");
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * x1 * real_to_double(sc, s1, "*"));
}

static s7_double multiply_rf_ssx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_rf_t r1;
  s7_double x, x1;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "*");
  s2 = slot_value(**p); (*p)++;
  r1 = (s7_rf_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * x1 * real_to_double(sc, s2, "*"));
}

static s7_double multiply_rf_sss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2, s3;
  s7_double x1, x2, x3;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "*");
  s2 = slot_value(**p); (*p)++;
  x2 = real_to_double(sc, s2, "*");
  s3 = slot_value(**p); (*p)++;
  x3 = real_to_double(sc, s3, "*");
  return(x1 * x2 * x3);
}

static s7_double multiply_rf_rss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1, s2;
  s7_double x1, x2, x3;
  s1 = slot_value(**p); (*p)++;
  x1 = real_to_double(sc, s1, "*");
  s2 = slot_value(**p); (*p)++;
  x2 = real_to_double(sc, s2, "*");
  c1 = **p; (*p)++;
  x3 = real_to_double(sc, c1, "*");
  return(x1 * x2 * x3);
}

static s7_rf_t multiply_rf_1(s7_scheme *sc, s7_pointer expr, int len)
{
  if (len == 3)
    return(com_rf_2(sc, expr, multiply_r_ops));
  if (len == 4)
    return(com_rf_3(sc, expr, multiply_r_ops));

  if (len > 4)
    {
      s7_rf_t rf;
      ptr_int loc;
      xf_t *rc;
      int first_len;

      xf_init(2);
      first_len = (int)(len / 2);
      xf_save_loc(loc);
      rf = multiply_rf_1(sc, expr, first_len + 1);
      if (rf)
	{
	  int i;
	  s7_pointer p;
	  xf_store_at(loc, (s7_pointer)rf);
	  xf_save_loc(loc);
	  for (i = 0, p = expr; i < first_len; i++, p = cdr(p));
	  rf = multiply_rf_1(sc, p, len - first_len);
	  if (rf)
	    {
	      xf_store_at(loc, (s7_pointer)rf);
	      return(multiply_rf_xx);
	    }
	  else return(NULL);
	}
      else return(NULL);
    }
  return(NULL);
}

static s7_rf_t multiply_rf(s7_scheme *sc, s7_pointer expr)
{
  return(multiply_rf_1(sc, expr, s7_list_length(sc, expr)));
}


static s7_int multiply_if_xx(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t r1, r2;
  s7_int x, y;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y);
}

static s7_int multiply_if_rx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_if_t r1;
  s7_int x;
  c1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * integer(c1));
}

static s7_int multiply_if_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t r1;
  s7_int x;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * integer(s1));
}

static s7_int multiply_if_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  return(integer(s1) * integer(s2));
}

static s7_int multiply_if_rs(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  return(integer(c1) * integer(s1));
}


static s7_int multiply_if_xxx(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t r1, r2, r3;
  s7_int x, y, z;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  r3 = (s7_if_t)(**p); (*p)++;
  z = r3(sc, p);
  return(x * y * z);
}

static s7_int multiply_if_rxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1;
  s7_if_t r1, r2;
  s7_int x, y;
  c1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y * integer(c1));
}

static s7_int multiply_if_sxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t r1, r2;
  s7_int x, y;
  s1 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  r2 = (s7_if_t)(**p); (*p)++;
  y = r2(sc, p);
  return(x * y * integer(s1));
}

static s7_int multiply_if_rsx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1;
  s7_if_t r1;
  s7_int x;
  s1 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * integer(c1) * integer(s1));
}

static s7_int multiply_if_ssx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_if_t r1;
  s7_int x;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  r1 = (s7_if_t)(**p); (*p)++;
  x = r1(sc, p);
  return(x * integer(s1) * integer(s2));
}

static s7_int multiply_if_sss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2, s3;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  s3 = slot_value(**p); (*p)++;
  return(integer(s1) * integer(s2) * integer(s3));
}

static s7_int multiply_if_rss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer c1, s1, s2;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  c1 = **p; (*p)++;
  return(integer(c1) * integer(s1) * integer(s2));
}


static s7_if_t multiply_if_1(s7_scheme *sc, s7_pointer expr, int len)
{
  if (len == 3)
    return(com_if_2(sc, expr, multiply_i_ops));
  if (len == 4)
    return(com_if_3(sc, expr, multiply_i_ops));

  if (len > 4)
    {
      s7_if_t xf;
      xf_t *rc;
      ptr_int loc;
      int first_len;

      xf_init(2);
      first_len = (int)(len / 2);
      xf_save_loc(loc);
      xf = multiply_if_1(sc, expr, first_len + 1);
      if (xf)
	{
	  int i;
	  s7_pointer p;
	  xf_store_at(loc, (s7_pointer)xf);
	  xf_save_loc(loc);
	  for (i = 0, p = expr; i < first_len; i++, p = cdr(p));
	  xf = multiply_if_1(sc, p, len - first_len);
	  if (xf)
	    {
	      xf_store_at(loc, (s7_pointer)xf);
	      return(multiply_if_xx);
	    }
	  else return(NULL);
	}
      else return(NULL);
    }
  return(NULL);
}

static s7_if_t multiply_if(s7_scheme *sc, s7_pointer expr)
{
  return(multiply_if_1(sc, expr, s7_list_length(sc, expr)));
}


static void init_multiply_ops(void)
{
  multiply_r_ops = (rf_ops *)calloc(1, sizeof(rf_ops));
  multiply_r_ops->r = rf_c;
  multiply_r_ops->s = rf_s;

  multiply_r_ops->rs = multiply_rf_rs;
  multiply_r_ops->rp = multiply_rf_rx;
  multiply_r_ops->sp = multiply_rf_sx;
  multiply_r_ops->ss = multiply_rf_ss;
  multiply_r_ops->pp = multiply_rf_xx;

  multiply_r_ops->rss = multiply_rf_rss;
  multiply_r_ops->rsp = multiply_rf_rsx;
  multiply_r_ops->rpp = multiply_rf_rxx;
  multiply_r_ops->sss = multiply_rf_sss;
  multiply_r_ops->ssp = multiply_rf_ssx;
  multiply_r_ops->spp = multiply_rf_sxx;
  multiply_r_ops->ppp = multiply_rf_xxx;

  multiply_i_ops = (if_ops *)calloc(1, sizeof(if_ops));
  multiply_i_ops->r = if_c;
  multiply_i_ops->s = if_s;

  multiply_i_ops->rs = multiply_if_rs;
  multiply_i_ops->rp = multiply_if_rx;
  multiply_i_ops->sp = multiply_if_sx;
  multiply_i_ops->ss = multiply_if_ss;
  multiply_i_ops->pp = multiply_if_xx;

  multiply_i_ops->rss = multiply_if_rss;
  multiply_i_ops->rsp = multiply_if_rsx;
  multiply_i_ops->rpp = multiply_if_rxx;
  multiply_i_ops->sss = multiply_if_sss;
  multiply_i_ops->ssp = multiply_if_ssx;
  multiply_i_ops->spp = multiply_if_sxx;
  multiply_i_ops->ppp = multiply_if_xxx;
}

#if WITH_ADD_PF
static s7_pointer c_mul_pf2(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf;
  s7_pointer x, y;
  pf = (s7_pf_t)(**p); (*p)++;
  x = pf(sc, p);
  xf_push(sc, x);
  pf = (s7_pf_t)(**p); (*p)++;
  y = pf(sc, p);
  x = g_multiply_2(sc, set_plist_2(sc, x, y));
  xf_pop(sc);
  return(x);
}

static s7_pf_t multiply_pf(s7_scheme *sc, s7_pointer expr)
{
  int len;
  len = s7_list_length(sc, expr);
  if (len == 3)
    {
      if ((s7_arg_to_pf(sc, cadr(expr))) &&
	  (s7_arg_to_pf(sc, caddr(expr))))
	return(c_mul_pf2);
    }
  return(NULL);
}
#endif

#endif /* with-gmp */



/* ---------------------------------------- divide ---------------------------------------- */

static bool is_number_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_number(p))
    return(true);
  if (has_methods(p))
    {
      s7_pointer f;
      f = find_method(sc, find_let(sc, p), sc->is_number_symbol);
      if (f != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
    }
  return(false);
}

static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
{
  #define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument"
  #define Q_divide pcl_n

  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))
	method_or_bust_with_type(sc, x, sc->divide_symbol, args, a_number_string, 0);
      if (s7_is_zero(x))
	return(division_by_zero_error(sc, sc->divide_symbol, 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))
	    {
	      s7_pointer n;
	      n = car(p);
	      if (!s7_is_number(n))
		{
		  n = check_values(sc, n, p);
		  if (!s7_is_number(n))
		    return(wrong_type_argument_with_type(sc, sc->divide_symbol, position_of(p, args), n, a_number_string));
		}
	      if (s7_is_zero(n))
		return(division_by_zero_error(sc, sc->divide_symbol, args));
	      if (type(n) > T_RATIO)
		{
		  return_real_zero = true;
		  if (is_NaN(s7_real_part(n)))
		    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_int32_max) ||
	  (num_a < s7_int32_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_symbol, 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(sc, &num_a, &den_a) == T_INTEGER)
	    goto DIVIDE_INTEGERS;
	  goto DIVIDE_RATIOS;

	case T_RATIO:
	  den_a = denominator(x);
#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn;
	    if (multiply_overflow(num_a, den_a, &dn))
	      {
		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;
	      }
	    num_a = dn;
	  }
#else
	  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;
	    }
	  num_a *= den_a;
#endif
	  den_a = numerator(x);
	  if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a));
	  if (reduce_fraction(sc, &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_symbol, 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:
	  method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    case T_RATIO:
      num_a = numerator(x);
      den_a = denominator(x);
    DIVIDE_RATIOS:
#if WITH_GMP
      if ((num_a > s7_int32_max) ||
	  (den_a > s7_int32_max) ||
	  (num_a < s7_int32_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_symbol, args));
#if HAVE_OVERFLOW_CHECKS
	  {
	    s7_int dn;
	    if (multiply_overflow(den_a, integer(x), &dn))
	      {
		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;
	      }
	    den_a = dn;
	  }
#else
	  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;
	    }
	  den_a *= integer(x);
#endif
	  if (is_null(p)) return(s7_make_ratio(sc, num_a, den_a));
	  if (reduce_fraction(sc, &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 HAVE_OVERFLOW_CHECKS
		if ((multiply_overflow(n1, d2, &n1)) ||
		    (multiply_overflow(n2, d1, &d1)))
		  {
		    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;
		  }
		num_a = n1;
		den_a = d1;
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		      }
		  }
		num_a *= d2;
		den_a *= n2;
#endif
#else
		num_a *= d2;
		den_a *= n2;
#endif
		if (is_null(p))
		  return(s7_make_ratio(sc, num_a, den_a));
	      }
	    if (reduce_fraction(sc, &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_symbol, 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:
	  method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    case T_REAL:
      rl_a = real(x);
      if (rl_a == 0)
	{
	  bool return_nan = false;
	  for (; is_pair(p); p = cdr(p))
	    {
	      s7_pointer n;
	      n = car(p);
	      if (!s7_is_number(n))
		{
		  n = check_values(sc, n, p);
		  if (!s7_is_number(n))
		    return(wrong_type_argument_with_type(sc, sc->divide_symbol, position_of(p, args), n, a_number_string));
		}
	      if (s7_is_zero(n))
		return(division_by_zero_error(sc, sc->divide_symbol, args));
	      if ((is_t_real(n)) &&
		  (is_NaN(real(n))))
		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_symbol, 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_symbol, 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:
	  method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      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_symbol, 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_symbol, 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:
	  method_or_bust_with_type(sc, x, sc->divide_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	}
      break;

    default:
      method_or_bust_with_type(sc, x, sc->divide_symbol, args, a_number_string, 1);
    }
}


#if (!WITH_GMP)
static s7_pointer invert_1;

static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) != 0)
	return(s7_make_ratio(sc, 1, integer(p)));      /* a already checked, not 0 */
      return(division_by_zero_error(sc, sc->divide_symbol, args));

    case T_RATIO:
      return(s7_make_ratio(sc, denominator(p), numerator(p)));

    case T_REAL:
      if (real(p) != 0.0)
	return(make_real(sc, 1.0 / real(p)));
      return(division_by_zero_error(sc, sc->divide_symbol, args));

    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:
      method_or_bust_with_type(sc, p, sc->divide_symbol, args, a_number_string, 1);
    }
}


static s7_pointer divide_1r;
static s7_pointer g_divide_1r(s7_scheme *sc, s7_pointer args)
{
  if (s7_is_real(cadr(args)))
    {
      s7_double rl;
      rl = real_to_double(sc, cadr(args), "/");
      if (rl == 0.0)
	return(division_by_zero_error(sc, sc->divide_symbol, args));
      return(make_real(sc, 1.0 / rl));
    }
  return(g_divide(sc, args));
}


static s7_double c_dbl_invert(s7_scheme *sc, s7_double x)
{
  if (x == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_1(sc, real_zero));
  return(1.0 / x);
}

static s7_double c_dbl_divide_2(s7_scheme *sc, s7_double x, s7_double y)
{
  if (y == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, make_real(sc, x), real_zero));
  return(x / y);
}

static s7_double c_dbl_divide_3(s7_scheme *sc, s7_double x, s7_double y, s7_double z)
{
  s7_double d;
  d = y * z;
  if (d == 0.0) division_by_zero_error(sc, sc->divide_symbol, set_elist_3(sc, make_real(sc, x), make_real(sc, y), make_real(sc, z)));
  return(x / d);
}

RF_3_TO_RF(divide, c_dbl_invert, c_dbl_divide_2, c_dbl_divide_3)
#endif


/* ---------------------------------------- max/min ---------------------------------------- */

static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p)
{
  s7_pointer f;
  f = find_method(sc, find_let(sc, p), sc->is_real_symbol);
  if (f != sc->undefined)
    return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
  return(false);
}

#define is_real_via_method(sc, p) ((s7_is_real(p)) || ((has_methods(p)) && (is_real_via_method_1(sc, p))))


static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
{
  #define H_max "(max ...) returns the maximum of its arguments"
  #define Q_max pcl_r

  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);
      /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(x), DISPLAY(y)); */

      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_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }
	  if (integer(x) < real(y))
	    {
	      x = y;
	      goto MAX_REALS;
	    }
	  goto MAX_INTEGERS;

	default:
	  method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    case T_RATIO:
    MAX_RATIOS:
      if (is_null(p)) return(x);
      y = car(p);
      p = cdr(p);
      /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(x), DISPLAY(y)); */

      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 ((num_a < 0) && (num_b >= 0)) /* x < 0, y >= 0 -> y */
	    x = y;
	  else
	    {
	      if ((num_a < 0) || (num_b >= 0))
		{
		  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;
			  /* fprintf(stderr, "val: %lld %lld %d %d\n", vala, valb, -1/2, 0); */
			  
			  if (!((vala > valb) ||
				((vala == valb) && (is_t_integer(y)))))
			    {
			      if ((valb > vala) ||
				  ((vala == valb) && (is_t_integer(x))) ||
				  /* 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 (is_t_ratio(x))
	    goto MAX_RATIOS;
	  goto MAX_INTEGERS;

	case T_REAL:
	  /* (max 3/4 nan.0) should probably return NaN */
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }

	  if (fraction(x) < real(y))
	    {
	      x = y;
	      goto MAX_REALS;
	    }
	  goto MAX_RATIOS;

	default:
	  method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    case T_REAL:
      if (is_NaN(real(x)))
	{
	  for (; is_not_null(p); p = cdr(p))
	    if (!is_real_via_method(sc, car(p)))
	      return(wrong_type_argument(sc, sc->max_symbol, 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_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->max_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }
	  if (real(x) < real(y)) x = y;
	  goto MAX_REALS;

	default:
	  method_or_bust(sc, y, sc->max_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->max_symbol, cons(sc, x, p), T_REAL, 1);
    }
}

#if (!WITH_GMP)
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_t_real(y))
    return((real(x) >= real(y)) ? x : y);
  if (is_real(y))
    return((real(x) >= real_to_double(sc, y, "max")) ? x : y);
  method_or_bust(sc, y, sc->max_symbol, args, T_REAL, 2);
}
#endif

static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
{
  #define H_min "(min ...) returns the minimum of its arguments"
  #define Q_min pcl_r

  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_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }
	  if (integer(x) > real(y))
	    {
	      x = y;
	      goto MIN_REALS;
	    }
	  goto MIN_INTEGERS;

	default:
	  method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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 ((num_a >= 0) && (num_b < 0))
	    x = y;
	  else
	    {
	      if ((num_a >= 0) || (num_b < 0))
		{
		  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) && (is_t_integer(x)))))
			    {
			      if ((valb < vala) ||
				  ((vala == valb) && (is_t_integer(y))) ||
				  (((long double)(num_a % den_a) / (long double)den_a) >= ((long double)(num_b % den_b) / (long double)den_b)))
				x = y;
			    }
			}
		    }
		}
	    }
	  if (is_t_ratio(x))
	    goto MIN_RATIOS;
	  goto MIN_INTEGERS;

	case T_REAL:
	  /* (min 3/4 nan.0) should probably return NaN */
	  if (is_NaN(real(y)))
	    {
	      for (; is_not_null(p); p = cdr(p))
		if (!is_real_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }
	  if (fraction(x) > real(y))
	    {
	      x = y;
	      goto MIN_REALS;
	    }
	  goto MIN_RATIOS;

	default:
	  method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    case T_REAL:
      if (is_NaN(real(x)))
	{
	  for (; is_not_null(p); p = cdr(p))
	    if (!is_real_via_method(sc, car(p)))
	      return(wrong_type_argument(sc, sc->min_symbol, 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_via_method(sc, car(p)))
		  return(wrong_type_argument(sc, sc->min_symbol, position_of(p, args), car(p), T_REAL));
	      return(y);
	    }
	  if (real(x) > real(y)) x = y;
	  goto MIN_REALS;

	default:
	  method_or_bust(sc, y, sc->min_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->min_symbol, cons(sc, x, p), T_REAL, 1);
    }
}

#if (!WITH_GMP)
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_t_real(y))
    return((real(x) <= real(y)) ? x : y);
  if (is_real(y))
    return((real(x) <= real_to_double(sc, y, "min")) ? x : y);
  method_or_bust(sc, y, sc->min_symbol, args, T_REAL, 2);
}

static s7_int c_max_i1(s7_scheme *sc, s7_int x) {return(x);}
static s7_int c_max_i2(s7_scheme *sc, s7_int x, s7_int y) {return((x >= y) ? x : y);}
static s7_int c_max_i3(s7_scheme *sc, s7_int x, s7_int y, s7_int z) {return(((x >= y) ? ((x >= z) ? x : z) : ((y >= z) ? y : z)));}
IF_3_TO_IF(max, c_max_i1, c_max_i2, c_max_i3)

static s7_int c_min_i1(s7_scheme *sc, s7_int x) {return(x);}
static s7_int c_min_i2(s7_scheme *sc, s7_int x, s7_int y) {return((x <= y) ? x : y);}
static s7_int c_min_i3(s7_scheme *sc, s7_int x, s7_int y, s7_int z) {return(((x <= y) ? ((x <= z) ? x : z) : ((y <= z) ? y : z)));}
IF_3_TO_IF(min, c_min_i1, c_min_i2, c_min_i3)

static s7_double c_max_r1(s7_scheme *sc, s7_double x) {return(x);}
static s7_double c_max_r2(s7_scheme *sc, s7_double x, s7_double y) {return((x >= y) ? x : y);}
static s7_double c_max_r3(s7_scheme *sc, s7_double x, s7_double y, s7_double z) {return(((x >= y) ? ((x >= z) ? x : z) : ((y >= z) ? y : z)));}
RF_3_TO_RF(max, c_max_r1, c_max_r2, c_max_r3)

static s7_double c_min_r1(s7_scheme *sc, s7_double x) {return(x);}
static s7_double c_min_r2(s7_scheme *sc, s7_double x, s7_double y) {return((x <= y) ? x : y);}
static s7_double c_min_r3(s7_scheme *sc, s7_double x, s7_double y, s7_double z) {return(((x <= y) ? ((x <= z) ? x : z) : ((y <= z) ? y : z)));}
RF_3_TO_RF(min, c_min_r1, c_min_r2, c_min_r3)
#endif



/* ---------------------------------------- = > < >= <= ---------------------------------------- */

static s7_pointer g_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_equal "(= z1 ...) returns #t if all its arguments are equal"
  #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)
  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;

	    case T_REAL:
	      if (num_a != real(x)) goto NOT_EQUAL;
	      break;

	    default:
	      method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, make_integer(sc, num_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	    }
	  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;

	    case T_RATIO:
	      if ((num_a != numerator(x)) || (den_a != denominator(x)))	goto NOT_EQUAL; /* hidden cast here */
	      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:
	      method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, s7_make_ratio(sc, num_a, den_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	    }
	  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 != (double)fraction(x)) goto NOT_EQUAL;
	      /* the cast to double is needed because rl_a is s7_double and we want (= ratio real) to be the same as (= real ratio):
	       *   (= 1.0 9223372036854775807/9223372036854775806)
	       *   (= 9223372036854775807/9223372036854775806 1.0)
	       */
	      break;

	    case T_REAL:
	      if (rl_a != real(x)) goto NOT_EQUAL;
	      break;

	    case T_COMPLEX:
	      goto NOT_EQUAL;

	    default:
	      method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, make_real(sc, rl_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	    }
	  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:
	      method_or_bust_with_type(sc, x, sc->eq_symbol, cons(sc, s7_make_complex(sc, rl_a, im_a), cons(sc, x, p)), a_number_string, position_of(p, args) - 1);
	    }
	  if (is_null(p))
	    return(sc->T);
	}

    default:
      method_or_bust_with_type(sc, x, sc->eq_symbol, args, a_number_string, 1);
    }

 NOT_EQUAL:
  for (; is_pair(p); p = cdr(p))
    if (!is_number_via_method(sc, car(p)))
      return(wrong_type_argument_with_type(sc, sc->eq_symbol, position_of(p, args), car(p), a_number_string));

  return(sc->F);
}


static s7_pointer equal_s_ic, equal_2;
static s7_pointer g_equal_s_ic(s7_scheme *sc, s7_pointer args)
{
  s7_int y;
  s7_pointer val;

  val = find_symbol_checked(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));
    case T_RATIO:   return(sc->F);
    case T_REAL:    return(make_boolean(sc, real(val) == y));
    case T_COMPLEX: return(sc->F);
    default:
      method_or_bust_with_type(sc, val, sc->eq_symbol, list_2(sc, val, cadr(args)), a_number_string, 1);
    }
  return(sc->T);
}

static s7_int object_length_to_int(s7_scheme *sc, s7_pointer obj);
#if (!WITH_GMP)
static s7_pointer equal_length_ic;
static s7_pointer g_equal_length_ic(s7_scheme *sc, s7_pointer args)
{
  /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */
  s7_int ilen;
  s7_pointer val;

  val = find_symbol_checked(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_STRING:       return(make_boolean(sc, string_length(val) == ilen));
    case T_HASH_TABLE:   return(make_boolean(sc, (hash_table_mask(val) + 1) == ilen));
    case T_ITERATOR:     return(make_boolean(sc, iterator_length(val) == ilen));
    case T_C_OBJECT:     return(make_boolean(sc, object_length_to_int(sc, val) == ilen));
    case T_LET:          return(make_boolean(sc, let_length(sc, val) == ilen));
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:       return(make_boolean(sc, vector_length(val) == ilen));
    case T_CLOSURE:
    case T_CLOSURE_STAR: if (has_methods(val)) return(make_boolean(sc, closure_length(sc, val) == ilen));
    default:             return(simple_wrong_type_argument_with_type(sc, sc->length_symbol, val, a_sequence_string));
      /* here we already lost because we checked for the length above */
    }
  return(sc->F);
}
#endif


static s7_pointer c_equal_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  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:
	  method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
	}
      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:
	  method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
	}
      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:
	  method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
	}
      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:
	  method_or_bust_with_type(sc, y, sc->eq_symbol, list_2(sc, x, y), a_number_string, 2);
	}
      break;

    default:
      method_or_bust_with_type(sc, x, sc->eq_symbol, list_2(sc, x, y), a_number_string, 1);
    }
  return(sc->F);
}


static s7_pointer c_equal_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#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
  return(c_equal_2_1(sc, x, y));
}


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
  return(c_equal_2_1(sc, x, y));
}

#if (!WITH_GMP)
static s7_pointer equal_i2(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t f;
  s7_int x, y;
  f = (s7_if_t)(**p); (*p)++;	x = f(sc, p);
  f = (s7_if_t)(**p); (*p)++;	y = f(sc, p);
  return(make_boolean(sc, x == y));
}

static s7_pointer equal_i2_ic(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x, y;
  (*p)++;
  x = slot_value(**p); (*p) += 2;
  y = (**p); (*p)++;
  if (!is_integer(x)) 
    return(c_equal_2_1(sc, x, y));
  return(make_boolean(sc, integer(x) == integer(y)));
}

static s7_pointer equal_i2_ii(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x, y;
  (*p)++;
  x = slot_value(**p); (*p) += 2;
  y = slot_value(**p); (*p)++;
  if (!is_integer(x)) 
    return(c_equal_2_1(sc, x, y));
  return(make_boolean(sc, integer(x) == integer(y)));
}

static s7_pointer equal_r2(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t f;
  s7_double x, y;
  f = (s7_rf_t)(**p); (*p)++;	x = f(sc, p);
  f = (s7_rf_t)(**p); (*p)++;	y = f(sc, p);
  return(make_boolean(sc, x == y));
}

static s7_pointer equal_p2(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x, y;
  f = (s7_pf_t)(**p); (*p)++;	x = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;	y = f(sc, p);
  return(c_equal_2(sc, x, y));
}

static s7_pf_t equal_pf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      ptr_int loc;
      s7_pointer a1, a2;
      a1 = cadr(expr);
      a2 = caddr(expr);
      loc = rc_loc(sc);
      if ((s7_arg_to_if(sc, cadr(expr))) && (s7_arg_to_if(sc, caddr(expr))))
	{
	  if (is_symbol(a1))
	    {
	      if (is_integer(a2)) return(equal_i2_ic);
	      if (is_symbol(a2)) return(equal_i2_ii);
	    }
	  return(equal_i2);
	}
      sc->cur_rf->cur = rc_go(sc, loc);
      if ((s7_arg_to_rf(sc, cadr(expr))) && (s7_arg_to_rf(sc, caddr(expr)))) return(equal_r2);
      sc->cur_rf->cur = rc_go(sc, loc);	
      if ((s7_arg_to_pf(sc, cadr(expr))) && (s7_arg_to_pf(sc, caddr(expr)))) return(equal_p2);
    }
  return(NULL);
}


static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
{
  #define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
  #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  s7_pointer x, 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_int32_max) &&
	      (integer(x) > s7_int32_min) &&
	      (denominator(y) < s7_int32_max))
	    {
	      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;

	default:
	  method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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_int32_max) &&
	      (integer(y) > s7_int32_min) &&
	      (denominator(x) < s7_int32_max))
	    {
	      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 HAVE_OVERFLOW_CHECKS
		if ((multiply_overflow(n1, d2, &n1)) ||
		    (multiply_overflow(n2, d1, &n2)))
		  {
		    if (fraction(x) >= fraction(y)) goto NOT_LESS;
		  }
		else
		  {
		    if (n1 >= n2) goto NOT_LESS;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		  }
#endif
	      }
	  }
	  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;

	default:
	  method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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;

	default:
	  method_or_bust(sc, y, sc->lt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
    }

 NOT_LESS:
  for (; is_pair(p); p = cdr(p))
    if (!is_real_via_method(sc, car(p)))
      return(wrong_type_argument(sc, sc->lt_symbol, 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"
  #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  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_int32_max) &&
	      (integer(x) > s7_int32_min) &&
	      (denominator(y) < s7_int32_max))
	    {
	      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;

	default:
	  method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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_int32_max) &&
	      (integer(y) > s7_int32_min) &&
	      (denominator(x) < s7_int32_max))
	    {
	      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 HAVE_OVERFLOW_CHECKS
		if ((multiply_overflow(n1, d2, &n1)) ||
		    (multiply_overflow(n2, d1, &n2)))
		  {
		    if (fraction(x) > fraction(y)) goto NOT_LEQ;
		  }
		else
		  {
		    if (n1 > n2) goto NOT_LEQ;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		  }
#endif
	      }
	  }
	  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;

	default:
	  method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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;

	default:
	  method_or_bust(sc, y, sc->leq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1);
    }

 NOT_LEQ:
  for (; is_pair(p); p = cdr(p))
    if (!is_real_via_method(sc, car(p)))
      return(wrong_type_argument(sc, sc->leq_symbol, 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"
  #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  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_int32_max) &&
	      (integer(x) > s7_int32_min) &&
	      (denominator(y) < s7_int32_max))
	    {
	      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;

	default:
	  method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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_int32_max) &&
	      (integer(y) > s7_int32_min) &&
	      (denominator(x) < s7_int32_max))
	    {
	      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 HAVE_OVERFLOW_CHECKS
		if ((multiply_overflow(n1, d2, &n1)) ||
		    (multiply_overflow(n2, d1, &n2)))
		  {
		    if (fraction(x) <= fraction(y)) goto NOT_GREATER;
		  }
		else
		  {
		    if (n1 <= n2) goto NOT_GREATER;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		  }
#endif
	      }
	  }
	  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;

	default:
	  method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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;

	default:
	  method_or_bust(sc, y, sc->gt_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->gt_symbol, args, T_REAL, 1);
    }

 NOT_GREATER:
  for (; is_pair(p); p = cdr(p))
    if (!is_real_via_method(sc, car(p)))
      return(wrong_type_argument(sc, sc->gt_symbol, 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"
  #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
  /* (>= 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_int32_max) &&
	      (integer(x) > s7_int32_min) &&
	      (denominator(y) < s7_int32_max))
	    {
	      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;

	default:
	  method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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_int32_max) &&
	      (integer(y) > s7_int32_min) &&
	      (denominator(x) < s7_int32_max))
	    {
	      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 HAVE_OVERFLOW_CHECKS
		if ((multiply_overflow(n1, d2, &n1)) ||
		    (multiply_overflow(n2, d1, &n2)))
		  {
		    if (fraction(x) < fraction(y)) goto NOT_GEQ;
		  }
		else
		  {
		    if (n1 < n2) goto NOT_GEQ;
		  }
#else
		if ((d1 > s7_int32_max) || (d2 > s7_int32_max) ||     /* before counting bits, check that overflow is possible */
		    (n1 > s7_int32_max) || (n2 > s7_int32_max) ||
		    (n1 < s7_int32_min) || (n2 < s7_int32_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;
		  }
#endif
	      }
	  }
	  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;

	default:
	  method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}


    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;

	default:
	  method_or_bust(sc, y, sc->geq_symbol, cons(sc, x, cons(sc, y, p)), T_REAL, position_of(p, args) - 1);
	}

    default:
      method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1);
    }

 NOT_GEQ:
  for (; is_pair(p); p = cdr(p))
    if (!is_real_via_method(sc, car(p)))
      return(wrong_type_argument(sc, sc->geq_symbol, 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)));
  method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
}

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

    case T_RATIO:
      if ((y >= 0) && (numerator(x) < 0))
	return(sc->T);
      if ((y <= 0) && (numerator(x) > 0))
	return(sc->F);
      if (denominator(x) < s7_int32_max)
	return(make_boolean(sc, (numerator(x) < (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) < y));

    case T_REAL:
      return(make_boolean(sc, real(x) < y));

    case T_COMPLEX:
    default:
      method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1);
    }
  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 = find_symbol_checked(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_STRING:       return(make_boolean(sc, string_length(val) < ilen));
    case T_HASH_TABLE:   return(make_boolean(sc, hash_table_mask(val) < ilen)); /* was <=? -- changed 15-Dec-15 */
    case T_ITERATOR:     return(make_boolean(sc, iterator_length(val) < ilen));
    case T_C_OBJECT:     return(make_boolean(sc, object_length_to_int(sc, val) < ilen));
    case T_LET:          return(make_boolean(sc, let_length(sc, val) < ilen));  /* this works because let_length handles the length method itself! */
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:       return(make_boolean(sc, vector_length(val) < ilen));
    case T_CLOSURE:
    case T_CLOSURE_STAR: if (has_methods(val)) return(make_boolean(sc, closure_length(sc, val) < ilen));
    default:             return(simple_wrong_type_argument_with_type(sc, sc->length_symbol, val, a_sequence_string)); /* no check method here because we checked above */
    }
  return(sc->F);
}

static s7_pointer c_less_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  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_less(sc, list_2(sc, x, y)));

	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) < real(y)));

	default:
	  method_or_bust(sc, y, sc->lt_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    case T_RATIO:
      return(g_less(sc, list_2(sc, x, y)));

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

	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) < fraction(y)));

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

	default:
	  method_or_bust(sc, y, sc->lt_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    default:
      method_or_bust(sc, x, sc->lt_symbol, list_2(sc, x, y), T_REAL, 1);
    }
  return(sc->T);
}

static s7_pointer c_less_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#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
  return(c_less_2_1(sc, x, y));
}

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
  return(c_less_2_1(sc, x, y));
}

static s7_pointer c_less_i(s7_scheme *sc, s7_int x, s7_int y) {return(make_boolean(sc, x < y));}
static s7_pointer c_less_r(s7_scheme *sc, s7_double x, s7_double y) {return(make_boolean(sc, x < y));}
XF2_TO_PF(less, c_less_i, c_less_r, c_less_2)


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

    case T_RATIO:
      if ((y >= 0) && (numerator(x) <= 0))
	return(sc->T);
      if ((y <= 0) && (numerator(x) > 0))
	return(sc->F);
      if (denominator(x) < s7_int32_max)
	return(make_boolean(sc, (numerator(x) <= (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) <= y));

    case T_REAL:
      return(make_boolean(sc, real(x) <= y));

    default:
      method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1);
    }
  return(sc->T);
}


static s7_pointer c_leq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  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_less_or_equal(sc, list_2(sc, x, y)));

	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) <= real(y)));

	default:
	  method_or_bust(sc, y, sc->leq_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    case T_RATIO:
      return(g_less_or_equal(sc, list_2(sc, x, y)));

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

	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) <= fraction(y)));

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

	default:
	  method_or_bust(sc, y, sc->leq_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    default:
      method_or_bust(sc, x, sc->leq_symbol, list_2(sc, x, y), T_REAL, 1);
    }
  return(sc->T);
}

static s7_pointer c_leq_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#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
  return(c_leq_2_1(sc, x, y));
}

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

#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
  return(c_leq_2_1(sc, x, y));
}

static s7_pointer c_leq_i(s7_scheme *sc, s7_int x, s7_int y) {return(make_boolean(sc, x <= y));}
static s7_pointer c_leq_r(s7_scheme *sc, s7_double x, s7_double y) {return(make_boolean(sc, x <= y));}
XF2_TO_PF(leq, c_leq_i, c_leq_r, c_leq_2)


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 = integer(cadr(args));
  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) > y));

    case T_RATIO:
      if (denominator(x) < s7_int32_max)               /* y has already been checked for range */
	return(make_boolean(sc, (numerator(x) > (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) > y));

    case T_REAL:
      return(make_boolean(sc, real(x) > y));

    default:
      method_or_bust_with_type(sc, x, sc->gt_symbol, args, a_number_string, 1);
    }
  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 = real(cadr(args));

  if (is_t_real(x))
    return(make_boolean(sc, real(x) > y));

  switch (type(x))
    {
    case T_INTEGER:
      return(make_boolean(sc, integer(x) > y));

    case T_RATIO:
      /* (> 9223372036854775807/9223372036854775806 1.0) */
      if (denominator(x) < s7_int32_max) /* y range check was handled in greater_chooser */
	return(make_boolean(sc, (numerator(x) > (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) > y));

    case T_REAL:
      return(make_boolean(sc, real(x) > y));

    default:
      method_or_bust_with_type(sc, x, sc->gt_symbol, args, a_number_string, 1);
    }
  return(sc->T);
}


static s7_pointer c_greater_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  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, list_2(sc, x, y)));

	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) > real(y)));

	default:
	  method_or_bust(sc, y, sc->gt_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    case T_RATIO:
      return(g_greater(sc, list_2(sc, x, y)));

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

	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) > fraction(y)));

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

	default:
	  method_or_bust(sc, y, sc->gt_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    default:
      method_or_bust(sc, x, sc->gt_symbol, list_2(sc, x, y), T_REAL, 1);
    }
  return(sc->T);
}

static s7_pointer c_greater_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#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
  return(c_greater_2_1(sc, x, y));
}

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

#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
  return(c_greater_2_1(sc, x, y));
}

static s7_pointer c_gt_i(s7_scheme *sc, s7_int x, s7_int y) {return(make_boolean(sc, x > y));}
static s7_pointer c_gt_r(s7_scheme *sc, s7_double x, s7_double y) {return(make_boolean(sc, x > y));}
XF2_TO_PF(gt, c_gt_i, c_gt_r, c_greater_2)


static s7_pointer greater_2_f;
static s7_pointer g_greater_2_f(s7_scheme *sc, s7_pointer args)
{
  return(make_boolean(sc, real(car(args)) > real(cadr(args))));
}


static s7_pointer c_geq_2_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  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_or_equal(sc, list_2(sc, x, y)));

	case T_REAL:
	  if (is_NaN(real(y))) return(sc->F);
	  return(make_boolean(sc, integer(x) >= real(y)));

	default:
	  method_or_bust(sc, y, sc->geq_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    case T_RATIO:
      return(g_greater_or_equal(sc, list_2(sc, x, y)));

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

	case T_RATIO:
	  if (is_NaN(real(x))) return(sc->F);
	  return(make_boolean(sc, real(x) >= fraction(y)));

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

	default:
	  method_or_bust(sc, y, sc->geq_symbol, list_2(sc, x, y), T_REAL, 2);
	}
      break;

    default:
      method_or_bust(sc, x, sc->geq_symbol, list_2(sc, x, y), T_REAL, 1);
    }
  return(sc->T);
}

static s7_pointer c_geq_2(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
#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
  return(c_geq_2_1(sc, x, y));
}
#endif

static s7_pointer geq_2 = NULL;

#if (!WITH_GMP)
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
  return(c_geq_2_1(sc, x, y));
}

static s7_pointer c_geq_i(s7_scheme *sc, s7_int x, s7_int y) {return(make_boolean(sc, x >= y));}
static s7_pointer c_geq_r(s7_scheme *sc, s7_double x, s7_double y) {return(make_boolean(sc, x >= y));}
XF2_TO_PF(geq, c_geq_i, c_geq_r, c_geq_2)


static s7_pointer geq_s_fc;
static s7_pointer g_geq_s_fc(s7_scheme *sc, s7_pointer args)
{
  s7_double y;
  s7_pointer x;

  x = car(args);
  y = real(cadr(args));

  if (is_t_real(x))
    return(make_boolean(sc, real(x) >= y));
  return(g_geq_2(sc, args));
}


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

    case T_RATIO:
      if ((y >= 0) && (numerator(x) < 0))
	return(sc->F);
      if ((y <= 0) && (numerator(x) >= 0))
	return(sc->T);
      if ((y < s7_int32_max) &&
	  (y > s7_int32_min) &&
	  (denominator(x) < s7_int32_max))
	return(make_boolean(sc, (numerator(x) >= (y * denominator(x)))));
      return(make_boolean(sc, fraction(x) >= y));

    case T_REAL:
      return(make_boolean(sc, real(x) >= y));

    default:
      method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1);
    }
  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"
  #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)  

  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, T_BIG_REAL);
	add_bigreal(sc, x);
	mpfr_init(big_real(x));
	mpc_real(big_real(x), big_complex(p), GMP_RNDN);

	return(x);
      }
#endif

    default:
      method_or_bust_with_type(sc, p, sc->real_part_symbol, args, a_number_string, 0);
    }
}

#if (!WITH_GMP)
static s7_double c_real_part(s7_scheme *sc, s7_pointer x) {return(real(g_real_part(sc, set_plist_1(sc, x))));}
PF_TO_RF(real_part, c_real_part)
#endif


static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
{
  #define H_imag_part "(imag-part num) returns the imaginary part of num"
  #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)  
  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, T_BIG_REAL);
	add_bigreal(sc, x);
	mpfr_init(big_real(x));
	mpc_imag(big_real(x), big_complex(p), GMP_RNDN);

	return(x);
      }
#endif

    default:
      method_or_bust_with_type(sc, p, sc->imag_part_symbol, args, a_number_string, 0);
    }
}

#if (!WITH_GMP)
static s7_double c_imag_part(s7_scheme *sc, s7_pointer x) {return(real(g_imag_part(sc, set_plist_1(sc, x))));}
PF_TO_RF(imag_part, c_imag_part)
#endif


/* ---------------------------------------- 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"
  #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)

  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
    default:            method_or_bust_with_type(sc, x, sc->numerator_symbol, args, a_rational_string, 0);
    }
}

#if (!WITH_GMP)
static s7_int c_numerator(s7_scheme *sc, s7_pointer x) {return(s7_numerator(x));}
PF_TO_IF(numerator, c_numerator)
#endif


static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
{
  #define H_denominator "(denominator rat) returns the denominator of the rational number rat"
  #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)

  s7_pointer x;
  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
    default:            method_or_bust_with_type(sc, x, sc->denominator_symbol, args, a_rational_string, 0);
    }
}

#if (!WITH_GMP)
static s7_int c_denominator(s7_scheme *sc, s7_pointer x) {return(s7_denominator(x));}
PF_TO_IF(denominator, c_denominator)
#endif


/* ---------------------------------------- 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"
  #define Q_is_nan pl_bn  

  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:
      method_or_bust_with_type(sc, x, sc->is_nan_symbol, list_1(sc, x), a_number_string, 0);
    }
}

#if (!WITH_GMP)
static s7_pointer c_is_nan(s7_scheme *sc, s7_double x) {return((is_NaN(x)) ? sc->T : sc->F);}
RF_TO_PF(is_nan, c_is_nan)
#endif


static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args)
{
  #define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real"
  #define Q_is_infinite pl_bn  

  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, list_1(sc, x)))) != 0) ||
			  (mpfr_inf_p(big_real(g_imag_part(sc, list_1(sc, x)))) != 0)));
#endif

    default:
      method_or_bust_with_type(sc, x, sc->is_infinite_symbol, list_1(sc, x), a_number_string, 0);
    }
}

#if (!WITH_GMP)
static s7_pointer c_is_infinite(s7_scheme *sc, s7_double x) {return((is_inf(x)) ? sc->T : sc->F);}
RF_TO_PF(is_infinite, c_is_infinite)
#endif


/* ---------------------------------------- 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"
  #define Q_is_number pl_bt  
  check_boolean_method(sc, s7_is_number, sc->is_number_symbol, 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"
  #define Q_is_integer pl_bt  
  check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args);
}


static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args)
{
  #define H_is_real "(real? obj) returns #t if obj is a real number"
  #define Q_is_real pl_bt  
  check_boolean_method(sc, s7_is_real, sc->is_real_symbol, args);
}


static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args)
{
  #define H_is_complex "(complex? obj) returns #t if obj is a number"
  #define Q_is_complex pl_bt  
  check_boolean_method(sc, s7_is_number, sc->is_complex_symbol, args);
}


static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args)
{
  #define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)"
  #define Q_is_rational pl_bt  
  check_boolean_method(sc, s7_is_rational, sc->is_rational_symbol, 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"
  #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)

  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:            method_or_bust(sc, p, sc->is_even_symbol, list_1(sc, p), T_INTEGER, 0);
    }
}

#if (!WITH_GMP)
static s7_pointer c_is_even(s7_scheme *sc, s7_int arg) {return(((arg & 1) == 0) ? sc->T : sc->F);}
IF_TO_PF(is_even, c_is_even)
#endif


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"
  #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)

  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:            method_or_bust(sc, p, sc->is_odd_symbol, list_1(sc, p), T_INTEGER, 0);
    }
}

#if (!WITH_GMP)
static s7_pointer c_is_odd(s7_scheme *sc, s7_int arg) {return(((arg & 1) == 0) ? sc->F : sc->T);}
IF_TO_PF(is_odd, c_is_odd)
#endif


/* ---------------------------------------- zero? ---------------------------------------- */
static s7_pointer c_is_zero(s7_scheme *sc, s7_pointer x)
{
  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:     return(sc->F);      /* ratios and complex numbers are already collapsed into integers and reals */
#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:
      method_or_bust_with_type(sc, x, sc->is_zero_symbol, list_1(sc, x), a_number_string, 0);
    }
}

static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args)
{
  #define H_is_zero "(zero? num) returns #t if the number num is zero"
  #define Q_is_zero pl_bn

  return(c_is_zero(sc, car(args)));
}

static s7_pointer c_is_zero_i(s7_scheme *sc, s7_int x) {return(make_boolean(sc, x == 0));}
static s7_pointer c_is_zero_r(s7_scheme *sc, s7_double x) {return(make_boolean(sc, x == 0.0));}
XF_TO_PF(is_zero, c_is_zero_i, c_is_zero_r, c_is_zero)


/* -------------------------------- positive? -------------------------------- */
static s7_pointer c_is_positive(s7_scheme *sc, s7_pointer x)
{
  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:
      method_or_bust(sc, x, sc->is_positive_symbol, list_1(sc, x), T_REAL, 0);
    }
}

static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args)
{
  #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)"
  #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  return(c_is_positive(sc, car(args)));
}

static s7_pointer c_is_positive_i(s7_scheme *sc, s7_int x) {return(make_boolean(sc, x > 0));}
static s7_pointer c_is_positive_r(s7_scheme *sc, s7_double x) {return(make_boolean(sc, x > 0.0));}
XF_TO_PF(is_positive, c_is_positive_i, c_is_positive_r, c_is_positive)


/* -------------------------------- negative? -------------------------------- */
static s7_pointer c_is_negative(s7_scheme *sc, s7_pointer x)
{
  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:
      method_or_bust(sc, x, sc->is_negative_symbol, list_1(sc, x), T_REAL, 0);
    }
}

static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args)
{
  #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)"
  #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  return(c_is_negative(sc, car(args)));
}

static s7_pointer c_is_negative_i(s7_scheme *sc, s7_int x) {return(make_boolean(sc, x < 0));}
static s7_pointer c_is_negative_r(s7_scheme *sc, s7_double x) {return(make_boolean(sc, x < 0.0));}
XF_TO_PF(is_negative, c_is_negative_i, c_is_negative_r, c_is_negative)


bool s7_is_ulong(s7_pointer arg)
{
  return(is_integer(arg));
}


unsigned long s7_ulong(s7_pointer p)
{
  return((_NFre(p))->object.number.ul_value);
}


s7_pointer s7_make_ulong(s7_scheme *sc, unsigned long n)
{
  s7_pointer x;
  new_cell(sc, 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((_NFre(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, T_INTEGER);
  x->object.number.ull_value = n;
  return(x);
}


#if (!WITH_PURE_S7)
#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"
  #define Q_exact_to_inexact pcl_r
  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"
  #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_rational_symbol, sc->is_real_symbol)
  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)"
  #define Q_is_exact pl_bn

  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:
      method_or_bust_with_type(sc, x, sc->is_exact_symbol, args, a_number_string, 0);
    }
}


static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args)
{
  #define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)"
  #define Q_is_inexact pl_bn

  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:
      method_or_bust_with_type(sc, x, sc->is_inexact_symbol, args, a_number_string, 0);
    }
}


/* ---------------------------------------- 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))"
  #define Q_integer_length pcl_i

  s7_int x;
  s7_pointer p;

  p = car(args);
  if (!s7_is_integer(p))
    method_or_bust(sc, p, sc->integer_length_symbol, args, T_INTEGER, 0);


  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)
static s7_int c_integer_length(s7_scheme *sc, s7_int arg) {return((arg < 0) ? integer_length(-(arg + 1)) : integer_length(arg));}
IF_TO_IF(integer_length, c_integer_length)
#endif
#endif /* !pure s7 */


static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args)
{
  #define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \
sign of 'x' (1 = positive, -1 = negative).  (integer-decode-float 0.0): (0 0 1)"
  #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol)

  /* no matter what s7_double is, integer-decode-float acts as if x is a C double */

  typedef struct decode_float_t {
    union {
      long long int ix;
      double fx;
    } value;
  } decode_float_t;

 decode_float_t num;
  s7_pointer x;
  x = car(args);

  switch (type(x))
    {
    case T_REAL:
      num.value.fx = (double)real(x);
      break;

#if WITH_GMP
    case T_BIG_REAL:
      num.value.fx = (double)real_to_double(sc, x, "integer-decode-float");
      break;
#endif

    default:
      method_or_bust_with_type(sc, x, sc->integer_decode_float_symbol, args, make_string_wrapper(sc, "a non-rational real"), 0);
    }

  if (num.value.fx == 0.0)
    return(list_3(sc, small_int(0), small_int(0), small_int(1)));

  return(list_3(sc,
		make_integer(sc, (s7_int)((num.value.ix & 0xfffffffffffffLL) | 0x10000000000000LL)),
		make_integer(sc, (s7_int)(((num.value.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)),
		make_integer(sc, ((num.value.ix & 0x8000000000000000LL) != 0) ? -1 : 1)));
}


/* -------------------------------- logior -------------------------------- */
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)"
  #define Q_logior pcl_i
  s7_int result = 0;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!s7_is_integer(car(x)))
	method_or_bust(sc, car(x), sc->logior_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
      result |= s7_integer(car(x));
    }
  return(make_integer(sc, result));
}

#if (!WITH_GMP)
static s7_int c_logior(s7_scheme *sc, s7_int x, s7_int y) {return(x | y);}
IF2_TO_IF(logior, c_logior)
#endif


/* -------------------------------- logxor -------------------------------- */
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)"
  #define Q_logxor pcl_i
  s7_int result = 0;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!s7_is_integer(car(x)))
	method_or_bust(sc, car(x), sc->logxor_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
      result ^= s7_integer(car(x));
    }
  return(make_integer(sc, result));
}

#if (!WITH_GMP)
static s7_int c_logxor(s7_scheme *sc, s7_int x, s7_int y) {return(x ^ y);}
IF2_TO_IF(logxor, c_logxor)
#endif


/* -------------------------------- logand -------------------------------- */
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)"
  #define Q_logand pcl_i
  s7_int result = -1;
  s7_pointer x;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!s7_is_integer(car(x)))
	method_or_bust(sc, car(x), sc->logand_symbol, cons(sc, make_integer(sc, result), x), T_INTEGER, position_of(x, args));
      result &= s7_integer(car(x));
    }
  return(make_integer(sc, result));
}

#if (!WITH_GMP)
static s7_int c_logand(s7_scheme *sc, s7_int x, s7_int y) {return(x & y);}
IF2_TO_IF(logand, c_logand)
#endif


/* -------------------------------- lognot -------------------------------- */

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"
  #define Q_lognot pcl_i
  if (!s7_is_integer(car(args)))
    method_or_bust(sc, car(args), sc->lognot_symbol, args, T_INTEGER, 0);
  return(make_integer(sc, ~s7_integer(car(args))));
}

#if (!WITH_GMP)
static s7_int c_lognot(s7_scheme *sc, s7_int arg) {return(~arg);}
IF_TO_IF(lognot, c_lognot)
#endif


/* -------------------------------- logbit? -------------------------------- */
/* logbit?  CL is (logbitp index int) using 2^index, but that order strikes me as backwards
 *   at least gmp got the arg order right!
 */

static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args)
{
  #define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \
order here follows gmp, and is the opposite of the CL convention.  (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))."
  #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)

  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(x))
    method_or_bust(sc, x, sc->logbit_symbol, args, T_INTEGER, 1);
  if (!s7_is_integer(y))
    method_or_bust(sc, y, sc->logbit_symbol, args, T_INTEGER, 2);

  index = s7_integer(y);
  if (index < 0)
    return(out_of_range(sc, sc->logbit_symbol, small_int(2), y, its_negative_string));

#if WITH_GMP
  if (is_t_big_integer(x))
    return(make_boolean(sc, (mpz_tstbit(big_integer(x), index) != 0)));
#endif

  if (index >= s7_int_bits)           /* not sure about the >: (logbit? -1 64) ?? */
    return(make_boolean(sc, integer(x) < 0));

  /* :(zero? (logand most-positive-fixnum (ash 1 63)))
   *   -> ash argument 2, 63, is out of range (shift is too large)
   *   so logbit? has a wider range than the logand/ash shuffle above.
   */

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

/* -------------------------------- ash -------------------------------- */
static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2)
{
  if (arg1 == 0) return(0);

  if (arg2 >= s7_int_bits)
    out_of_range(sc, sc->ash_symbol, small_int(2), make_integer(sc, arg2), its_too_large_string);

  if (arg2 < -s7_int_bits)
    {
      if (arg1 < 0)                      /* (ash -31 -100) */
	return(-1);
      return(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)
    {
      if (arg1 < 0)
	{
	  unsigned long long int z;
	  z = (unsigned long long int)arg1;
	  return((s7_int)(z << arg2));
	}
      return(arg1 << arg2);
    }
  return(arg1 >> -arg2);
}

static s7_pointer g_ash(s7_scheme *sc, s7_pointer args)
{
  #define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1"
  #define Q_ash pcl_i
  s7_pointer x, y;

  x = car(args);
  if (!s7_is_integer(x))
    method_or_bust(sc, x, sc->ash_symbol, args, T_INTEGER, 1);

  y = cadr(args);
  if (!s7_is_integer(y))
    method_or_bust(sc, y, sc->ash_symbol, args, T_INTEGER, 2);

  return(make_integer(sc, c_ash(sc, s7_integer(x), s7_integer(y))));
}

#if (!WITH_GMP)
IF2_TO_IF(ash, c_ash)
#endif


/* ---------------------------------------- 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
 *     (random-state seed) -> make a new state
 *   to save the current seed, use copy
 *   to save it across load, random-state->list and list->random-state.
 *   random-state? returns #t if its arg is one of these guys
 */

#if (!WITH_GMP)
s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \
Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
    (let ((seed (random-state 1234))) (random 1.0 seed))"
  #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)

  s7_pointer r1, r2, p;
  s7_int i1, i2;

  r1 = car(args);
  if (!s7_is_integer(r1))
    method_or_bust(sc, r1, sc->random_state_symbol, args, T_INTEGER, 1);
  i1 = s7_integer(r1);
  if (i1 < 0)
    return(out_of_range(sc, sc->random_state_symbol, small_int(1), r1, its_negative_string));

  if (is_null(cdr(args)))
    {
      new_cell(sc, p, T_RANDOM_STATE);
      random_seed(p) = (unsigned long long int)i1;
      random_carry(p) = 1675393560;                          /* should this be dependent on the seed? */
      return(p);
    }

  r2 = cadr(args);
  if (!s7_is_integer(r2))
    method_or_bust(sc, r2, sc->random_state_symbol, args, T_INTEGER, 2);
  i2 = s7_integer(r2);
  if (i2 < 0)
    return(out_of_range(sc, sc->random_state_symbol, small_int(2), r2, its_negative_string));

  new_cell(sc, p, T_RANDOM_STATE);
  random_seed(p) = (unsigned long long int)i1;
  random_carry(p) = (unsigned long long int)i2;
  return(p);
}

#define g_random_state s7_random_state

static s7_pointer c_random_state(s7_scheme *sc, s7_pointer x) {return(s7_random_state(sc, set_plist_1(sc, x)));}
PF_TO_PF(random_state, c_random_state)
#endif

static s7_pointer rng_copy(s7_scheme *sc, s7_pointer args)
{
#if WITH_GMP
  return(sc->F); /* I can't find a way to copy a gmp random generator */
#else
  s7_pointer obj;
  obj = car(args);
  if (is_random_state(obj))
    {
      s7_pointer new_r;
      new_cell(sc, new_r, T_RANDOM_STATE);
      random_seed(new_r) = random_seed(obj);
      random_carry(new_r) = random_carry(obj);
      return(new_r);
    }
  return(sc->F);
#endif
}


static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)."
  #define Q_is_random_state pl_bt
  check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args);
}

s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\
You can later apply random-state to this list to continue a random number sequence from any point."
  #define Q_random_state_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_random_state_symbol)

#if WITH_GMP
  if ((is_pair(args)) &&
      (!is_random_state(car(args))))
    method_or_bust_with_type(sc, car(args), sc->random_state_to_list_symbol, args, a_random_state_object_string, 1);
  return(sc->nil);
#else
  s7_pointer r;
  if (is_null(args))
    r = sc->default_rng;
  else
    {
      r = car(args);
      if (!is_random_state(r))
	method_or_bust_with_type(sc, r, sc->random_state_to_list_symbol, args, a_random_state_object_string, 1);
    }
  return(list_2(sc, make_integer(sc, random_seed(r)), make_integer(sc, random_carry(r))));
#endif
}

#define g_random_state_to_list s7_random_state_to_list

s7_pointer c_random_state_to_list(s7_scheme *sc, s7_pointer x) {return(s7_random_state_to_list(sc, set_plist_1(sc, x)));}
PF_TO_PF(random_state_to_list, c_random_state_to_list)


void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry)
{
#if (!WITH_GMP)
  s7_pointer p;
  new_cell(sc, p, T_RANDOM_STATE);
  random_seed(p) = (unsigned long long int)seed;
  random_carry(p) = (unsigned long long int)carry;
  sc->default_rng = p;
#endif
}

#if (!WITH_GMP)
/* -------------------------------- random -------------------------------- */

static double next_random(s7_pointer 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 = random_seed(r) * RAN_MULT + random_carry(r);
  random_seed(r) = (temp & 0xffffffffUL);
  random_carry(r) = (temp >> 32);
  result = (double)((unsigned int)(random_seed(r))) / 4294967295.5;
  /* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries?
   *   do we want the double just less than 2^32?
   */

  /* (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_double s7_random(s7_scheme *sc, s7_pointer state)
{
  if (!state)
    return(next_random(sc->default_rng));
  return(next_random(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)."
  #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
  s7_pointer r, num;

  num = car(args);
  if (!s7_is_number(num))
    method_or_bust_with_type(sc, num, sc->random_symbol, args, a_number_string, 1);

  if (is_not_null(cdr(args)))
    {
      r = cadr(args);
      if (!is_random_state(r))
	method_or_bust_with_type(sc, r, sc->random_symbol, args, a_random_state_object_string, 2);
    }
  else r = sc->default_rng;

  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_int_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)));
    }
  return(sc->F);
}

static s7_int c_random_i(s7_scheme *sc, s7_int arg) {return((s7_int)(arg * next_random(sc->default_rng)));} /* not round! */
IF_TO_IF(random, c_random_i)
static s7_double c_random_r(s7_scheme *sc, s7_double arg) {return(arg * next_random(sc->default_rng));}
RF_TO_RF(random, c_random_r)

static s7_pointer random_ic, random_rc, random_i;

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_i(s7_scheme *sc, s7_pointer args)
{
  return(make_integer(sc, (s7_int)(integer(slot_value(global_slot(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)
    {
      s7_pointer arg1;
      arg1 = cadr(expr);
      if (s7_is_integer(arg1))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(random_ic);
	}
      if ((is_real(arg1)) &&
	  (!is_rational(arg1)))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(random_rc);
	}
      if ((is_symbol(arg1)) &&
	  (is_immutable_symbol(arg1)) &&
	  (is_global(arg1)) &&
	  (is_integer(slot_value(global_slot(arg1)))))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(random_i);
	}
    }
  return(f);
}
#endif /* gmp */



/* -------------------------------- characters -------------------------------- */

#define NUM_CHARS 256

static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args)
{
  #define H_char_to_integer "(char->integer c) converts the character c to an integer"
  #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)

  if (!s7_is_character(car(args)))
    method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, T_CHARACTER, 0);
  return(small_int(character(car(args))));
}

#define int_method_or_bust(Sc, Obj, Method, Args, Type, Num)		\
  {									\
    s7_pointer func;							\
    if ((has_methods(Obj)) && ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
      return(integer(s7_apply_function(Sc, func, Args)));		\
    if (Num == 0) simple_wrong_type_argument(Sc, Method, Obj, Type);	\
    wrong_type_argument(Sc, Method, Num, Obj, Type);			\
  }

static s7_int c_char_to_integer(s7_scheme *sc, s7_pointer p)
{
  if (!s7_is_character(p))
    int_method_or_bust(sc, p, sc->char_to_integer_symbol, set_plist_1(sc, p), T_CHARACTER, 0);
  return(character(p));
}

PF_TO_IF(char_to_integer, c_char_to_integer)


static s7_pointer c_int_to_char(s7_scheme *sc, s7_int ind)
{
  if ((ind < 0) || (ind >= NUM_CHARS))
    return(simple_wrong_type_argument_with_type(sc, sc->integer_to_char_symbol, make_integer(sc, ind), 
						make_string_wrapper(sc, "an integer that can represent a character")));
  return(s7_make_character(sc, (unsigned char)ind));
}

static s7_pointer c_integer_to_char(s7_scheme *sc, s7_pointer x)
{
  s7_int ind;
  if (!s7_is_integer(x))
    method_or_bust(sc, x, sc->integer_to_char_symbol, list_1(sc, x), T_INTEGER, 0);
  ind = s7_integer(x);
  if ((ind < 0) || (ind >= NUM_CHARS))
    return(simple_wrong_type_argument_with_type(sc, sc->integer_to_char_symbol, x, make_string_wrapper(sc, "an integer that can represent a character")));
  return(s7_make_character(sc, (unsigned char)ind));
}

static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args)
{
  #define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character"
  #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)
  return(c_integer_to_char(sc, car(args)));
}

IF_TO_PF(integer_to_char, c_int_to_char)


static unsigned char uppers[256], lowers[256];
static void init_uppers(void)
{
  int i;
  for (i = 0; i < 256; i++)
    {
      uppers[i] = (unsigned char)toupper(i);
      lowers[i] = (unsigned char)tolower(i);
    }
}

static s7_pointer c_char_upcase(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->char_upcase_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(s7_make_character(sc, upper_character(arg)));
}

static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args)
{
  #define H_char_upcase "(char-upcase c) converts the character c to upper case"
  #define Q_char_upcase pcl_c
  if (!s7_is_character(car(args)))
    method_or_bust(sc, car(args), sc->char_upcase_symbol, args, T_CHARACTER, 0);
  return(s7_make_character(sc, upper_character(car(args))));
}

PF_TO_PF(char_upcase, c_char_upcase)


static s7_pointer c_char_downcase(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->char_downcase_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(s7_make_character(sc, lowers[(int)character(arg)]));
}

static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args)
{
  #define H_char_downcase "(char-downcase c) converts the character c to lower case"
  #define Q_char_downcase pcl_c
  if (!s7_is_character(car(args)))
    method_or_bust(sc, car(args), sc->char_downcase_symbol, args, T_CHARACTER, 0);
  return(s7_make_character(sc, lowers[character(car(args))]));
}

PF_TO_PF(char_downcase, c_char_downcase)


static s7_pointer c_is_char_alphabetic(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->is_char_alphabetic_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(make_boolean(sc, is_char_alphabetic(arg)));
}

static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic"
  #define Q_is_char_alphabetic pl_bc
  if (!s7_is_character(car(args)))
    method_or_bust(sc, car(args), sc->is_char_alphabetic_symbol, args, T_CHARACTER, 0);
  return(make_boolean(sc, is_char_alphabetic(car(args))));

  /* isalpha returns #t for (integer->char 226) and others in that range */
}

PF_TO_PF(is_char_alphabetic, c_is_char_alphabetic)


static s7_pointer c_is_char_numeric(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->is_char_numeric_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(make_boolean(sc, is_char_numeric(arg)));
}

static s7_pointer g_is_char_numeric(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit"
  #define Q_is_char_numeric pl_bc
  return(c_is_char_numeric(sc, car(args)));
}

PF_TO_PF(is_char_numeric, c_is_char_numeric)


static s7_pointer c_is_char_whitespace(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->is_char_whitespace_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(make_boolean(sc, is_char_whitespace(arg)));
}

static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character"
  #define Q_is_char_whitespace pl_bc
  return(c_is_char_whitespace(sc, car(args)));
}

PF_TO_PF(is_char_whitespace, c_is_char_whitespace)


static s7_pointer c_is_char_upper_case(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->is_char_upper_case_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(make_boolean(sc, is_char_uppercase(arg)));
}

static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case"
  #define Q_is_char_upper_case pl_bc
  return(c_is_char_upper_case(sc, car(args)));
}

PF_TO_PF(is_char_upper_case, c_is_char_upper_case)


static s7_pointer c_is_char_lower_case(s7_scheme *sc, s7_pointer arg)
{
  if (!s7_is_character(arg))
    method_or_bust(sc, arg, sc->is_char_lower_case_symbol, set_plist_1(sc, arg), T_CHARACTER, 0);
  return(make_boolean(sc, is_char_lowercase(arg)));
}

static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case"
  #define Q_is_char_lower_case pl_bc
  return(c_is_char_lower_case(sc, car(args)));
}

PF_TO_PF(is_char_lower_case, c_is_char_lower_case)



static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char "(char? obj) returns #t if obj is a character"
  #define Q_is_char pl_bt
  check_boolean_method(sc, s7_is_character, sc->is_char_symbol, 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 bool is_character_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_character(p))
    return(true);
  if (has_methods(p))
    {
      s7_pointer f;
      f = find_method(sc, find_let(sc, p), sc->is_char_symbol);
      if (f != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
    }
  return(false);
}


static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;

  y = car(args);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sym, args, T_CHARACTER, 1);

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      if (!s7_is_character(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args));

      if (charcmp(character(y), character(car(x))) != val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_character_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_CHARACTER));
	  return(sc->F);
	}
      y = 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, y;

  y = car(args);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sym, args, T_CHARACTER, 1);

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      if (!s7_is_character(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args));

      if (charcmp(character(y), character(car(x))) == val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_character_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_CHARACTER));
	  return(sc->F);
	}
      y = 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"
  #define Q_chars_are_equal pcl_bc

  s7_pointer x, y;

  y = car(args);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_eq_symbol, args, T_CHARACTER, 1);

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      if (!s7_is_character(car(x)))
	method_or_bust(sc, car(x), sc->char_eq_symbol, cons(sc, y, x), T_CHARACTER, position_of(x, args));

      if (car(x) != y)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_character_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sc->char_eq_symbol, position_of(y, args), car(y), T_CHARACTER));
	  return(sc->F);
	}
    }
  return(sc->T);
}


static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_less "(char<? char ...) returns #t if all the character arguments are increasing"
  #define Q_chars_are_less pcl_bc

  return(g_char_cmp(sc, args, -1, sc->char_lt_symbol));
}


static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing"
  #define Q_chars_are_greater pcl_bc

  return(g_char_cmp(sc, args, 1, sc->char_gt_symbol));
}


static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing"
  #define Q_chars_are_geq pcl_bc

  return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol));
}


static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args)
{
  #define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing"
  #define Q_chars_are_leq pcl_bc

  return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol));
}

static s7_pointer simple_char_eq;
static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args)
{
  return(make_boolean(sc, character(car(args)) == character(cadr(args))));
}

static s7_pointer c_char_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_eq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_eq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, x == y));
}

static s7_pointer s7_procedure_signature(s7_scheme *sc, s7_pointer x);
static bool char_check(s7_scheme *sc, s7_pointer obj)
{
  if (s7_is_character(obj)) return(true);
  if ((is_pair(obj)) && (is_symbol(car(obj))))
    {
      s7_pointer sig;
      sig = s7_procedure_signature(sc, s7_symbol_value(sc, car(obj)));
      return((sig) && (is_pair(sig)) && (car(sig) == sc->is_char_symbol));
    }
  return(false);
}

PF2_TO_PF_X(char_eq, char_check, c_char_eq, c_is_eq)


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 = find_symbol_checked(sc, car(args));
  if (c == cadr(args))
    return(sc->T);
  if (s7_is_character(c))
    return(sc->F);
  method_or_bust(sc, c, sc->char_eq_symbol, list_2(sc, c, cadr(args)), T_CHARACTER, 1);
}

static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args)
{
  if (!s7_is_character(car(args)))
    method_or_bust(sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1);
  if (car(args) == cadr(args))
    return(sc->T);
  if (!s7_is_character(cadr(args)))
    method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER, 2);
  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)))
    method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1);
  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)))
    method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1);
  if (!s7_is_character(cadr(args)))
    method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, T_CHARACTER, 2);
  return(make_boolean(sc, character(car(args)) < character(cadr(args))));
}

static s7_pointer c_char_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_lt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_lt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, character(x) < character(y)));
}

static s7_pointer c_clt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  return(make_boolean(sc, character(x) < character(y)));
}

PF2_TO_PF_X(char_lt, char_check, c_char_lt, c_clt)


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)))
    method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1);
  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)))
    method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1);
  if (!s7_is_character(cadr(args)))
    method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, T_CHARACTER, 2);
  return(make_boolean(sc, character(car(args)) > character(cadr(args))));
}

static s7_pointer c_char_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_gt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_gt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, character(x) > character(y)));
}

static s7_pointer c_cgt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  return(make_boolean(sc, character(x) > character(y)));
}

PF2_TO_PF_X(char_gt, char_check, c_char_gt, c_cgt)


static s7_pointer c_char_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_geq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_geq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, character(x) >= character(y)));
}

PF2_TO_PF(char_geq, c_char_geq)


static s7_pointer c_char_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_leq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_leq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, character(x) <= character(y)));
}

PF2_TO_PF(char_leq, c_char_leq)


#if (!WITH_PURE_S7)
static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;

  y = car(args);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sym, args, T_CHARACTER, 1);

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      if (!s7_is_character(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args));
      if (charcmp(upper_character(y), upper_character(car(x))) != val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_character_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_CHARACTER));
	  return(sc->F);
	}
      y = 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, y;

  y = car(args);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sym, args, T_CHARACTER, 1);
  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      if (!s7_is_character(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_CHARACTER, position_of(x, args));
      if (charcmp(upper_character(y), upper_character(car(x))) == val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_character_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_CHARACTER));
	  return(sc->F);
	}
      y = 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"
  #define Q_chars_are_ci_equal pcl_bc

  return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol));
}

static s7_pointer c_char_ci_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_ci_eq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_ci_eq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, upper_character(x) == upper_character(y)));
}

PF2_TO_PF(char_ci_eq, c_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"
  #define Q_chars_are_ci_less pcl_bc

  return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol));
}

static s7_pointer c_char_ci_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_ci_lt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_ci_lt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, upper_character(x) < upper_character(y)));
}

PF2_TO_PF(char_ci_lt, c_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"
  #define Q_chars_are_ci_greater pcl_bc

  return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol));
}

static s7_pointer c_char_ci_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_ci_gt_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_ci_gt_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, upper_character(x) > upper_character(y)));
}

PF2_TO_PF(char_ci_gt, c_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"
  #define Q_chars_are_ci_geq pcl_bc

  return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol));
}

static s7_pointer c_char_ci_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_ci_geq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_ci_geq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, upper_character(x) >= upper_character(y)));
}

PF2_TO_PF(char_ci_geq, c_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"
  #define Q_chars_are_ci_leq pcl_bc

  return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol));
}

static s7_pointer c_char_ci_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!s7_is_character(x))
    method_or_bust(sc, x, sc->char_ci_leq_symbol, list_2(sc, x, y), T_CHARACTER, 1);
  if (!s7_is_character(y))
    method_or_bust(sc, y, sc->char_ci_leq_symbol, list_2(sc, x, y), T_CHARACTER, 2);
  return(make_boolean(sc, upper_character(x) <= upper_character(y)));
}

PF2_TO_PF(char_ci_leq, c_char_ci_leq)
#endif /* not pure s7 */


static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
{
  #define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f"
  #define Q_char_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_boolean_symbol), s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_integer_symbol)

  const char *porig, *p, *pset;
  s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */
  s7_pointer arg1, arg2;

  arg1 = car(args);
  if ((!s7_is_character(arg1)) &&
      (!is_string(arg1)))
    method_or_bust(sc, arg1, sc->char_position_symbol, args, T_CHARACTER, 1);

  arg2 = cadr(args);
  if (!is_string(arg2))
    method_or_bust(sc, arg2, sc->char_position_symbol, args, T_STRING, 2);

  porig = string_value(arg2);
  len = string_length(arg2);

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3;
      arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	{
	  s7_pointer p;
	  if (!s7_is_integer(p = check_values(sc, arg3, cddr(args))))
	    method_or_bust(sc, arg3, sc->char_position_symbol, args, T_INTEGER, 3);
	  arg3 = p;
	}
      start = s7_integer(arg3);
      if (start < 0)
	return(wrong_type_argument_with_type(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string));
    }
  else start = 0;
  if (start >= len) return(sc->F);

  if (s7_is_character(arg1))
    {
      char c;
      c = character(arg1);
      p = strchr((const char *)(porig + start), (int)c); /* use strchrnul in Gnu C to catch embedded null case */
      if (p)
	return(make_integer(sc, p - porig));
      return(sc->F);
    }

  if (string_length(arg1) == 0)
    return(sc->F);
  pset = string_value(arg1);

  pos = strcspn((const char *)(porig + start), (const char *)pset);
  if ((pos + start) < len)
    return(make_integer(sc, pos + start));

  /* but if the string has an embedded null, we can get erroneous results here --
   *   perhaps check for null at pos+start?  What about a searched-for string that
   *   also has embedded nulls?
   *
   * The embedded nulls are for byte-vector usages, where presumably you're not talking
   *   about chars and strings, so I think I'll ignore these cases.  In unicode, you'd
   *   want to use unicode-aware searchers, so that also is irrelevant.
   */
  return(sc->F);
}

static s7_pointer c_char_position_ppi(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int z) {return(g_char_position(sc, set_plist_3(sc, x, y, make_integer(sc, z))));}
static s7_pointer c_char_position_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_char_position(sc, set_plist_2(sc, x, y)));}
PPIF_TO_PF(char_position, c_char_position_pp, c_char_position_ppi)


static s7_pointer char_position_csi;
static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args)
{
  /* assume char arg1, no end */
  const char *porig, *p;
  char c;
  s7_pointer arg2;
  s7_int start, len;

  c = character(car(args));
  arg2 = cadr(args);

  if (!is_string(arg2))
    return(g_char_position(sc, args));

  len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */
  porig = string_value(arg2);

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3;
      arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	return(g_char_position(sc, args));
      start = s7_integer(arg3);
      if (start < 0)
	return(wrong_type_argument_with_type(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string));
      if (start >= len) return(sc->F);
    }
  else start = 0;

  if (len == 0) return(sc->F);
  p = strchr((const char *)(porig + start), (int)c);
  if (p)
    return(make_integer(sc, p - porig));
  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"
  #define Q_string_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_boolean_symbol), sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
  const char *s1, *s2, *p2;
  s7_int start = 0;
  s7_pointer s1p, s2p;

  s1p = car(args);
  if (!is_string(s1p))
    method_or_bust(sc, s1p, sc->string_position_symbol, args, T_STRING, 1);

  s2p = cadr(args);
  if (!is_string(s2p))
    method_or_bust(sc, s2p, sc->string_position_symbol, args, T_STRING, 2);

  if (is_pair(cddr(args)))
    {
      s7_pointer arg3;
      arg3 = caddr(args);
      if (!s7_is_integer(arg3))
	{
	  s7_pointer p;
	  if (!s7_is_integer(p = check_values(sc, arg3, cddr(args))))
	    method_or_bust(sc, arg3, sc->string_position_symbol, args, T_INTEGER, 3);
	  arg3 = p;
	}
      start = s7_integer(arg3);
      if (start < 0)
	return(wrong_type_argument_with_type(sc, sc->string_position_symbol, 3, arg3, a_non_negative_integer_string));
    }

  if (string_length(s1p) == 0)
    return(sc->F);
  s1 = string_value(s1p);
  s2 = string_value(s2p);
  if (start >= string_length(s2p))
    return(sc->F);

  p2 = strstr((const char *)(s2 + start), s1);
  if (!p2) return(sc->F);
  return(make_integer(sc, p2 - s2));
}

static s7_pointer c_string_position_ppi(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int z) {return(g_string_position(sc, set_plist_3(sc, x, y, make_integer(sc, z))));}
static s7_pointer c_string_position_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_string_position(sc, set_plist_2(sc, x, y)));}
PPIF_TO_PF(string_position, c_string_position_pp, c_string_position_ppi)



/* -------------------------------- strings -------------------------------- */

s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, int len)
{
  s7_pointer x;
  new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE);
  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(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, 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_string_wrapper_with_length(s7_scheme *sc, const char *str, int len)
{
  s7_pointer x;
  new_cell(sc, x, T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE);
  string_value(x) = (char *)str;
  string_length(x) = len;
  string_hash(x) = 0;
  string_needs_free(x) = false;
  return(x);
}

static s7_pointer make_string_wrapper(s7_scheme *sc, const char *str)
{
  return(make_string_wrapper_with_length(sc, str, safe_strlen(str)));
}

static s7_pointer make_empty_string(s7_scheme *sc, int len, char fill)
{
  s7_pointer x;
  new_cell(sc, x, T_STRING);
  string_value(x) = (char *)malloc((len + 1) * sizeof(char));
  if (fill != 0)
    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)
{
  if (str)
    return(s7_make_string_with_length(sc, str, safe_strlen(str)));
  return(make_empty_string(sc, 0, 0));
}


static char *make_permanent_string(const char *str)
{
  char *x;
  int len;
  len = safe_strlen(str);
  x = (char *)malloc((len + 1) * sizeof(char));
  memcpy((void *)x, (void *)str, len);
  x[len] = 0;
  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();
  unheap(x);
  set_type(x, T_STRING | T_IMMUTABLE);
  if (str)
    {
      unsigned int len;
      len = safe_strlen(str);
      string_length(x) = len;
      string_value(x) = (char *)malloc((len + 1) * sizeof(char));
      memcpy((void *)string_value(x), (void *)str, len);
      string_value(x)[len] = 0;
    }
  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)
{
  s7_pointer p;
  p = sc->tmp_strs[0];
  prepare_temporary_string(sc, len + 1, 0);
  string_length(p) = len;
  if (len > 0)
    memmove((void *)(string_value(p)), (void *)str, len); /* not memcpy because str might be a temp string (i.e. sc->tmp_str_chars -> itself) */
  string_value(p)[len] = 0;
  return(p);
}


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"
  #define Q_is_string pl_bt

  check_boolean_method(sc, is_string, sc->is_string_symbol, args);
}


/* -------------------------------- make-string -------------------------------- */
static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args)
{
  #define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)"
  #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)

  s7_pointer n;
  s7_int len;
  char fill = ' ';

  n = car(args);
  if (!s7_is_integer(n))
    {
      check_two_methods(sc, n, sc->make_string_symbol, sc->make_byte_vector_symbol, args);
      return(wrong_type_argument(sc, sc->make_string_symbol, 1, n, T_INTEGER));
    }

  len = s7_integer(n);
  if ((len < 0) || (len > sc->max_string_length))
    return(out_of_range(sc, sc->make_string_symbol, small_int(1), n, (len < 0) ? its_negative_string : its_too_large_string));

  if (is_not_null(cdr(args)))
    {
      if (!s7_is_character(cadr(args)))
	method_or_bust(sc, cadr(args), sc->make_string_symbol, args, T_CHARACTER, 2);
      fill = s7_character(cadr(args));
    }
  n = make_empty_string(sc, (int)len, fill);
  if (fill == '\0')
    memset((void *)string_value(n), 0, (int)len);
  return(n);
}

static s7_pointer c_make_string(s7_scheme *sc, s7_int len) {return(make_empty_string(sc, (int)len, ' '));}
IF_TO_PF(make_string, c_make_string)


#if (!WITH_PURE_S7)
static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args)
{
  #define H_string_length "(string-length str) returns the length of the string str"
  #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
  s7_pointer p;
  p = car(args);
  if (!is_string(p))
    method_or_bust(sc, p, sc->string_length_symbol, args, T_STRING, 0);
  return(make_integer(sc, string_length(p)));
}

static s7_int c_string_length(s7_scheme *sc, s7_pointer p)
{
  if (!is_string(p))
    int_method_or_bust(sc, p, sc->string_length_symbol, set_plist_1(sc, p), T_STRING, 0);
  return(string_length(p));
}

PF_TO_IF(string_length, c_string_length)
#endif


/* -------------------------------- string-up|downcase -------------------------------- */

static s7_pointer c_string_downcase(s7_scheme *sc, s7_pointer p)
{
  s7_pointer newstr;
  int i, len;
  unsigned char *nstr, *ostr;

  sc->temp3 = p;
  if (!is_string(p))
    method_or_bust(sc, p, sc->string_downcase_symbol, list_1(sc, p), T_STRING, 0);

  len = string_length(p);
  newstr = make_empty_string(sc, len, 0);

  ostr = (unsigned char *)string_value(p);
  nstr = (unsigned char *)string_value(newstr);
  for (i = 0; i < len; i++)
    nstr[i] = lowers[(int)ostr[i]];

  return(newstr);
}

static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args)
{
  #define H_string_downcase "(string-downcase str) returns the lower case version of str."
  #define Q_string_downcase pcl_s
  return(c_string_downcase(sc, car(args)));
}

PF_TO_PF(string_downcase, c_string_downcase)


static s7_pointer c_string_upcase(s7_scheme *sc, s7_pointer p)
{
  s7_pointer newstr;
  int i, len;
  unsigned char *nstr, *ostr;

  sc->temp3 = p;
  if (!is_string(p))
    method_or_bust(sc, p, sc->string_upcase_symbol, list_1(sc, p), T_STRING, 0);

  len = string_length(p);
  newstr = make_empty_string(sc, len, 0);

  ostr = (unsigned char *)string_value(p);
  nstr = (unsigned char *)string_value(newstr);
  for (i = 0; i < len; i++)
    nstr[i] = uppers[(int)ostr[i]];

  return(newstr);
}

static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args)
{
  #define H_string_upcase "(string-upcase str) returns the upper case version of str."
  #define Q_string_upcase pcl_s
  return(c_string_upcase(sc, car(args)));
}

PF_TO_PF(string_upcase, c_string_upcase)


unsigned int s7_string_length(s7_pointer str)
{
  return(string_length(str));
}


/* -------------------------------- string-ref -------------------------------- */
static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index)
{
  char *str;
  s7_int ind;

  if (!s7_is_integer(index))
    {
      s7_pointer p;
      if (!s7_is_integer(p = check_values(sc, index, cons(sc, index, sc->nil))))
	method_or_bust(sc, index, sc->string_ref_symbol, list_2(sc, strng, index), T_INTEGER, 2);
      index = p;
    }
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, index, a_non_negative_integer_string));
  if (ind >= string_length(strng))
    return(out_of_range(sc, sc->string_ref_symbol, small_int(2), index, its_too_large_string));

  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, p;
  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"
  #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)

  strng = car(args);
  if (!is_string(strng))
    method_or_bust(sc, strng, sc->string_ref_symbol, args, T_STRING, 1);

  index = cadr(args);
  if (!s7_is_integer(index))
    {
      if (!s7_is_integer(p = check_values(sc, index, cdr(args))))
	method_or_bust(sc, index, sc->string_ref_symbol, args, T_INTEGER, 2);
      index = p;
    }
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, index, a_non_negative_integer_string));
  if (ind >= string_length(strng))
    return(out_of_range(sc, sc->string_ref_symbol, small_int(2), index, its_too_large_string));

  str = string_value(strng);
  return(s7_make_character(sc, ((unsigned char *)str)[ind]));
}

static s7_pointer c_string_ref(s7_scheme *sc, s7_pointer str, s7_int ind)
{
  if (!is_string(str))
    method_or_bust(sc, str, sc->string_ref_symbol, list_2(sc, str, make_integer(sc, ind)), T_STRING, 1);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->string_ref_symbol, 2, make_integer(sc, ind), a_non_negative_integer_string));
  if (ind >= string_length(str))
    return(out_of_range(sc, sc->string_ref_symbol, small_int(2), make_integer(sc, ind), its_too_large_string));
  return(s7_make_character(sc, ((unsigned char *)string_value(str))[ind]));
}

PIF_TO_PF(string_ref, c_string_ref)


/* -------------------------------- string-set! -------------------------------- */
static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
{
  #define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr"
  #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)

  s7_pointer x, c, index;
  char *str;
  s7_int ind;

  x = car(args);
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_set_symbol, args, T_STRING, 1);

  index = cadr(args);
  if (!s7_is_integer(index))
    {
      s7_pointer p;
      if (!s7_is_integer(p = check_values(sc, index, cdr(args))))
	method_or_bust(sc, index, sc->string_set_symbol, args, T_INTEGER, 2);
      index = p;
    }
  ind = s7_integer(index);
  if (ind < 0)
    return(wrong_type_argument_with_type(sc, sc->string_set_symbol, 2, index, a_non_negative_integer_string));
  if (ind >= string_length(x))
    return(out_of_range(sc, sc->string_set_symbol, small_int(2), index, its_too_large_string));
  str = string_value(_TSet(x));

  c = caddr(args);
  if (!s7_is_character(c))
    {
      if ((is_byte_vector(x)) &&
	  (s7_is_integer(c)))
	{
	  s7_int ic;  /* not int here! */
	  ic = s7_integer(c);
	  if ((ic < 0) || (ic > 255))
	    return(wrong_type_argument_with_type(sc, sc->string_set_symbol, 3, c, an_unsigned_byte_string));
	  str[ind] = (char)ic;
	  return(c);
	}
      method_or_bust(sc, c, sc->string_set_symbol, list_3(sc, x, index, c), T_CHARACTER, 3);
    }

  str[ind] = (char)s7_character(c);
  return(c);
}

static int c_string_tester(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1;
  a1 = cadr(expr);
  if (is_symbol(a1))
    {
      s7_pointer table;
      table = s7_slot(sc, a1);
      if ((is_slot(table)) && 
	  ((is_immutable_symbol(a1)) || (!is_stepper(table))) &&
	  (is_string(slot_value(table))))
	{
	  s7_pointer a2;
	  s7_xf_store(sc, slot_value(table));
	  a2 = caddr(expr);
	  if (is_symbol(a2))
	    {
	      s7_pointer slot;
	      slot = s7_slot(sc, a2);
	      if ((is_slot(slot)) && 
		  (is_integer(slot_value(slot))))
		{
		  s7_xf_store(sc, slot);
		  return(TEST_SS);
		}
	    }
	  else
	    {
	      if (s7_arg_to_if(sc, a1))
		return(TEST_SI);
	    }
	  return(TEST_SQ);
	}
    }
  return(TEST_NO_S);
}

static s7_pointer c_string_set_s(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
  if (!s7_is_character(val))
    method_or_bust(sc, val, sc->string_set_symbol, list_3(sc, vec, make_integer(sc, index), val), T_CHARACTER, 3);    
  if ((index < 0) ||
      (index >= string_length(vec)))
    return(out_of_range(sc, sc->string_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));

  string_value(vec)[index] = (char)character(val);
  return(val);
}

static s7_pointer c_string_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
  if (!s7_is_string(vec))
    method_or_bust(sc, vec, sc->string_set_symbol, set_plist_3(sc, vec, make_integer(sc, index), val), T_STRING, 1);
  return(c_string_set_s(sc, vec, index, val));
}

PIPF_TO_PF(string_set, c_string_set_s, c_string_set, c_string_tester)


/* -------------------------------- string-append -------------------------------- */
static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, bool use_temp)
{
  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))
    {
      s7_pointer p;
      p = car(x);
      if (!is_string(p))
	{
	  /* look for string-append and if found, cobble up a plausible intermediate call */
	  if (has_methods(p))
	    {
	      s7_pointer func;
	      func = find_method(sc, find_let(sc, p), sc->string_append_symbol);
	      if (func != sc->undefined)
		{
		  s7_pointer y;
		  if (len == 0)
		    return(s7_apply_function(sc, func, args));
		  newstr = make_empty_string(sc, len, 0);
		  for (pos = string_value(newstr), y = args; y != x; pos += string_length(car(y)), y = cdr(y))
		    memcpy(pos, string_value(car(y)), string_length(car(y)));
		  return(s7_apply_function(sc, func, cons(sc, newstr, x)));
		}
	    }
	  return(wrong_type_argument(sc, sc->string_append_symbol, position_of(x, args), p, T_STRING));
	}
      len += string_length(p);
    }

  if (use_temp)
    {
      newstr = sc->tmp_strs[0];
      prepare_temporary_string(sc, len + 1, 0);
      string_length(newstr) = len;
      string_value(newstr)[len] = 0;
    }
  else
    {
      /* store the contents of the argument strings into the new string */
      newstr = make_empty_string(sc, len, 0);
    }
  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)));

  if (is_byte_vector(car(args)))
    set_byte_vector(newstr);

  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"
  #define Q_string_append pcl_s
  return(g_string_append_1(sc, args, false));
}

static s7_pointer string_append_to_temp;
static s7_pointer g_string_append_to_temp(s7_scheme *sc, s7_pointer args)
{
  return(g_string_append_1(sc, args, true));
}


#if (!WITH_PURE_S7)
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"
  #define Q_string_copy s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_string_symbol)
  s7_pointer p;
  p = car(args);
  if (!is_string(p))
    method_or_bust(sc, p, sc->string_copy_symbol, args, T_STRING, 1);
  return(s7_make_string_with_length(sc, string_value(p), string_length(p)));
}
#endif


/* -------------------------------- substring -------------------------------- */
static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer fallback,
				s7_pointer start_and_end_args, s7_pointer 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, p;
  s7_int index;

#if DEBUGGING
  if (is_null(start_and_end_args))
    {
      fprintf(stderr, "start_and_end args is null\n");
      return(sc->gc_nil);
    }
#endif

  pstart = car(start_and_end_args);
  if (!s7_is_integer(pstart))
    {
      if (!s7_is_integer(p = check_values(sc, pstart, start_and_end_args)))
	{
	  check_two_methods(sc, pstart, caller, fallback, args);
	  return(wrong_type_argument(sc, caller, position, pstart, T_INTEGER));
	}
      else pstart = p;
    }

  index = s7_integer(pstart);
  if ((index < 0) ||
      (index > *end)) /* *end == length here */
    return(out_of_range(sc, caller, small_int(position), pstart, (index < 0) ? its_negative_string : its_too_large_string));
  *start = index;

  if (is_null(cdr(start_and_end_args)))
    return(sc->gc_nil);

  pend = cadr(start_and_end_args);
  if (!s7_is_integer(pend))
    {
      if (!s7_is_integer(p = check_values(sc, pend, cdr(start_and_end_args))))
	{
	  check_two_methods(sc, pend, caller, fallback,
			    (position == 2) ? list_3(sc, car(args), pstart, pend) : list_4(sc, car(args), cadr(args), pstart, pend));
	  return(wrong_type_argument(sc, caller, position + 1, pend, T_INTEGER));
	}
      else pend = p;
    }
  index = s7_integer(pend);
  if ((index < *start) ||
      (index > *end))
    return(out_of_range(sc, caller, small_int(position + 1), pend, (index < *start) ? its_too_small_string : its_too_large_string));
  *end = index;
  return(sc->gc_nil);
}


static s7_pointer g_substring(s7_scheme *sc, s7_pointer args)
{
  #define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \
end: (substring \"01234\" 1 2) -> \"1\""
  #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)

  s7_pointer x, str;
  s7_int start = 0, end;
  int len;
  char *s;

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->substring_symbol, args, T_STRING, 1);

  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      x = start_and_end(sc, sc->substring_symbol, NULL, cdr(args), args, 2, &start, &end);
      if (x != sc->gc_nil) return(x);
    }
  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))
    method_or_bust(sc, str, sc->substring_symbol, args, T_STRING, 1);

  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      s7_pointer x;
      x = start_and_end(sc, sc->substring_symbol, NULL, cdr(args), args, 2, &start, &end);
      if (x != sc->gc_nil) return(x);
    }
  return(make_temporary_string(sc, (const char *)(string_value(str) + start), (int)(end - start)));
}


/* -------------------------------- object->string -------------------------------- */
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_symbol) 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."
  #define Q_object_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->T, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol))

  use_write_t choice;
  char *str;
  s7_pointer obj;
  int len = 0;

  if (is_not_null(cdr(args)))
    {
      choice = write_choice(sc, cadr(args));
      if (choice == USE_WRITE_WRONG)
	method_or_bust(sc, cadr(args), sc->object_to_string_symbol, args, T_BOOLEAN, 2);
    }
  else choice = USE_WRITE;
  /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */

  obj = car(args);
  check_method(sc, obj, sc->object_to_string_symbol, args);
  str = s7_object_to_c_string_1(sc, obj, choice, &len);
  if (str)
    return(make_string_uncopied_with_length(sc, str, len));
  return(s7_make_string_with_length(sc, "", 0));
}

static s7_pointer c_object_to_string(s7_scheme *sc, s7_pointer x) {return(g_object_to_string(sc, set_plist_1(sc, x)));}
PF_TO_PF(object_to_string, c_object_to_string)


/* -------------------------------- string comparisons -------------------------------- */
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 bool is_string_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_string(p))
    return(true);
  if (has_methods(p))
    {
      s7_pointer f;
      f = find_method(sc, find_let(sc, p), sc->is_string_symbol);
      if (f != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
    }
  return(false);
}

static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int val, s7_pointer sym)
{
  s7_pointer x, y;

  y = car(args);
  if (!is_string(y))
    method_or_bust(sc, y, sym, args, T_STRING, 1);

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!is_string(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args));
      if (scheme_strcmp(y, car(x)) != val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_string_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING));
	  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;

  y = car(args);
  if (!is_string(y))
    method_or_bust(sc, y, sym, args, T_STRING, 1);

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!is_string(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args));
      if (scheme_strcmp(y, car(x)) == val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_string_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING));
	  return(sc->F);
	}
      y = car(x);
    }
  return(sc->T);
}


static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y)
{
  return((string_length(x) == string_length(y)) &&
	 (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x))));
}


static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal"
  #define Q_strings_are_equal pcl_bs

  /* C-based check stops at null, but we can have embedded nulls.
   *   (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2))
   */
  s7_pointer x, y;
  bool happy = true;

  y = car(args);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_eq_symbol, args, T_STRING, 1);

  for (x = cdr(args); is_pair(x); x = cdr(x))
    {
      s7_pointer p;
      p = car(x);
      if (y != p)
	{
	  if (!is_string(p))
	    method_or_bust(sc, p, sc->string_eq_symbol, cons(sc, y, x), T_STRING, position_of(x, args));
	  if (happy)
	    happy = scheme_strings_are_equal(p, y);
	}
    }
  if (!happy)
    return(sc->F);
  return(sc->T);
}

static s7_pointer c_string_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{ 
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_eq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_eq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, ((string_length(x) == string_length(y)) &&
			   (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x))))));
}

PF2_TO_PF(string_eq, c_string_eq)


static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args)
{
  #define H_strings_are_less "(string<? str ...) returns #t if all the string arguments are increasing"
  #define Q_strings_are_less pcl_bs

  return(g_string_cmp(sc, args, -1, sc->string_lt_symbol));
}

static s7_pointer c_string_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_lt_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_lt_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(x, y) == -1));
}

PF2_TO_PF(string_lt, c_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"
  #define Q_strings_are_greater pcl_bs

  return(g_string_cmp(sc, args, 1, sc->string_gt_symbol));
}

static s7_pointer c_string_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_gt_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_gt_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(x, y) == 1));
}

PF2_TO_PF(string_gt, c_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"
  #define Q_strings_are_geq pcl_bs

  return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol));
}

static s7_pointer c_string_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_geq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_geq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(x, y) != -1));
}

PF2_TO_PF(string_geq, c_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"
  #define Q_strings_are_leq pcl_bs

  return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol));
}

static s7_pointer c_string_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_leq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_leq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(x, y) != 1));
}

PF2_TO_PF(string_leq, c_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)))
    method_or_bust(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1);
  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)))
    method_or_bust(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1);
  if (!is_string(cadr(args)))
    method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, T_STRING, 2);
  return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
}


static s7_pointer string_less_2;
static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    method_or_bust(sc, car(args), sc->string_lt_symbol, args, T_STRING, 1);
  if (!is_string(cadr(args)))
    method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
}


static s7_pointer string_greater_2;
static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args)
{
  if (!is_string(car(args)))
    method_or_bust(sc, car(args), sc->string_gt_symbol, args, T_STRING, 1);
  if (!is_string(cadr(args)))
    method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, T_STRING, 2);
  return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
}


#if (!WITH_PURE_S7)

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;
  unsigned char *str1, *str2;

  len1 = string_length(s1);
  len2 = string_length(s2);
  if (len1 > len2)
    len = len2;
  else len = len1;

  str1 = (unsigned char *)string_value(s1);
  str2 = (unsigned char *)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;
  unsigned char *str1, *str2;

  len = string_length(s1);
  len2 = string_length(s2);
  if (len != len2)
    return(false);

  str1 = (unsigned char *)string_value(s1);
  str2 = (unsigned char *)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;

  y = car(args);
  if (!is_string(y))
    method_or_bust(sc, y, sym, args, T_STRING, 1);

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!is_string(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args));
      if (val == 0)
	{
	  if (!scheme_strequal_ci(y, car(x)))
	    {
	      for (y = cdr(x); is_pair(y); y = cdr(y))
		if (!is_string_via_method(sc, car(y)))
		  return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING));
	      return(sc->F);
	    }
	}
      else
	{
	  if (scheme_strcasecmp(y, car(x)) != val)
	    {
	      for (y = cdr(x); is_pair(y); y = cdr(y))
		if (!is_string_via_method(sc, car(y)))
		  return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING));
	      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;

  y = car(args);
  if (!is_string(y))
    method_or_bust(sc, y, sym, args, T_STRING, 1);

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!is_string(car(x)))
	method_or_bust(sc, car(x), sym, cons(sc, y, x), T_STRING, position_of(x, args));
      if (scheme_strcasecmp(y, car(x)) == val)
	{
	  for (y = cdr(x); is_pair(y); y = cdr(y))
	    if (!is_string_via_method(sc, car(y)))
	      return(wrong_type_argument(sc, sym, position_of(y, args), car(y), T_STRING));
	  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"
  #define Q_strings_are_ci_equal pcl_bs
  return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol));
}

static s7_pointer c_string_ci_eq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_ci_eq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_ci_eq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcasecmp(x, y) == 0));
}

PF2_TO_PF(string_ci_eq, c_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"
  #define Q_strings_are_ci_less pcl_bs
  return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol));
}

static s7_pointer c_string_ci_lt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_ci_lt_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_ci_lt_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcasecmp(x, y) == -1));
}

PF2_TO_PF(string_ci_lt, c_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"
  #define Q_strings_are_ci_greater pcl_bs
  return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol));
}

static s7_pointer c_string_ci_gt(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_ci_gt_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_ci_gt_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcasecmp(x, y) == 1));
}

PF2_TO_PF(string_ci_gt, c_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"
  #define Q_strings_are_ci_geq pcl_bs
  return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol));
}

static s7_pointer c_string_ci_geq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_ci_geq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_ci_geq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcasecmp(x, y) != -1));
}

PF2_TO_PF(string_ci_geq, c_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"
  #define Q_strings_are_ci_leq pcl_bs
  return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol));
}

static s7_pointer c_string_ci_leq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_string(x))
    method_or_bust(sc, x, sc->string_ci_leq_symbol, list_2(sc, x, y), T_STRING, 1);
  if (!is_string(y))
    method_or_bust(sc, y, sc->string_ci_leq_symbol, list_2(sc, x, y), T_STRING, 2);
  return(make_boolean(sc, scheme_strcasecmp(x, y) != 1));
}

PF2_TO_PF(string_ci_leq, c_string_ci_leq)
#endif /* pure s7 */


static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr"
  #define Q_string_fill s7_make_circular_signature(sc, 3, 4, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol)

  s7_pointer x, chr;
  s7_int start = 0, end, byte = 0;
  x = car(args);

  if (!is_string(x))
    method_or_bust(sc, x, sc->string_fill_symbol, args, T_STRING, 1); /* not two methods here */

  chr = cadr(args);
  if (!is_byte_vector(x))
    {
      if (!s7_is_character(chr))
	{
	  check_two_methods(sc, chr, sc->string_fill_symbol, sc->fill_symbol, args);
	  return(wrong_type_argument(sc, sc->string_fill_symbol, 2, chr, T_CHARACTER));
	}
    }
  else
    {
      if (!is_integer(chr))
	{
	  check_two_methods(sc, chr, sc->string_fill_symbol, sc->fill_symbol, args);
	  return(wrong_type_argument(sc, sc->fill_symbol, 2, chr, T_INTEGER));
	}
      byte = integer(chr);
      if ((byte < 0) || (byte > 255))
	return(simple_wrong_type_argument_with_type(sc, sc->string_fill_symbol, chr, an_unsigned_byte_string));
    }

  end = string_length(x);
  if (!is_null(cddr(args)))
    {
      s7_pointer p;
      p = start_and_end(sc, sc->string_fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
      if (p != sc->gc_nil) return(p);
      if (start == end) return(chr);
    }
  if (end == 0) return(chr);

  if (!is_byte_vector(x))
    memset((void *)(string_value(x) + start), (int)character(chr), end - start);
  else memset((void *)(string_value(x) + start), (int)byte, end - start);

  return(chr);
}

#if (!WITH_PURE_S7)
static s7_pointer c_string_fill(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_string_fill(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(string_fill, c_string_fill)
#endif


static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
{
  int i, len;
  s7_pointer x, newstr;
  char *str;

  /* get length for new string and check arg types */
  for (len = 0, x = args; is_not_null(x); len++, x = cdr(x))
    {
      s7_pointer p;
      p = car(x);
      if (!s7_is_character(p))
	{
	  if (has_methods(p))
	    {
	      s7_pointer func;
	      func = find_method(sc, find_let(sc, p), sym);
	      if (func != sc->undefined)
		{
		  s7_pointer y;
		  if (len == 0)
		    return(s7_apply_function(sc, func, args));
		  newstr = make_empty_string(sc, len, 0);
		  str = string_value(newstr);
		  for (i = 0, y = args; y != x; i++, y = cdr(y))
		    str[i] = character(car(y));
		  return(g_string_append(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, x))));
		}
	    }
	  return(wrong_type_argument(sc, sym, len + 1, car(x), T_CHARACTER));
	}
    }
  newstr = make_empty_string(sc, len, 0);
  str = string_value(newstr);
  for (i = 0, x = args; is_not_null(x); i++, x = cdr(x))
    str[i] = character(car(x));

  return(newstr);
}


static s7_pointer g_string(s7_scheme *sc, s7_pointer args)
{
  #define H_string "(string chr...) appends all its character arguments into one string"
  #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol)

  if (is_null(args))                                /* (string) but not (string ()) */
    return(s7_make_string_with_length(sc, "", 0));
  return(g_string_1(sc, args, sc->string_symbol));
}

#if (!WITH_PURE_S7)
static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)"
  #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol)

  if (is_null(car(args)))
    return(s7_make_string_with_length(sc, "", 0));

  if (!is_proper_list(sc, car(args)))
    method_or_bust_with_type(sc, car(args), sc->list_to_string_symbol, args, make_string_wrapper(sc, "a (proper, non-circular) list of characters"), 0);
  return(g_string_1(sc, car(args), sc->list_to_string_symbol));
}
#endif

static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, int len)
{
  int i;
  s7_pointer result;

  if (len == 0) 
    return(sc->nil);
  if (len >= (sc->free_heap_top - sc->free_heap))
    {
      gc(sc);
      while (len >= (sc->free_heap_top - sc->free_heap))
	resize_heap(sc);
    }

  sc->v = sc->nil;
  for (i = len - 1; i >= 0; i--)
    sc->v = cons_unchecked(sc, s7_make_character(sc, ((unsigned char)str[i])), sc->v);
  result = sc->v;
  sc->v = sc->nil;
  return(result);
}

#if (!WITH_PURE_S7)
static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)"
  #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol)

  s7_int i, start = 0, end;
  s7_pointer p, str;

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->string_to_list_symbol, args, T_STRING, 0);

  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      p = start_and_end(sc, sc->string_to_list_symbol, NULL, cdr(args), args, 2, &start, &end);
      if (p != sc->gc_nil) return(p);
      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);
}

static s7_pointer c_string_to_list(s7_scheme *sc, s7_pointer x) {return(g_string_to_list(sc, set_plist_1(sc, x)));}
PF_TO_PF(string_to_list, c_string_to_list)
#endif


/* -------------------------------- byte_vectors --------------------------------
 *
 * these are just strings with the T_BYTE_VECTOR bit set.
 */

static bool s7_is_byte_vector(s7_pointer b) {return((is_string(b)) && (is_byte_vector(b)));}

static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector"
  #define Q_is_byte_vector pl_bt

  check_boolean_method(sc, s7_is_byte_vector, sc->is_byte_vector_symbol, args);
}


static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector."
  #define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol)
  s7_pointer str;
  str = car(args);
  if (is_integer(str))
    str = s7_make_string_with_length(sc, (const char *)(&(integer(str))), sizeof(s7_int));
  else
    {
      if (!is_string(str))
	method_or_bust(sc, str, sc->string_to_byte_vector_symbol, set_plist_1(sc, str), T_STRING, 1);
    }
  set_byte_vector(str);
  return(str);
}

static s7_pointer c_string_to_byte_vector(s7_scheme *sc, s7_pointer str) {return(g_string_to_byte_vector(sc, set_plist_1(sc, str)));}

PF_TO_PF(string_to_byte_vector, c_string_to_byte_vector)


static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte."
  #define Q_make_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_integer_symbol)

  s7_pointer str;
  if (is_null(cdr(args)))
    {
      str = g_make_string(sc, args);
      if (is_string(str))
	memclr((void *)(string_value(str)), string_length(str));
    }
  else
    {
      s7_pointer len, byte;
      s7_int b;
      len = car(args);
      if (!is_integer(len))
	method_or_bust(sc, len, sc->make_byte_vector_symbol, args, T_INTEGER, 1);

      byte = cadr(args);
      if (!s7_is_integer(byte))
	method_or_bust(sc, byte, sc->make_byte_vector_symbol, args, T_INTEGER, 2);

      b = s7_integer(byte);
      if ((b < 0) || (b > 255))
	return(simple_wrong_type_argument_with_type(sc, sc->make_byte_vector_symbol, byte, an_unsigned_byte_string));
      str = g_make_string(sc, set_plist_2(sc, len, chars[b]));
    }
  set_byte_vector(str);
  return(str);
}


static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments"
  #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_integer_symbol)

  s7_int i, len;
  s7_pointer vec, x;
  char *str;

  len = s7_list_length(sc, args);
  vec = make_empty_string(sc, len, 0);
  str = string_value(vec);

  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))
	{
	  if (has_methods(byte))
	    {
	      s7_pointer func;
	      func = find_method(sc, find_let(sc, byte), sc->byte_vector_symbol);
	      if (func != sc->undefined)
		{
		  if (i == 0)
		    return(s7_apply_function(sc, func, args));
		  string_length(vec) = i;
		  vec = g_string_append(sc, set_plist_2(sc, vec, s7_apply_function(sc, func, x)));
		  set_byte_vector(vec);
		  return(vec);
		}
	    }
	  return(wrong_type_argument(sc, sc->byte_vector_symbol, i + 1, byte, T_INTEGER));
	}
      b = s7_integer(byte);
      if ((b < 0) || (b > 255))
	return(simple_wrong_type_argument_with_type(sc, sc->byte_vector_symbol, byte, an_unsigned_byte_string));
      str[i] = (unsigned char)b;
    }
  set_byte_vector(vec);
  return(vec);
}

static s7_pointer byte_vector_to_list(s7_scheme *sc, const char *str, int len)
{
  int i;
  s7_pointer p;
  if (len == 0) return(sc->nil);
  sc->w = sc->nil;
  for (i = len - 1; i >= 0; i--)
    sc->w = cons(sc, small_int((unsigned int)((unsigned char)(str[i]))), sc->w); /* extra cast is not redundant! */
  p = sc->w;
  sc->w = sc->nil;
  return(p);
}



/* -------------------------------- 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."
  #define Q_is_port_closed pl_bt
  s7_pointer x;

  x = car(args);
  if ((is_input_port(x)) || (is_output_port(x)))
    return(make_boolean(sc, port_is_closed(x)));

  method_or_bust_with_type(sc, x, sc->is_port_closed_symbol, args, make_string_wrapper(sc, "a port"), 0);
}


static s7_pointer c_port_line_number(s7_scheme *sc, s7_pointer x)
{
  if ((!(is_input_port(x))) ||
      (port_is_closed(x)))
    method_or_bust_with_type(sc, x, sc->port_line_number_symbol, list_1(sc, x), an_input_port_string, 0);
  return(make_integer(sc, port_line_number(x)));
}

static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args)
{
  #define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port"
  #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_null_symbol))

  if ((is_null(args)) || (is_null(car(args))))
    return(c_port_line_number(sc, sc->input_port));
  return(c_port_line_number(sc, car(args)));
}

PF_TO_PF(port_line_number, c_port_line_number)

int s7_port_line_number(s7_pointer p)
{
  if (is_input_port(p))
    return(port_line_number(p));
  return(0);
}

static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, line;

  if ((is_null(car(args))) || 
      ((is_null(cdr(args))) && (is_integer(car(args)))))
    p = sc->input_port;
  else 
    {
      p = car(args);
      if (!(is_input_port(p)))
	return(s7_wrong_type_arg_error(sc, "set! port-line-number", 1, p, "an input port"));
    }

  line = (is_null(cdr(args)) ? car(args) : cadr(args));
  if (!is_integer(line))
    return(s7_wrong_type_arg_error(sc, "set! port-line-number", 2, line, "an integer"));
  port_line_number(p) = integer(line);
  return(line);
}


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 c_port_filename(s7_scheme *sc, s7_pointer x)
{
  if (((is_input_port(x)) ||
       (is_output_port(x))) &&
      (!port_is_closed(x)))
    {
      if (port_filename(x))
	return(make_string_wrapper_with_length(sc, port_filename(x), port_filename_length(x)));
      return(s7_make_string_with_length(sc, "", 0));
      /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
    }
  method_or_bust_with_type(sc, x, sc->port_filename_symbol, list_1(sc, x), an_open_port_string, 0);
}

static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args)
{
  #define H_port_filename "(port-filename file-port) returns the filename associated with port"
  #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, sc->T)

  if (is_null(args))
    return(c_port_filename(sc, sc->input_port));
  return(c_port_filename(sc, car(args)));
}

PF_TO_PF(port_filename, c_port_filename)


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"
  #define Q_is_input_port pl_bt
  check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, 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"
  #define Q_is_output_port pl_bt
  check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, 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"
  #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol)
  return(sc->input_port);
}

#if (!WITH_PURE_S7)
static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port"
  #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol)

  s7_pointer 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
    {
      check_method(sc, port, s7_make_symbol(sc, "set-current-input-port"), args);
      return(s7_wrong_type_arg_error(sc, "set-current-input-port", 0, port, "an open input port"));
    }
  return(old_port);
}
#endif

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"
  #define Q_current_output_port s7_make_signature(sc, 1, sc->is_output_port_symbol)
  return(sc->output_port);
}

#if (!WITH_PURE_S7)
static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
  #define Q_set_current_output_port s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_output_port_symbol)

  s7_pointer old_port, port;
  old_port = sc->output_port;
  port = car(args);
  if (((is_output_port(port)) &&
       (!port_is_closed(port))) ||
      (port == sc->F))
    sc->output_port = port;
  else
    {
      check_method(sc, port, s7_make_symbol(sc, "set-current-output-port"), args);
      return(s7_wrong_type_arg_error(sc, "set-current-output-port", 0, port, "an open output port"));
    }
  return(old_port);
}
#endif

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"
  #define Q_current_error_port s7_make_signature(sc, 1, sc->is_output_port_symbol)
  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"
  #define Q_set_current_error_port s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_output_port_symbol)
  s7_pointer old_port, port;

  old_port = sc->error_port;
  port = car(args);
  if (((is_output_port(port)) &&
       (!port_is_closed(port))) ||
      (port == sc->F))
    sc->error_port = port;
  else
    {
      check_method(sc, port, s7_make_symbol(sc, "set-current-error-port"), args);
      return(s7_wrong_type_arg_error(sc, "set-current-error-port", 0, port, "an open output port"));
    }
  return(old_port);
}


#if (!WITH_PURE_S7)
static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args)
{
  #define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port"
  #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol)
  if (is_not_null(args))
    {
      s7_pointer pt = car(args);
      if (!is_input_port(pt))
	method_or_bust_with_type(sc, pt, sc->is_char_ready_symbol, args, an_input_port_string, 0);
      if (port_is_closed(pt))
	return(simple_wrong_type_argument_with_type(sc, sc->is_char_ready_symbol, pt, an_open_port_string));

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


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"
  #define Q_is_eof_object pl_bt
  check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args);
}


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, bool copied);
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 DEBUGGING
  if (!is_input_port(p))
    fprintf(stderr, "s7_close_input_port: %s\n", DISPLAY(p));
#endif
  if ((is_immutable_port(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))
    {
      if (port_file(p))
	{
	  fclose(port_file(p));
	  port_file(p) = NULL;
	}
    }
  else
    {
      if ((is_string_port(p)) &&
	  (port_gc_loc(p) != -1))
	s7_gc_unprotect_at(sc, port_gc_loc(p));
    }
  if (port_needs_free(p))
    {
      if (port_data(p))
	{
	  free(port_data(p));
	  port_data(p) = NULL;
	  port_data_size(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 c_close_input_port(s7_scheme *sc, s7_pointer pt)
{
  if (!is_input_port(pt))
    method_or_bust_with_type(sc, pt, sc->close_input_port_symbol, set_plist_1(sc, pt), an_input_port_string, 0);
  if (!is_immutable_port(pt))
    s7_close_input_port(sc, pt);
  return(sc->unspecified);
}

static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args)
{
  #define H_close_input_port "(close-input-port port) closes the port"
  #define Q_close_input_port s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)
  return(c_close_input_port(sc, car(args)));
}

PF_TO_PF(close_input_port, c_close_input_port)


void s7_flush_output_port(s7_scheme *sc, s7_pointer p)
{
  if ((!is_output_port(p)) ||
      (!is_file_port(p)) ||
      (port_is_closed(p)) ||
      (p == sc->F))
    return;

  if (port_file(p))
    {
      if (port_position(p) > 0)
	{
	  if (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != port_position(p))
	    s7_warn(sc, 64, "fwrite trouble in flush-output-port\n");
	  port_position(p) = 0;
	}
      fflush(port_file(p));
    }
}


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"
  #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
  s7_pointer pt;

  if (is_null(args))
    pt = sc->output_port;
  else pt = car(args);

  if (!is_output_port(pt))
    {
      if (pt == sc->F) return(pt);
      method_or_bust_with_type(sc, pt, sc->flush_output_port_symbol, args, an_output_port_string, 0);
    }
  s7_flush_output_port(sc, pt);
  return(pt);
}

static s7_pointer c_flush_output_port(s7_scheme *sc) {return(g_flush_output_port(sc, sc->nil));}
PF_0(flush_output_port, c_flush_output_port)

static void close_output_port(s7_scheme *sc, s7_pointer p)
{
  if (is_file_port(p))
    {
      if (port_filename(p)) /* only a file (output) port has a filename */
	{
	  free(port_filename(p));
	  port_filename(p) = NULL;
	  port_filename_length(p) = 0;
	}

      if (port_file(p))
	{
	  if (port_position(p) > 0)
	    {
	      if (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != port_position(p))
		s7_warn(sc, 64, "fwrite trouble in close-output-port\n");
	      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_data(p)))
	{
	  free(port_data(p));
	  port_data(p) = NULL;
	  port_data_size(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;
}

void s7_close_output_port(s7_scheme *sc, s7_pointer p)
{
  if ((is_immutable_port(p)) ||
      ((is_output_port(p)) && (port_is_closed(p))) ||
      (p == sc->F))
    return;
  close_output_port(sc, p);
}


static s7_pointer c_close_output_port(s7_scheme *sc, s7_pointer pt)
{
  if (!is_output_port(pt))
    {
      if (pt == sc->F) return(sc->unspecified);
      method_or_bust_with_type(sc, pt, sc->close_output_port_symbol, set_plist_1(sc, pt), an_output_port_string, 0);
    }
  if (!(is_immutable_port(pt)))
    s7_close_output_port(sc, pt);
  return(sc->unspecified);
}

static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args)
{
  #define H_close_output_port "(close-output-port port) closes the port"
  #define Q_close_output_port s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
  return(c_close_output_port(sc, car(args)));
}

PF_TO_PF(close_output_port, c_close_output_port)


/* -------- 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_data_size(port) <= port_position(port)) /* port_string_length is 0 if no port string */
    return(EOF);
  return((unsigned char)port_data(port)[port_position(port)++]);
}


static int output_read_char(s7_scheme *sc, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, an_input_port_string);
  return(0);
}


static int closed_port_read_char(s7_scheme *sc, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, an_open_port_string);
  return(0);
}



/* -------- read line functions -------- */

static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol, bool copied)
{
  return(simple_wrong_type_argument_with_type(sc, sc->read_line_symbol, port, an_input_port_string));
}


static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol, bool copied)
{
  return(simple_wrong_type_argument_with_type(sc, sc->read_line_symbol, port, an_open_port_string));
}


static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol, bool copied)
{
  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, bool copied)
{
  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, bool copied)
{
  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_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_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, bool copied)
{
  unsigned int i, port_start;
  unsigned char *port_str, *cur, *start;

  port_start = port_position(port);
  port_str = port_data(port);
  start = (unsigned char *)(port_str + port_start);

  cur = (unsigned char *)strchr((const char *)start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */
  if (cur)
      {
	port_line_number(port)++;
	i = cur - port_str;
	port_position(port) = i + 1;
	if (copied)
	  return(s7_make_string_with_length(sc, (const char *)start, ((with_eol) ? i + 1 : i) - port_start));
	return(make_string_wrapper_with_length(sc, (char *)start, ((with_eol) ? i + 1 : i) - port_start));
      }
  i = port_data_size(port);
  port_position(port) = i;
  if (i <= port_start)         /* the < part can happen -- if not caught we try to create a string of length -1 -> segfault */
    return(sc->eof_object);

  if (copied)
    return(s7_make_string_with_length(sc, (const char *)start, i - port_start));
  return(make_string_wrapper_with_length(sc, (char *)start, i - port_start));
}


/* -------- write character functions -------- */

static void resize_port_data(s7_pointer pt, int new_size)
{
  int loc;
  loc = port_data_size(pt);
  port_data_size(pt) = new_size;
  port_data(pt) = (unsigned char *)realloc(port_data(pt), new_size * sizeof(unsigned char));
  memclr((void *)(port_data(pt) + loc), new_size - loc);
}

static void string_write_char(s7_scheme *sc, int c, s7_pointer pt)
{
  if (port_position(pt) >= port_data_size(pt))
    resize_port_data(pt, port_data_size(pt) * 2);
  port_data(pt)[port_position(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)
    {
      if (fwrite((void *)(port_data(port)), 1, PORT_DATA_SIZE, port_file(port)) != PORT_DATA_SIZE)
	s7_warn(sc, 64, "fwrite trouble during write-char\n");
      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_symbol, port, an_output_port_string);
}


static void closed_port_write_char(s7_scheme *sc, int c, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_open_port_string);
}



/* -------- 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_symbol, port, an_output_port_string);
}


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_symbol, port, an_open_port_string);
}


static void input_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_output_port_string);
}

static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, an_open_port_string);
}

static void stdout_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  if (str[len] == '\0')
    fputs(str, stdout);
  else
    {
      int i;
      for (i = 0; i < len; i++)
	fputc(str[i], stdout);
    }
}

static void stderr_write_string(s7_scheme *sc, const char *str, int len, s7_pointer port)
{
  if (str[len] == '\0')
    fputs(str, stderr);
  else
    {
      int i;
      for (i = 0; i < len; i++)
	fputc(str[i], 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 */

  new_len = port_position(pt) + len;
  if (new_len >= (int)port_data_size(pt))
    resize_port_data(pt, new_len * 2);

  memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len);
  /* memcpy is much faster than the equivalent while loop */
  port_position(pt) = new_len;
}


static s7_pointer write_string_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return(f);
}


static void file_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s)
    {
      if (port_position(port) > 0)
	{
	  if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != port_position(port))
	    s7_warn(sc, 64, "fwrite trouble in display\n");
	  port_position(port) = 0;
	}
      if (fputs(s, port_file(port)) == EOF)
	s7_warn(sc, 64, "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)
{
  int new_len;
  new_len = port_position(pt) + len;
  if (new_len >= PORT_DATA_SIZE)
    {
      if (port_position(pt) > 0)
	{
	  if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != port_position(pt))
	    s7_warn(sc, 64, "fwrite trouble in write-string\n");
	  port_position(pt) = 0;
	}
      if (fwrite((void *)str, 1, len, port_file(pt)) != (size_t)len)
	s7_warn(sc, 64, "fwrite trouble in write-string\n");
    }
  else
    {
      memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len);
      port_position(pt) = new_len;
    }
}

static void string_display(s7_scheme *sc, const char *s, s7_pointer port)
{
  if (s)
    string_write_string(sc, s, safe_strlen(s), port);
}


static void 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)
{
  int i;
  for (i = 0; i < len; i++)
    (*(port_output_function(pt)))(sc, str[i], 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."
  #define Q_write_string s7_make_circular_signature(sc, 3, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_output_port_symbol, sc->is_integer_symbol)
  s7_pointer str, port;
  s7_int start = 0, end;

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->write_string_symbol, args, T_STRING, 1);

  end = string_length(str);
  if (!is_null(cdr(args)))
    {
      s7_pointer inds;
      port = cadr(args);
      inds = cddr(args);
      if (!is_null(inds))
	{
	  s7_pointer p;
	  p = start_and_end(sc, sc->write_string_symbol, NULL, inds, args, 3, &start, &end);
	  if (p != sc->gc_nil) return(p);
	}
    }
  else port = sc->output_port;
  if (!is_output_port(port))
    {
      if (port == sc->F)
	{
	  s7_pointer x;
	  int len;
	  if ((start == 0) && (end == string_length(str)))
	    return(str);
	  len = (int)(end - start);
	  x = s7_make_string_with_length(sc, (char *)(string_value(str) + start), len);
	  string_value(x)[len] = 0;
	  return(x);
	}
      method_or_bust_with_type(sc, port, sc->write_string_symbol, args, an_output_port_string, 2);
    }

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

static s7_pointer c_write_string(s7_scheme *sc, s7_pointer x) {return(g_write_string(sc, set_plist_1(sc, x)));}
PF_TO_PF(write_string, c_write_string)



/* -------- skip to newline 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_data(pt) + port_position(pt));
  orig_str = strchr(str, (int)'\n');
  if (!orig_str)
    {
      port_position(pt) = port_data_size(pt);
      return(TOKEN_EOF);
    }
  port_position(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */
  port_line_number(pt)++;
  return(token(sc));
}


/* -------- white space readers -------- */

static 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 terminated_string_read_white_space(s7_scheme *sc, s7_pointer pt)
{
  const unsigned char *str;
  unsigned char c;
  /* here we know we have null termination and white_space[#\null] is false.
   */
  str = (const unsigned char *)(port_data(pt) + port_position(pt));

  while (white_space[c = *str++]) /* (let ((�a 1)) �a) -- 255 is not -1 = EOF */
    if (c == '\n')
      port_line_number(pt)++;
  if (c)
    port_position(pt) = str - port_data(pt);
  else port_position(pt) = port_data_size(pt);
  return((int)c);
}


/* name (alphanumeric token) readers */

static void resize_strbuf(s7_scheme *sc, unsigned int needed_size)
{
  unsigned int i, old_size;
  old_size = sc->strbuf_size;
  while (sc->strbuf_size <= needed_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_or_sharp(s7_scheme *sc, s7_pointer pt, bool atom_case)
{
  int c;
  unsigned int i = 1;
  /* sc->strbuf[0] has the first char of the string we're reading */

  do {
    c = fgetc(port_file(pt)); /* might return EOF */
    if (c == '\n')
      port_line_number(pt)++;

    sc->strbuf[i++] = c;
    if (i >= sc->strbuf_size)
      resize_strbuf(sc, i);
  } while ((c != EOF) && (char_ok_in_a_name[c]));

  if ((i == 2) &&
      (sc->strbuf[0] == '\\'))
    sc->strbuf[2] = '\0';
  else
    {
      if (c != EOF)
	{
	  if (c == '\n')
	    port_line_number(pt)--;
	  ungetc(c, port_file(pt));
	}
      sc->strbuf[i - 1] = '\0';
    }

  if (atom_case)
    return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));

  return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
}

static s7_pointer file_read_name(s7_scheme *sc, s7_pointer pt)
{
  return(file_read_name_or_sharp(sc, pt, true));
}

static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer pt)
{
  return(file_read_name_or_sharp(sc, pt, false));
}


static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt)
{
  /* sc->strbuf[0] has the first char of the string we're reading */
  unsigned int k;
  char *str, *orig_str;

  str = (char *)(port_data(pt) + port_position(pt));

  if (!char_ok_in_a_name[(unsigned char)*str])
    {
      s7_pointer result;
      result = sc->singletons[(unsigned char)(sc->strbuf[0])];
      if (!result)
	{
	  sc->strbuf[1] = '\0';
	  result = make_symbol_with_length(sc, sc->strbuf, 1);
	  sc->singletons[(unsigned char)(sc->strbuf[0])] = result;
	}
      return(result);
    }

  orig_str = (char *)(str - 1);
  str++;
  while (char_ok_in_a_name[(unsigned char)(*str)]) {str++;}
  k = str - orig_str;
  if (*str != 0)
    port_position(pt) += (k - 1);
  else port_position(pt) = port_data_size(pt);

  /* this is equivalent to:
   *    str = strpbrk(str, "(); \"\t\r\n");
   *    if (!str)
   *      {
   *        k = strlen(orig_str);
   *        str = (char *)(orig_str + k);
   *      }
   *    else k = str - orig_str;
   * but slightly faster.
   */

  if (!number_table[(unsigned char)(*orig_str)])
    return(make_symbol_with_length(sc, orig_str, k));

  /* eval_c_string string is a constant so we can't set and unset the token's end char */
  if ((k + 1) >= sc->strbuf_size)
    resize_strbuf(sc, k + 1);

  memcpy((void *)(sc->strbuf), (void *)orig_str, k);
  sc->strbuf[k] = '\0';
  return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));
}


static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt)
{
  /* sc->strbuf[0] has the first char of the string we're reading.
   *   since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe
   */
  unsigned int k;
  char *orig_str, *str;

  str = (char *)(port_data(pt) + port_position(pt));

  if (!char_ok_in_a_name[(unsigned char)*str])
    {
      if (sc->strbuf[0] == 'f')
	return(sc->F);
      if (sc->strbuf[0] == 't')
	return(sc->T);
      if (sc->strbuf[0] == '\\')
	{
	  /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
	  sc->strbuf[1] = str[0];
	  sc->strbuf[2] = '\0';
	  port_position(pt)++;
	}
      else sc->strbuf[1] = '\0';
      return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
    }

  orig_str = (char *)(str - 1);
  str++;
  while (char_ok_in_a_name[(unsigned char)(*str)]) {str++;}
  k = str - orig_str;
  if (*str != 0)
    port_position(pt) += (k - 1);
  else port_position(pt) += k;

  if ((k + 1) >= sc->strbuf_size)
    resize_strbuf(sc, k + 1);

  memcpy((void *)(sc->strbuf), (void *)orig_str, k);
  sc->strbuf[k] = '\0';
  return(make_sharp_constant(sc, sc->strbuf, UNNESTED_SHARP, BASE_10, WITH_OVERFLOW_ERROR));
}


static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt)
{
  /* port_string was allocated (and read from a file) so we can mess with it directly */
  s7_pointer result;
  unsigned int k;
  char *orig_str, *str;
  char endc;

  str = (char *)(port_data(pt) + port_position(pt));
  if (!char_ok_in_a_name[(unsigned char)*str])
    {
      s7_pointer result;
      result = sc->singletons[(unsigned char)(sc->strbuf[0])];
      if (!result)
	{
	  sc->strbuf[1] = '\0';
	  result = make_symbol_with_length(sc, sc->strbuf, 1);
	  sc->singletons[(unsigned char)(sc->strbuf[0])] = result;
	}
      return(result);
    }

  orig_str = (char *)(str - 1);
  str++;
  while (char_ok_in_a_name[(unsigned char)(*str)]) {str++;}
  k = str - orig_str;
  if (*str != 0)
    port_position(pt) += (k - 1);
  else port_position(pt) = port_data_size(pt);

  if (!number_table[(unsigned char)(*orig_str)])
    return(make_symbol_with_length(sc, orig_str, k));

  endc = (*str);
  (*str) = '\0';
  result = make_atom(sc, orig_str, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR);
  (*str) = endc;
  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, T_INPUT_PORT);
  port_loc = s7_gc_protect(sc, 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_length(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;
      unsigned char *content;

      content = (unsigned char *)malloc((size + 2) * sizeof(unsigned char));
      bytes = fread(content, sizeof(unsigned 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_data(port) = content;
      port_data_size(port) = size;
      port_position(port) = 0;
      port_needs_free(port) = true;
      port_gc_loc(port) = -1;
      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) = terminated_string_read_white_space;
      port_read_name(port) = string_read_name;
      port_read_sharp(port) = string_read_sharp;
    }
  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;
      port_read_sharp(port) = file_read_sharp; /* was string_read_sharp?? */
    }
#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;
  port_read_sharp(port) = file_read_sharp;
#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;
	      tmpbuf_malloc(filename, len);
	      snprintf(filename, len, "%s%s", home, (char *)(name + 1));
	      fp = fopen(filename, "r");
	      tmpbuf_free(filename, len);
	      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"
  #define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
  s7_pointer name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->open_input_file_symbol, args, T_STRING, 1);
  /* what if the file name is a byte-vector? currently we accept it */

  if (is_pair(cdr(args)))
    {
      s7_pointer mode;
      mode = cadr(args);
      if (!is_string(mode))
	method_or_bust_with_type(sc, mode, sc->open_input_file_symbol, args, make_string_wrapper(sc, "a string (a mode such as \"r\")"), 2);
      /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */
      return(open_input_file_1(sc, string_value(name), string_value(mode), "open-input-file"));
    }
  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();
  unheap(x);
  set_type(x, T_OUTPUT_PORT | T_IMMUTABLE);
  port_port(x) = (port_t *)calloc(1, sizeof(port_t));
  port_type(x) = FILE_PORT;
  port_data(x) = NULL;
  port_is_closed(x) = false;
  port_filename_length(x) = 8;
  port_filename(x) = copy_string_with_length("*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();
  unheap(x);
  set_type(x, T_OUTPUT_PORT | T_IMMUTABLE);
  port_port(x) = (port_t *)calloc(1, sizeof(port_t));
  port_type(x) = FILE_PORT;
  port_data(x) = NULL;
  port_is_closed(x) = false;
  port_filename_length(x) = 8;
  port_filename(x) = copy_string_with_length("*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();
  unheap(x);
  set_type(x, T_INPUT_PORT | T_IMMUTABLE);
  port_port(x) = (port_t *)calloc(1, sizeof(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_length("*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_read_sharp(x) = file_read_sharp;
  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, 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_length(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_size(x) = PORT_DATA_SIZE;
  port_data(x) = (unsigned char *)malloc(PORT_DATA_SIZE); /* was +8? */
  add_output_port(sc, x);
  return(x);
}


static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args)
{
  #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing"
  #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
  s7_pointer name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->open_output_file_symbol, args, T_STRING, 1);

  if (is_pair(cdr(args)))
    {
      if (!is_string(cadr(args)))
	method_or_bust_with_type(sc, cadr(args), sc->open_output_file_symbol, args, make_string_wrapper(sc, "a string (a mode such as \"w\")"), 2);
      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, 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_data(x) = (unsigned char *)input_string;
  port_data_size(x) = len;
  port_position(x) = 0;
  port_filename_length(x) = 0;
  port_filename(x) = NULL;
  port_file_number(x) = 0; /* unsigned int */
  port_line_number(x) = 0;
  port_needs_free(x) = false;
  port_gc_loc(x) = -1;
  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;
#if DEBUGGING
  if (input_string[len] != '\0')
    fprintf(stderr, "read_white_space string is not terminated: %s", input_string);
#endif
  port_read_white_space(x) = terminated_string_read_white_space;
  port_read_name(x) = string_read_name_no_free;
  port_read_sharp(x) = string_read_sharp;
  port_write_character(x) = input_write_char;
  port_write_string(x) = input_write_string;
  add_input_port(sc, x);
  return(x);
}


static s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str)
{
  s7_pointer p;
  p = open_input_string(sc, string_value(str), string_length(str));
  port_gc_loc(p) = s7_gc_protect(sc, str);
  return(p);
}


s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string)
{
  return(open_input_string(sc, input_string, safe_strlen(input_string)));
}


static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args)
{
  #define H_open_input_string "(open-input-string str) opens an input port reading str"
  #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol)
  s7_pointer input_string, port;

  input_string = car(args);
  if (!is_string(input_string))
    method_or_bust(sc, input_string, sc->open_input_string_symbol, args, T_STRING, 0);
  port = open_and_protect_input_string(sc, input_string);
  return(port);
}


#define FORMAT_PORT_LENGTH 128
/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed
 *   256 is slightly slower (the calloc time below dominates the realloc time in string_write_string)
 *   64 is much slower (realloc dominates)
 */

static s7_pointer open_output_string(s7_scheme *sc, int len)
{
  s7_pointer x;
  new_cell(sc, x, T_OUTPUT_PORT);
  port_port(x) = alloc_port(sc);
  port_type(x) = STRING_PORT;
  port_is_closed(x) = false;
  port_data_size(x) = len;
  port_data(x) = (unsigned char *)malloc(len * sizeof(unsigned char)); /* was +8? */
  port_data(x)[0] = '\0';   /* in case s7_get_output_string before any output */
  port_position(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);
}

s7_pointer s7_open_output_string(s7_scheme *sc)
{
  return(open_output_string(sc, sc->initial_string_port_length));
}


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"
  #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol)
  return(s7_open_output_string(sc));
}


const char *s7_get_output_string(s7_scheme *sc, s7_pointer p)
{
  port_data(p)[port_position(p)] = '\0';
  return((const char *)port_data(p));
}


static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port.  \
If the optional 'clear-port' is #t, the current string is flushed."
  #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_output_port_symbol, sc->is_boolean_symbol)

  s7_pointer p, result;
  bool clear_port = false;

  if (is_pair(cdr(args)))
    {
      p = cadr(args);
      if (!s7_is_boolean(p))
	return(wrong_type_argument(sc, sc->get_output_string_symbol, 2, p, T_BOOLEAN));
      clear_port = (p == sc->T);
    }
  p = car(args);
  if ((!is_output_port(p)) ||
      (!is_string_port(p)))
    {
      if (p == sc->F) return(make_empty_string(sc, 0, 0));
      method_or_bust_with_type(sc, p, sc->get_output_string_symbol, args, make_string_wrapper(sc, "an output string port"), 0);
    }
  if (port_is_closed(p))
    return(simple_wrong_type_argument_with_type(sc, sc->get_output_string_symbol, p, make_string_wrapper(sc, "an active (open) string port")));

  result = s7_make_string_with_length(sc, (const char *)port_data(p), port_position(p));
  if (clear_port)
    {
      port_position(p) = 0;
      port_data(p)[0] = '\0';
    }
  return(result);
}


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, 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, T_OUTPUT_PORT);
  port_port(x) = alloc_port(sc);
  port_type(x) = FUNCTION_PORT;
  port_data(x) = NULL;
  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->temp6 = sc->input_port;
  sc->input_port = new_port;
  sc->input_port_stack = cons(sc, sc->temp6, sc->input_port_stack);
  sc->temp6 = sc->nil;
}


static void pop_input_port(s7_scheme *sc)
{
  if (is_pair(sc->input_port_stack))
    {
      s7_pointer nxt;
      sc->input_port = car(sc->input_port_stack);
      nxt = cdr(sc->input_port_stack);
      /* is this safe? */
      free_cell(sc, sc->input_port_stack);
      sc->input_port_stack = nxt;
    }
  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_data_size(pt) <= port_position(pt))
	return(EOF);
      c = (unsigned char)port_data(pt)[port_position(pt)++];
    }

  if (c == '\n')
    port_line_number(pt)++;

  return(c);
}


static void backchar(char c, s7_pointer pt)
{
  if (c == '\n')
    port_line_number(pt)--;

  if (is_file_port(pt))
    ungetc(c, port_file(pt));
  else
    {
      if (port_position(pt) > 0)
	port_position(pt)--;
    }
}


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)
{
  if (pt != sc->F)
    port_write_character(pt)(sc, c, pt);
}


static s7_pointer input_port_if_not_loading(s7_scheme *sc)
{
  s7_pointer port;
  port = sc->input_port;
  if (is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */
    {
      int c;
      c = port_read_white_space(port)(sc, port);
      if (c > 0)            /* we can get either EOF or NULL at the end */
	{
	  backchar(c, port);
	  return(NULL);
	}
      return(sc->standard_input);
    }
  return(port);
}

static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
{
  #define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port"
  #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(sc->eof_object);
    }
  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->read_char_symbol, args, an_input_port_string, 0);
  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)
{
  s7_pointer port;
  port = input_port_if_not_loading(sc);
  if (port)
    return(chars[port_read_character(port)(sc, port)]);
  return(sc->eof_object);
}


static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port;
  port = car(args);
  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->read_char_symbol, args, an_input_port_string, 0);
  return(chars[port_read_character(port)(sc, port)]);
}

static s7_pointer c_read_char(s7_scheme *sc)
{
  int c;
  s7_pointer port;
  port = input_port_if_not_loading(sc);
  if (!port) return(sc->eof_object);
  c = port_read_character(port)(sc, port);
  if (c == EOF)
    return(sc->eof_object);
  return(chars[c]);
}

PF_0(read_char, c_read_char)


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"
  #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, sc->is_output_port_symbol)
  s7_pointer port, chr;

  chr = car(args);
  if (!s7_is_character(chr))
    method_or_bust(sc, chr, sc->write_char_symbol, args, T_CHARACTER, 1);

  if (is_pair(cdr(args)))
    port = cadr(args);
  else port = sc->output_port;
  if (port == sc->F) return(chr);
  if (!is_output_port(port))
    method_or_bust_with_type(sc, port, sc->write_char_symbol, args, an_output_port_string, 2);

  port_write_character(port)(sc, s7_character(chr), port);
  return(chr);
}

static s7_pointer c_write_char(s7_scheme *sc, s7_pointer chr)
{
  if (!s7_is_character(chr))
    method_or_bust(sc, chr, sc->write_char_symbol, set_plist_1(sc, chr), T_CHARACTER, 1);
  if (sc->output_port == sc->F) return(chr);
  port_write_character(sc->output_port)(sc, s7_character(chr), sc->output_port);
  return(chr);
}

static s7_pointer write_char_1;
static s7_pointer g_write_char_1(s7_scheme *sc, s7_pointer args) {return(c_write_char(sc, car(args)));}

PF_TO_PF(write_char, c_write_char)


static s7_pointer write_char_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 1)
    return(write_char_1);
  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"
  #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else port = sc->input_port;

  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->peek_char_symbol, args, an_input_port_string, 0);
  if (port_is_closed(port))
    return(simple_wrong_type_argument_with_type(sc, sc->peek_char_symbol, port, an_open_port_string));

  if (is_function_port(port))
    return((*(port_input_function(port)))(sc, S7_PEEK_CHAR, port));
  return(chars[s7_peek_char(sc, port)]);
}

static s7_pointer c_peek_char(s7_scheme *sc) {return(chars[s7_peek_char(sc, sc->input_port)]);}
PF_0(peek_char, c_peek_char)


static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args)
{
  #define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port"
  #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
  s7_pointer port;
  int c;

  if (is_not_null(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(sc->eof_object);
    }
  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->read_byte_symbol, args, an_input_port_string, 0);

  c = port_read_character(port)(sc, port);
  if (c == EOF)
    return(sc->eof_object);
  return(small_int(c));
}

static s7_pointer c_read_byte(s7_scheme *sc)
{
  int c;
  s7_pointer port;
  port = input_port_if_not_loading(sc);
  if (!port) return(sc->eof_object);
  c = port_read_character(port)(sc, port);
  if (c == EOF)
    return(sc->eof_object);
  return(small_int(c));
}

PF_0(read_byte, c_read_byte)


static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
{
  #define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port"
  #define Q_write_byte s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_output_port_symbol)
  s7_pointer port, b;
  s7_int val;

  b = car(args);
  if (!s7_is_integer(b))
    method_or_bust(sc, car(args), sc->write_byte_symbol, args, T_INTEGER, 1);

  val = s7_integer(b);
  if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */
    return(wrong_type_argument_with_type(sc, sc->write_byte_symbol, 1, b, an_unsigned_byte_string));

  if (is_pair(cdr(args)))
    port = cadr(args);
  else port = sc->output_port;

  if (!is_output_port(port))
    {
      if (port == sc->F) return(car(args));
      method_or_bust_with_type(sc, port, sc->write_byte_symbol, args, an_output_port_string, 0);
    }

  s7_write_char(sc, (int)(s7_integer(b)), port);
  return(b);
}

static s7_int c_write_byte(s7_scheme *sc, s7_int x)
{
  if ((x < 0) || (x > 255))
    wrong_type_argument_with_type(sc, sc->write_byte_symbol, 1, make_integer(sc, x), an_unsigned_byte_string);
  s7_write_char(sc, (int)x, sc->output_port);
  return(x);
}

IF_TO_IF(write_byte, c_write_byte)


static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args)
{
  #define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #<eof>.\
If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
  #define Q_read_line s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol, sc->is_boolean_symbol)

  s7_pointer port;
  bool with_eol = false;

  if (is_not_null(args))
    {
      port = car(args);
      if (!is_input_port(port))
	method_or_bust_with_type(sc, port, sc->read_line_symbol, args, an_input_port_string, 1);

      if (is_not_null(cdr(args)))
	with_eol = (cadr(args) != sc->F);
    }
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(sc->eof_object);
    }
  return(port_read_line(port)(sc, port, with_eol, true));
}

static s7_pointer c_read_line(s7_scheme *sc) {return(g_read_line(sc, sc->nil));}
PF_0(read_line, c_read_line)


static s7_pointer read_line_uncopied;
static s7_pointer g_read_line_uncopied(s7_scheme *sc, s7_pointer args)
{
  s7_pointer port;
  bool with_eol = false;
  port = car(args);
  if (!is_input_port(port))
    return(g_read_line(sc, args));
  if (is_not_null(cdr(args)))
    with_eol = (cadr(args) != sc->F);
  return(port_read_line(port)(sc, port, with_eol, false));
}


static s7_pointer c_read_string(s7_scheme *sc, s7_int chars, s7_pointer port)
{
  s7_pointer s;
  s7_int i;
  unsigned char *str;

  if (chars < 0)
    return(wrong_type_argument_with_type(sc, sc->read_string_symbol, 1, make_integer(sc, chars), a_non_negative_integer_string));
  if (chars > sc->max_string_length)
    return(out_of_range(sc, sc->read_string_symbol, small_int(1), make_integer(sc, chars), its_too_large_string));

  if (!port) return(sc->eof_object);
  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->read_string_symbol, list_2(sc, make_integer(sc, chars), port), an_input_port_string, 2);

  if (chars == 0)
    return(make_empty_string(sc, 0, 0));

  s = make_empty_string(sc, chars, 0);
  str = (unsigned char *)string_value(s);
  for (i = 0; i < chars; i++)
    {
      int c;
      c = port_read_character(port)(sc, port);
      if (c == EOF)
	{
	  if (i == 0)
	    return(sc->eof_object);
	  string_length(s) = i;
	  return(s);
	}
      str[i] = (unsigned char)c;
    }
  return(s);
}

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."
  #define Q_read_string s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_integer_symbol, sc->is_input_port_symbol)
  s7_pointer k, port;

  k = car(args);
  if (!s7_is_integer(k))
    method_or_bust(sc, k, sc->read_string_symbol, args, T_INTEGER, 1);

  if (!is_null(cdr(args)))
    port = cadr(args);
  else port = input_port_if_not_loading(sc); /* port checked (for NULL) in c_read_string */
  return(c_read_string(sc, s7_integer(k), port));
}

static s7_pointer c_read_string_1(s7_scheme *sc, s7_int chars) {return(c_read_string(sc, chars, input_port_if_not_loading(sc)));}
IF_TO_PF(read_string, c_read_string_1)

#define declare_jump_info() bool old_longjmp; int old_jump_loc, jump_loc; jmp_buf old_goto_start

#define store_jump_info(Sc)						\
  do {									\
      old_longjmp = Sc->longjmp_ok;					\
      old_jump_loc = Sc->setjmp_loc;					\
      memcpy((void *)old_goto_start, (void *)(Sc->goto_start), sizeof(jmp_buf));\
  } while (0)

#define restore_jump_info(Sc)						\
  do {									\
      Sc->longjmp_ok = old_longjmp;					\
      Sc->setjmp_loc = old_jump_loc;					\
      memcpy((void *)(Sc->goto_start), (void *)old_goto_start, sizeof(jmp_buf));\
      if ((jump_loc == ERROR_JUMP) &&\
          (sc->longjmp_ok))\
        longjmp(sc->goto_start, ERROR_JUMP);\
  } while (0)

#define set_jump_info(Sc, Tag)			\
  do {						\
      sc->longjmp_ok = true;			\
      sc->setjmp_loc = Tag;				\
      jump_loc = setjmp(sc->goto_start);		\
  } while (0)


s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
{
  if (is_input_port(port))
    {
      s7_pointer old_envir;
      declare_jump_info();

      old_envir = sc->envir;
      sc->envir = sc->nil;
      push_input_port(sc, port);

      store_jump_info(sc);
      set_jump_info(sc, READ_SET_JUMP);
      if (jump_loc != NO_JUMP)
	{
	  if (jump_loc != ERROR_JUMP)
	    eval(sc, sc->op);
	}
      else 
	{
	  push_stack(sc, OP_BARRIER, port, sc->nil);
	  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);

	  eval(sc, OP_READ_INTERNAL);

	  if (sc->tok == TOKEN_EOF)
	    sc->value = sc->eof_object;

	  if ((sc->op == OP_EVAL_DONE) &&
	      (stack_op(sc->stack, s7_stack_top(sc) - 1) == OP_BARRIER))
	    pop_stack(sc); 
	}
      pop_input_port(sc);
      sc->envir = old_envir;

      restore_jump_info(sc);
      return(sc->value);
    }
  return(simple_wrong_type_argument_with_type(sc, sc->read_symbol, port, an_input_port_string));
}


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 rootlet, 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"
  #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)
  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else
    {
      port = input_port_if_not_loading(sc);
      if (!port) return(sc->eof_object);
    }

  if (!is_input_port(port))
    method_or_bust_with_type(sc, port, sc->read_symbol, args, an_input_port_string, 0);

  if (is_function_port(port))
    return((*(port_input_function(port)))(sc, S7_READ, port));

  if ((is_string_port(port)) &&
      (port_data_size(port) <= port_position(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);
}

static s7_pointer c_read(s7_scheme *sc) {return(g_read(sc, sc->nil));}
PF_0(read, c_read)


/* -------------------------------- load -------------------------------- */

static FILE *search_load_path(s7_scheme *sc, const char *name)
{
  int i, len;
  s7_pointer lst;

  lst = s7_load_path(sc);
  len = s7_list_length(sc, lst);
  for (i = 0; i < len; i++)
    {
      const char *new_dir;
      new_dir = string_value(s7_list_ref(sc, lst, i));
      if (new_dir)
	{
	  FILE *fp;
	  snprintf(sc->tmpbuf, TMPBUF_SIZE, "%s/%s", new_dir, name);
	  fp = fopen(sc->tmpbuf, "r");
	  if (fp) return(fp);
	}
    }
  return(NULL);
}


s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e)
{
  s7_pointer port;
  FILE *fp;
  char *new_filename = NULL;
  declare_jump_info();

  fp = fopen(filename, "r");
  if (!fp)
    {
      fp = search_load_path(sc, filename);
      if (fp) 
	new_filename = copy_string(sc->tmpbuf); /* (require libc.scm) for example needs the directory for cload in some cases */
    }
  if (!fp)
    return(file_error(sc, "load", "can't open", filename));

  if (hook_has_functions(sc->load_hook))
    s7_call(sc, sc->load_hook, list_1(sc, sc->temp4 = s7_make_string(sc, filename)));

  port = read_file(sc, fp, (new_filename) ? (const char *)new_filename : filename, -1, "load");   /* -1 means always read its contents into a local string */
  port_file_number(port) = remember_file_name(sc, filename);
  if (new_filename) free(new_filename);
  set_loader_port(port);
  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 = e;
  push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);

  store_jump_info(sc);
  set_jump_info(sc, LOAD_SET_JUMP);
  if (jump_loc != NO_JUMP)
    {
      if (jump_loc != ERROR_JUMP)
	eval(sc, sc->op);
    }
  else eval(sc, OP_READ_INTERNAL);

  pop_input_port(sc);
  if (is_input_port(port))
    s7_close_input_port(sc, port);

  restore_jump_info(sc);
  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
 return(sc->value);
}


s7_pointer s7_load(s7_scheme *sc, const char *filename)
{
  return(s7_load_with_environment(sc, filename, sc->nil));
}


#if WITH_C_LOADER
#include <dlfcn.h>

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 *)malloc(len * sizeof(char));
  if (pwd)
    {
      snprintf(rtn, len, "%s/%s", pwd, filename);
      free(pwd);
    }
  else snprintf(rtn, len, "%s", filename);
  return(rtn);
}
#endif


static s7_pointer g_load(s7_scheme *sc, s7_pointer args)
{
  #define H_load "(load file (env (rootlet))) loads the scheme file 'file'. The 'env' argument \
defaults to the rootlet.  To load into the current environment instead, pass (curlet)."
  #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)

  FILE *fp = NULL;
  s7_pointer name, port;
  const char *fname;

  name = car(args);
  if (!is_string(name))
    method_or_bust(sc, name, sc->load_symbol, args, T_STRING, 1);

  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->load_symbol, 2, e, a_let_string));
      if (e == sc->rootlet)
	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_symbol, set_elist_2(sc, make_string_wrapper(sc, "load's first argument, ~S, should be a filename"), name)));

  if (is_directory(fname))
    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(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" (inlet (cons 'init_func 'init_m_j0)))
   */
  {
    int fname_len;

    fname_len = safe_strlen(fname);
    if ((fname_len > 3) &&
	(is_pair(cdr(args))) &&
	(local_strcmp((const char *)(fname + (fname_len - 3)), ".so")))
      {
	s7_pointer init;

	init = let_ref_1(sc, sc->envir, s7_make_symbol(sc, "init_func"));
	if (is_symbol(init))
	  {
	    void *library;
	    char *pwd_name = NULL;

	    if (fname[0] != '/')
	      pwd_name = full_filename(fname); /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */
	    library = dlopen((pwd_name) ? pwd_name : fname, RTLD_NOW);
	    if (library)
	      {
		const char *init_name = NULL;
		void *init_func;

		init_name = symbol_name(init);
		init_func = dlsym(library, init_name);
		if (init_func)
		  {
		    typedef void *(*dl_func)(s7_scheme *sc);
		    ((dl_func)init_func)(sc);
		    if (pwd_name) free(pwd_name);
		    return(sc->T);
		  }
		else
		  {
		    s7_warn(sc, 512, "loaded %s, but can't find %s (%s)?\n", fname, init_name, dlerror());
		    dlclose(library);
		  }
	      }
	    else s7_warn(sc, 512, "load %s failed: %s\n", (pwd_name) ? pwd_name : fname, dlerror());
	    if (pwd_name) free(pwd_name);
	  }
	else s7_warn(sc, 512, "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;
	      tmpbuf_malloc(filename, len);
	      snprintf(filename, len, "%s%s", home, (char *)(fname + 1));
	      fp = fopen(filename, "r");
	      tmpbuf_free(filename, len);
	    }
	}
    }
#endif

  if (!fp)
    {
      fp = search_load_path(sc, fname);
      if (!fp)
	return(file_error(sc, "load", "can't open", fname));
    }

  port = read_file(sc, fp, fname, -1, "load");
  port_file_number(port) = remember_file_name(sc, fname);
  set_loader_port(port);
  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.  Call *load-hook* if it is a procedure.
   */

  if (hook_has_functions(sc->load_hook))
    s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp4 = s7_make_string(sc, fname)));

  return(sc->unspecified);
}


s7_pointer s7_load_path(s7_scheme *sc)
{
  return(s7_symbol_value(sc, sc->load_path_symbol));
}


s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir)
{
  s7_symbol_set_value(sc,
		      sc->load_path_symbol,
		      cons(sc,
			   s7_make_string(sc, dir),
			   s7_symbol_value(sc, sc->load_path_symbol)));
  return(s7_symbol_value(sc, sc->load_path_symbol));
}


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_symbol);
      if (is_null(x))
	return(cadr(args));
    }
  return(sc->error_symbol);
}

static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args)
{
  s7_pointer cl_dir;
  cl_dir = cadr(args);
  if (!is_string(cl_dir))
    return(sc->error_symbol);
  s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir);
  if (safe_strlen(string_value(cl_dir)) > 0)
    s7_add_to_load_path(sc, (const char *)(string_value(cl_dir)));
  return(cl_dir);
}


/* ---------------- 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->autoloaded_already = (bool **)calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *));
      sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE;
      sc->autoload_names_loc = 0;
    }
  else
    {
      if (sc->autoload_names_loc >= sc->autoload_names_top)
	{
	  int i;
	  sc->autoload_names_top *= 2;
	  sc->autoload_names = (const char ***)realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **));
	  sc->autoload_names_sizes = (int *)realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(int));
	  sc->autoloaded_already = (bool **)realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *));
	  for (i = sc->autoload_names_loc; i < sc->autoload_names_top; i++)
	    {
	      sc->autoload_names[i] = NULL;
	      sc->autoload_names_sizes[i] = 0;
	      sc->autoloaded_already[i] = NULL;
	    }
	}
    }

  sc->autoload_names[sc->autoload_names_loc] = names;
  sc->autoload_names_sizes[sc->autoload_names_loc] = size;
  sc->autoloaded_already[sc->autoload_names_loc] = (bool *)calloc(size, sizeof(bool));
  sc->autoload_names_loc++;
}


static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading)
{
  int l = 0, pos = -1, lib, libs;
  const char *name, *this_name;

  name = symbol_name(symbol);
  libs = sc->autoload_names_loc;

  for (lib = 0; lib < libs; lib++)
    {
      const char **names;
      int u;
      u = sc->autoload_names_sizes[lib] - 1;
      names = sc->autoload_names[lib];

      while (true)
	{
	  int comp;
	  if (u < l) break;
	  pos = (l + u) / 2;
	  this_name = names[pos * 2];
	  comp = strcmp(this_name, name);
	  if (comp == 0)
	    {
	      *already_loaded = sc->autoloaded_already[lib][pos];
	      if (loading) sc->autoloaded_already[lib][pos] = true;
	      return(names[pos * 2 + 1]);             /* file name given func name */
	    }
	  if (comp < 0)
	    l = pos + 1;
	  else u = pos - 1;
	}
    }
  return(NULL);
}


s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function)
{
  /* add '(symbol . file) to s7's autoload table */
  if (is_null(sc->autoload_table))
    sc->autoload_table = s7_make_hash_table(sc, sc->default_hash_table_length);
  s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function);
  return(file_or_function);
}


static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args)
{
  #define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \
If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \
the function.  The function takes one argument, the calling environment.  Presumably the symbol is defined \
in the file, or by the function."
  #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T)

  s7_pointer sym, value;

  sym = car(args);
  if (is_string(sym))
    {
      if (string_length(sym) == 0)                   /* (autoload "" ...) */
	return(s7_wrong_type_arg_error(sc, "autoload", 1, sym, "a symbol-name or a symbol"));
      sym = make_symbol_with_length(sc, string_value(sym), string_length(sym));
    }
  if (!is_symbol(sym))
    {
      check_method(sc, sym, sc->autoload_symbol, args);
      return(s7_wrong_type_arg_error(sc, "autoload", 1, sym, "a string (symbol-name) or a symbol"));
    }
  if (is_keyword(sym))
    return(s7_wrong_type_arg_error(sc, "autoload", 1, sym, "a normal symbol (a keyword is never unbound)"));

  value = cadr(args);
  if (is_string(value))
    return(s7_autoload(sc, sym, value));
  if (((is_closure(value)) || (is_closure_star(value))) &&
      (s7_is_aritable(sc, value, 1)))
    return(s7_autoload(sc, sym, value));

  check_method(sc, value, sc->autoload_symbol, args);
  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."
  #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
  s7_pointer sym;

  sym = car(args);
  if (!is_symbol(sym))
    {
      check_method(sc, sym, sc->autoloader_symbol, args);
      return(s7_wrong_type_arg_error(sc, "*autoload*", 1, sym, "a symbol"));
    }
  if (sc->autoload_names)
    {
      const char *file;
      bool loaded = false;
      file = find_autoload_name(sc, sym, &loaded, false);
      if (file)
	return(s7_make_string(sc, file));
    }
  if (is_hash_table(sc->autoload_table))
    return(s7_hash_table_ref(sc, sc->autoload_table, sym));

  return(sc->F);
}


static s7_pointer g_require(s7_scheme *sc, s7_pointer args)
{
  #define H_require "(require . symbols) loads each file associated with each symbol if it has not been loaded already.\
The symbols refer to the argument to \"provide\"."
  #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol)

  s7_pointer p;
  sc->temp5 = cons(sc, args, sc->temp5);
  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer sym;
      if (is_symbol(car(p)))
	sym = car(p);
      else
	{
	  if ((is_pair(car(p))) && 
	      (caar(p) == sc->quote_symbol) &&
	      (is_symbol(cadar(p))))
	    sym = cadar(p);
	  else return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "require: ~S is not a symbol"), car(p))));
	}
      if (!is_slot(find_symbol(sc, sym)))
	{
	  s7_pointer f;
	  f = g_autoloader(sc, list_1(sc, sym));
	  if (is_string(f))
	    s7_load_with_environment(sc, string_value(f), sc->envir);
	  else
	    {
	      sc->temp5 = sc->nil; 
	      return(s7_error(sc, make_symbol(sc, "autoload-error"), 
			      set_elist_2(sc, make_string_wrapper(sc, "require: no autoload info for ~S"), sym)));
	    }
	}
    }
  sc->temp5 = cdr(sc->temp5); /* in-coming value */
  return(sc->T);
}


/* -------------------------------- eval-string -------------------------------- */

s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e)
{
  s7_pointer code, port;
  port = s7_open_input_string(sc, str);
  code = s7_read(sc, port);
  s7_close_input_port(sc, port);
  return(s7_eval(sc, _NFre(code), e));
}


s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str)
{
  return(s7_eval_c_string_with_environment(sc, str, sc->nil));
}

static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args)
{
  #define H_eval_string "(eval-string str (env (curlet))) returns the result of evaluating the string str as Scheme code"
  #define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
  s7_pointer port, str;
  
  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->eval_string_symbol, args, T_STRING, 1);

  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_let(e))
 	return(wrong_type_argument_with_type(sc, sc->eval_string_symbol, 2, e, a_let_string));
      if (e == sc->rootlet)
	sc->envir = sc->nil;
      else sc->envir = e;
    }

  port = open_and_protect_input_string(sc, str);
  push_input_port(sc, port);

  sc->temp3 = sc->args;
  push_stack(sc, OP_EVAL_STRING_1, args, sc->code); 
  push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);

  return(sc->F);
}

static s7_pointer eval_string_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return(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);
}


/* -------------------------------- call-with-input-string -------------------------------- */

static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args)
{
  s7_pointer str, proc;
  #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it"
  #define Q_call_with_input_string pl_sf
  /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->call_with_input_string_symbol, args, T_STRING, 1);

  proc = cadr(args);
  if (is_let(proc))
    check_method(sc, proc, sc->call_with_input_string_symbol, args);

  if (!s7_is_aritable(sc, proc, 1))
    return(wrong_type_argument_with_type(sc, sc->call_with_input_string_symbol, 2, proc,
					 make_string_wrapper(sc, "a procedure of one argument (the port)")));

  if ((is_continuation(proc)) || (is_goto(proc)))
    return(wrong_type_argument_with_type(sc, sc->call_with_input_string_symbol, 2, proc, a_normal_procedure_string));

  return(call_with_input(sc, open_and_protect_input_string(sc, str), args));
}

static s7_pointer c_call_with_input_string(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_call_with_input_string(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(call_with_input_string, c_call_with_input_string)


/* -------------------------------- call-with-input-file -------------------------------- */

static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument"
  #define Q_call_with_input_file pl_sf
  s7_pointer str, proc;

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->call_with_input_file_symbol, args, T_STRING, 1);

  proc = cadr(args);
  if (!s7_is_aritable(sc, proc, 1))
    return(wrong_type_argument_with_type(sc, sc->call_with_input_file_symbol, 2, proc,
					 make_string_wrapper(sc, "a procedure of one argument (the port)")));
  if ((is_continuation(proc)) || (is_goto(proc)))
    return(wrong_type_argument_with_type(sc, sc->call_with_input_file_symbol, 2, proc, a_normal_procedure_string));

  return(call_with_input(sc, open_input_file_1(sc, string_value(str), "r", "call-with-input-file"), args));
}

static s7_pointer c_call_with_input_file(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_call_with_input_file(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(call_with_input_file, c_call_with_input_file)


static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
{
  s7_pointer old_input_port, p;
  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);
  p = cadr(args);
  push_stack(sc, OP_APPLY, sc->nil, p);
  return(sc->F);
}


/* -------------------------------- with-input-from-string -------------------------------- */

static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args)
{
  #define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk"
  #define Q_with_input_from_string pl_sf
  s7_pointer str;

  str = car(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->with_input_from_string_symbol, args, T_STRING, 1);

  if (!is_thunk(sc, cadr(args)))
    method_or_bust_with_type(sc, cadr(args), sc->with_input_from_string_symbol, args, a_thunk_string, 2);

  /* since the arguments are evaluated before we get here, we can get some confusing situations:
   *   (with-input-from-string "#x2.1" (read))
   *   (read) -> whatever it can get from the current input port!
   *   ";with-input-from-string argument 2, #<eof>, is untyped but should be a thunk"
   */
  return(with_input(sc, open_and_protect_input_string(sc, str), args));
}

static s7_pointer c_with_input_from_string(s7_scheme *sc, s7_pointer x) {return(g_with_input_from_string(sc, set_plist_1(sc, x)));}
PF_TO_PF(with_input_from_string, c_with_input_from_string)


/* -------------------------------- with-input-from-file -------------------------------- */

static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args)
{
  #define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk"
  #define Q_with_input_from_file pl_sf

  if (!is_string(car(args)))
    method_or_bust(sc, car(args), sc->with_input_from_file_symbol, args, T_STRING, 1);

  if (!is_thunk(sc, cadr(args)))
    method_or_bust_with_type(sc, cadr(args), sc->with_input_from_file_symbol, args, a_thunk_string, 2);

  return(with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "with-input-from-file"), args));
}

static s7_pointer c_with_input_from_file(s7_scheme *sc, s7_pointer x) {return(g_with_input_from_file(sc, set_plist_1(sc, x)));}
PF_TO_PF(with_input_from_file, c_with_input_from_file)



/* -------------------------------- iterators -------------------------------- */

static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args)
{
  #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator."
  #define Q_is_iterator pl_bt
  s7_pointer x;

  x = car(args);
  if (is_iterator(x)) return(sc->T);
  check_closure_for(sc, x, sc->is_iterator_symbol);
  check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args);
  return(sc->F);
}


static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer p)
{
  /* fields are obj cur [loc|lcur] [len|slow|hcur] next */
  s7_pointer iter;
  new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE);
  iterator_sequence(iter) = iterator_sequence(p);   /* obj */
  iterator_position(iter) = iterator_position(p);   /* loc|lcur (loc is s7_int) */
  iterator_length(iter) = iterator_length(p);       /* len|slow|hcur (len is s7_int) */
  iterator_current(iter) = iterator_current(p);     /* cur */
  iterator_next(iter) = iterator_next(p);           /* next */
  return(iter);
}


static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator)
{
  return(sc->ITERATOR_END);
}

static s7_pointer let_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer slot;
  slot = iterator_current_slot(iterator);
  if (is_slot(slot))
    {
      iterator_set_current_slot(iterator, next_slot(slot));
      if (iterator_let_cons(iterator))
	{
	  s7_pointer p;
	  p = iterator_let_cons(iterator);
	  set_car(p, slot_symbol(slot));
	  set_cdr(p, slot_value(slot));
	  return(p);
	}
      return(cons(sc, slot_symbol(slot), slot_value(slot)));
    }
  iterator_next(iterator) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer rootlet_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer slot;
  slot = iterator_current(iterator);
  if (is_slot(slot))
    {
      if (iterator_position(iterator) < sc->rootlet_entries)
	{
	  iterator_position(iterator)++;
	  iterator_current(iterator) = vector_element(sc->rootlet, iterator_position(iterator));
	}
      else iterator_current(iterator) = sc->nil;
      return(cons(sc, slot_symbol(slot), slot_value(slot)));
    }
  iterator_next(iterator) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator)
{
  s7_pointer table;
  int loc, len;
  hash_entry_t **elements;
  hash_entry_t *lst;

  lst = iterator_hash_current(iterator);
  if (lst)
    {
      iterator_hash_current(iterator) = lst->next;
      if (iterator_current(iterator))
	{
	  s7_pointer p;
	  p = iterator_current(iterator);
	  set_car(p, lst->key);
	  set_cdr(p, lst->value);
	  return(p);
	}
      return(cons(sc, lst->key, lst->value));
    }

  table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */
  len = hash_table_mask(table) + 1;
  elements = hash_table_elements(table);

  for (loc = iterator_position(iterator) + 1; loc < len;  loc++)
    {
      hash_entry_t *x;
      x = elements[loc];
      if (x)
	{
	  iterator_position(iterator) = loc;
	  iterator_hash_current(iterator) = x->next;
	  if (iterator_current(iterator))
	    {
	      s7_pointer p;
	      p = iterator_current(iterator);
	      set_car(p, x->key);
	      set_cdr(p, x->value);
	      return(p);
	    }
	  return(cons(sc, x->key, x->value));
	}
    }
  iterator_next(iterator) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer string_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    return(s7_make_character(sc, (unsigned char)(string_value(iterator_sequence(obj))[iterator_position(obj)++])));
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    return(small_int((unsigned char)(string_value(iterator_sequence(obj))[iterator_position(obj)++])));
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer float_vector_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    return(make_real(sc, float_vector_element(iterator_sequence(obj), iterator_position(obj)++)));
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer int_vector_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    return(make_integer(sc, int_vector_element(iterator_sequence(obj), iterator_position(obj)++)));
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    return(vector_element(iterator_sequence(obj), iterator_position(obj)++));
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj)
{
  s7_pointer result;
  result = s7_apply_function(sc, iterator_sequence(obj), sc->nil);
  if (result == sc->ITERATOR_END)
    iterator_next(obj) = iterator_finished;
  return(result);
}

static s7_pointer c_object_direct_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    {
      s7_pointer result, p;
      p = iterator_sequence(obj);
      result = c_object_cref(p)(sc, p, iterator_position(obj));
      iterator_position(obj)++;
      if (result == sc->ITERATOR_END)
	iterator_next(obj) = iterator_finished;
      return(result);
    }
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (iterator_position(obj) < iterator_length(obj))
    {
      s7_pointer result, p, cur;
      p = iterator_sequence(obj);
      cur = iterator_current(obj);
      set_car(sc->z2_1, sc->x);
      set_car(sc->z2_2, sc->z); /* is this necessary? */
      set_car(cur, make_integer(sc, iterator_position(obj)));
      result = (*(c_object_ref(p)))(sc, p, cur);
      sc->x = car(sc->z2_1);
      sc->z = car(sc->z2_2);
      iterator_position(obj)++;
      if (result == sc->ITERATOR_END)
	iterator_next(obj) = iterator_finished;
      return(result);
    }
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}


static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj);
static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer obj)
{
  if (is_pair(iterator_current(obj)))
    {
      s7_pointer result;
      result = car(iterator_current(obj));
      iterator_current(obj) = cdr(iterator_current(obj));
      if (iterator_current(obj) == iterator_slow(obj))
	{
	  iterator_next(obj) = iterator_finished;
	  return(result);
	}
      iterator_next(obj) = pair_iterate_1;
      return(result);
    }
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj)
{
  if (is_pair(iterator_current(obj)))
    {
      s7_pointer result;
      result = car(iterator_current(obj));
      iterator_current(obj) = cdr(iterator_current(obj));
      if (iterator_current(obj) == iterator_slow(obj))
	{
	  iterator_next(obj) = iterator_finished;
	  return(result);
	}
      iterator_set_slow(obj, cdr(iterator_slow(obj)));
      iterator_next(obj) = pair_iterate;
      return(result);
    }
  iterator_next(obj) = iterator_finished;
  return(sc->ITERATOR_END);
}

static s7_pointer iterator_method(s7_scheme *sc, s7_pointer e)
{
  s7_pointer func;
  if ((has_methods(e)) && 
      ((func = find_method(sc, find_let(sc, e), sc->make_iterator_symbol)) != sc->undefined))
    {
      s7_pointer it;
      it = s7_apply_function(sc, func, list_1(sc, e));
      if (!is_iterator(it))
	return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "make-iterator method must return an interator: ~S"), it)));
      return(it);
    }
  return(NULL);
}

s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
{
  s7_pointer iter;

  new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE);
  iterator_sequence(iter) = e;
  iterator_position(iter) = 0;

  switch (type(e))
    {
    case T_LET:
      if (e == sc->rootlet)
	{
	  iterator_current(iter) = vector_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */
	  iterator_next(iter) = rootlet_iterate;
	}
      else
	{
	  s7_pointer f;
	  sc->temp6 = iter;
	  f = iterator_method(sc, e);
	  sc->temp6 = sc->nil;
	  if (f) {free_cell(sc, iter); return(f);}
	  iterator_set_current_slot(iter, let_slots(e));
	  iterator_next(iter) = let_iterate;
	  iterator_let_cons(iter) = NULL;
	}
      break;

    case T_HASH_TABLE:
      iterator_hash_current(iter) = NULL;
      iterator_current(iter) = NULL;
      iterator_position(iter) = -1;
      iterator_next(iter) = hash_table_iterate;
      break;

    case T_STRING:
      iterator_length(iter) = string_length(e);
      if (is_byte_vector(e))
	iterator_next(iter) = byte_vector_iterate;
      else iterator_next(iter) = string_iterate;
      break;

    case T_VECTOR:
      iterator_length(iter) = vector_length(e);
      iterator_next(iter) = vector_iterate;
      break;

    case T_INT_VECTOR:
      iterator_length(iter) = vector_length(e);
      iterator_next(iter) = int_vector_iterate;
      break;

    case T_FLOAT_VECTOR:
      iterator_length(iter) = vector_length(e);
      iterator_next(iter) = float_vector_iterate;
      break;

    case T_PAIR:
      iterator_current(iter) = e;
      iterator_next(iter) = pair_iterate;
      iterator_set_slow(iter, e);
      break;

    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      {
	s7_pointer p;
	p = cons(sc, e, sc->nil);
	if (g_is_iterator(sc, p) != sc->F)
	  {
	    set_car(p, small_int(0));
	    iterator_current(iter) = p;
	    set_mark_seq(iter);
	    iterator_next(iter) = closure_iterate;
	    if (has_methods(e))
	      iterator_length(iter) = closure_length(sc, e);
	    else iterator_length(iter) = s7_int_max;
	  }
	else 
	  {
	    free_cell(sc, iter);
	    return(simple_wrong_type_argument_with_type(sc, sc->make_iterator_symbol, e, make_string_wrapper(sc, "a closure/macro with an 'iterator local that is not #f")));
	  }
      }
      break;

    case T_C_OBJECT:
      iterator_length(iter) = object_length_to_int(sc, e);
      if (c_object_direct_ref(e))
	{
	  iterator_next(iter) = c_object_direct_iterate;
	  c_object_cref(e) = c_object_direct_ref(e);
	}
      else
	{
	  s7_pointer f;
	  sc->temp6 = iter;
	  f = iterator_method(sc, e);
	  sc->temp6 = sc->nil;
	  if (f) {free_cell(sc, iter); return(f);}
	  iterator_current(iter) = cons(sc, small_int(0), sc->nil);
	  set_mark_seq(iter);
	  iterator_next(iter) = c_object_iterate;
	}
      break;

    default:
      return(simple_wrong_type_argument_with_type(sc, sc->make_iterator_symbol, e, a_sequence_string));
    }
  return(iter);
}


static s7_pointer g_make_iterator(s7_scheme *sc, s7_pointer args)
{
  #define H_make_iterator "(make-iterator sequence) returns an iterator object that \
returns the next value in the sequence each time it is called.  When it reaches the end, it returns " ITERATOR_END_NAME "."
  #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol)
  
  s7_pointer seq;
  seq = car(args);

  if (is_pair(cdr(args)))
    {
      if (is_pair(cadr(args)))
	{
	  if (is_hash_table(seq))
	    {
	      s7_pointer iter;
	      iter = s7_make_iterator(sc, seq);
	      iterator_current(iter) = cadr(args);
	      set_mark_seq(iter);
	      return(iter);
	    }
	  if ((is_let(seq)) && (seq != sc->rootlet))
	    {
	      s7_pointer iter;
	      iter = s7_make_iterator(sc, seq);
	      iterator_let_cons(iter) = cadr(args);
	      set_mark_seq(iter);
	      return(iter);
	    }
	}
      else return(simple_wrong_type_argument(sc, sc->make_iterator_symbol, cadr(args), T_PAIR));
    }
  return(s7_make_iterator(sc, seq));
}

PF_TO_PF(make_iterator, s7_make_iterator)


static s7_pointer c_iterate(s7_scheme *sc, s7_pointer iter)
{
  if (!is_iterator(iter))
    method_or_bust(sc, iter, sc->iterate_symbol, list_1(sc, iter), T_ITERATOR, 0);
  return((iterator_next(iter))(sc, iter));
}

static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args)
{
  #define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "."
  #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol)

  s7_pointer iter;
  iter = car(args);
  if (!is_iterator(iter))
    method_or_bust(sc, iter, sc->iterate_symbol, args, T_ITERATOR, 0);
  return((iterator_next(iter))(sc, iter));
}

static s7_pointer iterate_pf_p(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x;
  f = (s7_pf_t)(**p); (*p)++;	
  x = f(sc, p);
  return(c_iterate(sc, x));
}

static s7_pointer iterate_pf_s(s7_scheme *sc, s7_pointer **p)
{
  pf_pf_t f;
  s7_pointer x;
  x = (s7_pointer)(**p); (*p)++;	
  f = (pf_pf_t)(**p); (*p)++;	
  return(f(sc, x));
}

static s7_pf_t iterate_gf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      s7_pointer a1, obj;
      a1 = cadr(expr);
      if ((is_symbol(a1)) &&
	  (!s7_xf_is_stepper(sc, a1)) &&
	  (is_iterator(obj = s7_symbol_value(sc, a1))))
	{
	  s7_xf_store(sc, obj);
	  s7_xf_store(sc, (s7_pointer)iterator_next(obj));
	  return(iterate_pf_s);
	}
      if (s7_arg_to_pf(sc, a1))
	return(iterate_pf_p);
    }
  return(NULL);
}

static s7_pf_t iterate_pf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_null(cddr(expr))))
    {
      s7_pointer a1, obj;
      a1 = cadr(expr);
      if ((is_symbol(a1)) &&
	  (!s7_xf_is_stepper(sc, a1)) &&
	  (is_iterator(obj = s7_symbol_value(sc, a1))))
	{
	  s7_pointer seq;
	  seq = iterator_sequence(obj);
	  if ((type(seq) == T_VECTOR) || (is_string(seq)) || (is_pair(seq)))
	    {
	      s7_xf_store(sc, obj);
	      s7_xf_store(sc, (s7_pointer)iterator_next(obj));
	      return(iterate_pf_s);
	    }
	}
    }
  return(NULL);
}

s7_pointer s7_iterate(s7_scheme *sc, s7_pointer obj)
{
  return((iterator_next(obj))(sc, obj));
}

bool s7_is_iterator(s7_pointer obj)
{
  return(is_iterator(obj));
}

bool s7_iterator_is_at_end(s7_pointer obj)
{
  return(iterator_is_at_end(obj));
}


static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args)
{
  #define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing."
  #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol)

  s7_pointer iter;

  iter = car(args);
  if (!is_iterator(iter))
    return(simple_wrong_type_argument(sc, sc->iterator_sequence_symbol, iter, T_ITERATOR));
  return(iterator_sequence(iter));
}

static s7_pointer c_iterator_sequence(s7_scheme *sc, s7_pointer iter)
{
  if (!is_iterator(iter))
    return(simple_wrong_type_argument(sc, sc->iterator_sequence_symbol, iter, T_ITERATOR));
  return(iterator_sequence(iter));
}

PF_TO_PF(iterator_sequence, c_iterator_sequence)


static s7_pointer g_iterator_is_at_end(s7_scheme *sc, s7_pointer args)
{
  #define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence."
  #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol)
  s7_pointer iter;

  iter = car(args);
  if (!is_iterator(iter))
    return(simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, iter, T_ITERATOR));
  return(make_boolean(sc, iterator_is_at_end(iter)));
}



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

#define INITIAL_SHARED_INFO_SIZE 8

static int shared_ref(shared_info *ci, s7_pointer p)
{
  /* from print after collecting refs, not called by equality check */
  int i;
  s7_pointer *objs;

  if (!is_collected(p)) return(0);

  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;
  s7_pointer *objs;
  objs = ci->objs;

  if (!is_collected(p)) return(0);
  for (i = 0; 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,
   *   called only in equality check, not printer.
   */

  if ((ci->top + 2) >= ci->size)
    enlarge_shared_info(ci);

  set_collected(x);
  set_collected(y);

  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)
{
  /* called only in equality check, not printer */

  if (ci->top == ci->size)
    enlarge_shared_info(ci);

  set_collected(x);

  ci->objs[ci->top] = x;
  ci->refs[ci->top++] = ref_x;
}

static shared_info *collect_shared_info(s7_scheme *sc, shared_info *ci, s7_pointer top, bool stop_at_print_length, bool *cyclic);
static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key);

static void collect_vector_info(s7_scheme *sc, shared_info *ci, s7_pointer top, bool stop_at_print_length, bool *cyclic)
{
  s7_int i, plen;

  if (stop_at_print_length)
    {
      plen = sc->print_length;
      if (plen > vector_length(top))
	plen = vector_length(top);
    }
  else 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), stop_at_print_length, cyclic);
}


static shared_info *collect_shared_info(s7_scheme *sc, shared_info *ci, s7_pointer top, bool stop_at_print_length, bool *cyclic)
{
  /* 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_shared(top))
    return(ci);

  if (is_collected(top))
    {
      s7_pointer *p, *objs_end;
      int i;
      *cyclic = true;
      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 */
      bool top_cyclic = false;
      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), stop_at_print_length, &top_cyclic);
	  if (has_structure(cdr(top)))
	    collect_shared_info(sc, ci, cdr(top), stop_at_print_length, &top_cyclic);
	  break;

	case T_VECTOR:
	  collect_vector_info(sc, ci, top, stop_at_print_length, &top_cyclic);
	  break;

	case T_ITERATOR:
	  collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length, &top_cyclic);
	  break;

	case T_HASH_TABLE:
	  if (hash_table_entries(top) > 0)
	    {
	      unsigned int i, len;
	      hash_entry_t **entries;
	      bool keys_safe;

	      keys_safe = ((hash_table_checker(top) != hash_equal) &&
			   (!hash_table_checker_locked(top)));
	      entries = hash_table_elements(top);
	      len = hash_table_mask(top) + 1;
	      for (i = 0; i < len; i++)
		{
		  hash_entry_t *p;
		  for (p = entries[i]; p; p = p->next)
		    {
		      if ((!keys_safe) &&
			  (has_structure(p->key)))
			collect_shared_info(sc, ci, p->key, stop_at_print_length, &top_cyclic);
		      if (has_structure(p->value))
			collect_shared_info(sc, ci, p->value, stop_at_print_length, &top_cyclic);
		    }
		}
	    }
	  break;

	case T_SLOT:
	  if (has_structure(slot_value(top)))
	    collect_shared_info(sc, ci, slot_value(top), stop_at_print_length, &top_cyclic);
	  break;

	case T_LET:
	  if (top == sc->rootlet)
	    collect_vector_info(sc, ci, top, stop_at_print_length, &top_cyclic);
	  else
	    {
	      s7_pointer p;
	      for (p = let_slots(top); is_slot(p); p = next_slot(p))
		if (has_structure(slot_value(p)))
		  collect_shared_info(sc, ci, slot_value(p), stop_at_print_length, &top_cyclic);
	    }
	  break;
	}
      if (!top_cyclic)
	set_shared(top);
      else *cyclic = true;
    }
  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
    {
      int i;
      ci = sc->circle_info;
      memclr((void *)(ci->refs), ci->top * sizeof(int));
      for (i = 0; i < ci->top; i++)
	clear_collected_and_shared(ci->objs[i]);
    }
  ci->top = 0;
  ci->ref = 0;
  ci->has_hits = false;
  return(ci);
}


static shared_info *make_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length)
{
  /* for the printer */
  shared_info *ci;
  int i, refs;
  s7_pointer *ci_objs;
  int *ci_refs;
  bool no_problem = true, cyclic = false;

  /* 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) */
	{
	  s7_pointer 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, stop_at_print_length, &cyclic);

  for (i = 0; i < ci->top; i++)
    {
      s7_pointer p;
      p = ci->objs[i];
      clear_collected_and_shared(p);
    }
  if (!cyclic)
    return(NULL);

  if (!(ci->has_hits))
    return(NULL);

  ci_objs = ci->objs;
  ci_refs = ci->refs;

  /* find if any were referenced twice (once for just being there, so twice=shared)
   *   we know there's at least one such reference because has_hits is true.
   */
  for (i = 0, refs = 0; i < ci->top; i++)
    if (ci_refs[i] > 0)
      {
	set_collected(ci_objs[i]);
	if (i == refs)
	  refs++;
	else
	  {
	    ci_objs[refs] = ci_objs[i];
	    ci_refs[refs++] = ci_refs[i];
	    ci_refs[i] = 0;
	    ci_objs[i] = NULL;
	  }
      }
  ci->top = refs;
  return(ci);
}

/* -------------------------------- cyclic-sequences -------------------------------- */

static s7_pointer cyclic_sequences(s7_scheme *sc, s7_pointer obj, bool return_list)
{
  if (has_structure(obj))
    {
      shared_info *ci;
      ci = make_shared_info(sc, obj, false); /* false=don't stop at print length (vectors etc) */
      if (ci)
	{
	  if (return_list)
	    {
	      int i;
	      s7_pointer lst;
	      sc->w = sc->nil;
	      for (i = 0; i < ci->top; i++)
		sc->w = cons(sc, ci->objs[i], sc->w);
	      lst = sc->w;
	      sc->w = sc->nil;
	      return(lst);
	    }
	  else return(sc->T);
	}
    }
  return(sc->nil);
}

static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args)
{
  #define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic."
  #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T)
  return(cyclic_sequences(sc, car(args), true));
}

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, shared_info *ci);
static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci);
static s7_pointer object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice);

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);
#ifdef __OpenBSD__
  strlcat(str, buf, 128); /* 128=length of str */
#else
  strcat(str, buf);
#endif
  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, 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)
	    {
	      if (use_write == USE_READABLE_WRITE)
		{
		  int plen;
		  char buf[128];
		  char *indices;
		  /* need to translate flat_ref into a set of indices
		   */
		  tmpbuf_calloc(indices, 128);
		  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);
		  tmpbuf_free(indices, 128);
		}
	      object_to_port_with_circle_check(sc, vector_element(vec, flat_ref), port, DONT_USE_DISPLAY(use_write), 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), 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, 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_rank(vect) > 1)
	{
	  plen = snprintf(buf, 32, "#%uD()", vector_ndims(vect));
	  port_write_string(port)(sc, buf, plen, port);
	}
      else port_write_string(port)(sc, "#()", 3, port);
      return;
    }

  if (use_write != USE_READABLE_WRITE)
    {
      plen = sc->print_length;
      if (plen <= 0)
	{
	  if (vector_rank(vect) > 1)
	    {
	      plen = snprintf(buf, 32, "#%uD(...)", 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)
    {
      if ((ci) &&
	  (peek_shared_ref(ci, vect) != 0))
	{
	  port_write_string(port)(sc, "(let (({v} (make-vector ", 24, port);
	  if (vector_rank(vect) > 1)
	    {
	      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);
		}
	      port_write_string(port)(sc, ")))) ", 5, port);
	    }
	  else 
	    {
	      plen = snprintf(buf, 128, "%lld))) ", vector_length(vect));
	      port_write_string(port)(sc, buf, plen, port);
	    }
	  if (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_rank(vect) > 1)
	    {
	      bool last = false;
	      multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), &last, use_write, 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);
		  object_to_port_with_circle_check(sc, vector_element(vect, i), port, use_write, ci);
		  port_write_string(port)(sc, ") ", 2, port);
		}
	    }
	  port_write_string(port)(sc, "{v})", 4, port);
	}
      else /* simple readable case */
	{
	  if (vector_rank(vect) > 1)
	    port_write_string(port)(sc, "(make-shared-vector (vector", 27, port);
	  else port_write_string(port)(sc, "(vector", 7, port);

	  for (i = 0; i < len; i++)
	    {
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, vector_element(vect, i), port, use_write, ci);
	    }
	  port_write_character(port)(sc, ')', port);

	  if (vector_rank(vect) > 1)
	    {
	      unsigned int dim;
	      port_write_string(port)(sc, " '(", 3, port);
	      for (dim = 0; dim < vector_ndims(vect) - 1; dim++)
		{
		  plen = snprintf(buf, 128, "%lld ", vector_dimension(vect, dim));
		  port_write_string(port)(sc, buf, plen, port);
		}
	      plen = snprintf(buf, 128, "%lld", vector_dimension(vect, dim));
	      port_write_string(port)(sc, buf, plen, port);
	      port_write_string(port)(sc, "))", 2, port);
	    }
	}
    }
  else
    {
      if (vector_rank(vect) > 1)
	{
	  bool last = false;
	  if (vector_ndims(vect) > 1)
	    {
	      plen = snprintf(buf, 32, "#%uD", 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, ci);
	}
      else
	{
	  port_write_string(port)(sc, "#(", 2, port);
	  for (i = 0; i < len - 1; i++)
	    {
	      object_to_port_with_circle_check(sc, vector_element(vect, i), port, DONT_USE_DISPLAY(use_write), ci);
	      port_write_character(port)(sc, ' ', port);
	    }
	  object_to_port_with_circle_check(sc, vector_element(vect, i), port, DONT_USE_DISPLAY(use_write), ci);

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);
	}
    }
}

static bool string_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);
  size = len + 256;
  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);
    }
  else size = sc->slash_str_size;
  cur_size = size - 2;

  /* 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; */
	  size *= 2;
	  sc->slash_str = (char *)realloc(sc->slash_str, size * sizeof(char));    
	  sc->slash_str_size = size;
	  cur_size = size - 2;
	  s = sc->slash_str;
	  /* for (k = j; k < size; k++) s[k] = 0; */
	}
    }
  if (quoted) s[j++] = '"';
  s[j] = '\0';
  (*nlen) = j;
  return(s);
}

static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  if ((obj == sc->standard_output) ||
      (obj == sc->standard_error))
    port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
  else
    {
      int nlen;
      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 
	    {
	      char *str;
	      if (is_string_port(obj))
		{
		  port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port);
		  if (port_position(obj) > 0)
		    {
		      port_write_string(port)(sc, " (display ", 10, port);
		      str = slashify_string(sc, (const char *)port_data(obj), port_position(obj), IN_QUOTES, &nlen);
		      port_write_string(port)(sc, str, nlen, port);
		      port_write_string(port)(sc, " p)", 3, port);
		    }
		  port_write_string(port)(sc, " p)", 3, port);
		}
	      else 
		{
		  str = (char *)malloc(256 * sizeof(char));
		  nlen = snprintf(str, 256, "(open-output-file \"%s\" \"a\")", port_filename(obj));
		  port_write_string(port)(sc, str, nlen, port);
		  free(str);
		}
	    }
	}
      else
	{
	  if (is_string_port(obj))
	    port_write_string(port)(sc, "<output-string-port", 19, port);
	  else
	    {
	      if (is_file_port(obj))
		port_write_string(port)(sc, "<output-file-port", 17, port);
	      else port_write_string(port)(sc, "<output-function-port", 21, port);
	    }
	  if (port_is_closed(obj)) 
	    port_write_string(port)(sc, " (closed)>", 10, port);
	  else port_write_character(port)(sc, '>', port);
	}
    }
}

static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  if (obj == sc->standard_input)
    port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
  else
    {
      int nlen = 0;
      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))
		port_write_string(port)(sc, "#<function input port>", 22, port);
	      else
		{
		  char *str;
		  if (is_file_port(obj))
		    {
		      str = (char *)malloc(256 * sizeof(char));
		      nlen = snprintf(str, 256, "(open-input-file \"%s\")", port_filename(obj));
		      port_write_string(port)(sc, str, nlen, port);
		      free(str);
		    }
		  else
		    {
		      /* if the string is large, slashify_string is a problem. Usually this is actually
		       *   a file port where the contents were read in one (up to 5MB) gulp, so the
		       *   readable version could be: open file, read-char to the current port_position.
		       *   s7_port_filename(port) has the char* name if any.
		       */
		      int data_len;
		      data_len = port_data_size(obj) - port_position(obj);
		      if (data_len > 100)
			{
			  const char *filename;
			  filename = (const char *)s7_port_filename(obj);
			  if (filename)
			    {
			      #define DO_STR_LEN 1024
			      char *do_str;
			      int len;
			      do_str = (char *)malloc(DO_STR_LEN * sizeof(char));
			      if (port_position(obj) > 0)
				{
				  len = snprintf(do_str, DO_STR_LEN, "(let ((port (open-input-file \"%s\")))", filename);
				  port_write_string(port)(sc, do_str, len, port);
				  len = snprintf(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i %u) port)))", 
						 port_position(obj) - 1);
				}
			      else len = snprintf(do_str, DO_STR_LEN, "(open-input-file \"%s\")", filename);
			      port_write_string(port)(sc, do_str, len, port);
			      free(do_str);
			      return;
			    }
			}
		      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, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), IN_QUOTES, &nlen);
		      port_write_string(port)(sc, str, nlen, port);
		      port_write_character(port)(sc, ')', port);
		    }
		}
	    }
	}
      else
	{
	  if (is_string_port(obj))
	    port_write_string(port)(sc, "<input-string-port", 18, port);
	  else
	    {
	      if (is_file_port(obj))
		port_write_string(port)(sc, "<input-file-port", 16, port);
	      else port_write_string(port)(sc, "<input-function-port", 20, port);
	    }
	  if (port_is_closed(obj)) 
	    port_write_string(port)(sc, " (closed)>", 10, port);
	  else port_write_character(port)(sc, '>', port);
	}
    }
}

static bool symbol_needs_slashification(s7_pointer obj)
{
  unsigned char *p, *pend;
  const char *str;
  int len;
  str = symbol_name(obj);
  if (str[0] == '#')
    return(true);
  len = symbol_name_length(obj);
  pend = (unsigned char *)(str + len);
  for (p = (unsigned char *)str; p < pend; p++)
    if (symbol_slashify_table[*p])
      return(true);
  set_clean_symbol(obj);
  return(false);
}

static void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  /* I think this is the only place we print a symbol's name
   *   but in the readable case, what about (symbol "1;3")? it actually seems ok!
   */
  if ((!is_clean_symbol(obj)) &&
      (symbol_needs_slashification(obj)))
    {
      int nlen = 0;
      char *str, *symstr;
      str = slashify_string(sc, symbol_name(obj), symbol_name_length(obj), NOT_IN_QUOTES, &nlen);
      nlen += 16;
      tmpbuf_malloc(symstr, nlen);
      nlen = snprintf(symstr, nlen, "(symbol \"%s\")", str);
      port_write_string(port)(sc, symstr, nlen, port);
      tmpbuf_free(symstr, nlen);
    }
  else
    {
      if ((use_write == USE_READABLE_WRITE) &&
	  (!is_keyword(obj)))
	port_write_character(port)(sc, '\'', port);
      if (is_string_port(port))
	{
	  int new_len;
	  new_len = port_position(port) + symbol_name_length(obj);
	  if (new_len >= (int)port_data_size(port))
	    resize_port_data(port, new_len * 2);
	  memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj));
	  port_position(port) = new_len;
	}
      else port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port);
    }
}

static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  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 (!string_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
	    {
	      char *str;
	      int nlen = 0;
	      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);
    }
}

static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write)
{
  s7_int i, len;
  int plen;
  bool too_long = false;

  len = string_length(vect);
  if (use_write == USE_READABLE_WRITE)
    plen = len;
  else plen = sc->print_length;

  if (len == 0)
    port_write_string(port)(sc, "#u8()", 5, port);
  else
    {
      if (plen <= 0)
	port_write_string(port)(sc, "#u8(...)", 8, port);
      else
	{
	  unsigned int nlen;
	  char *p;
	  if (len > plen)
	    {
	      too_long = true;
	      len = plen;
	    }
	  port_write_string(port)(sc, "#u8(", 4, port);
	  for (i = 0; i < len - 1; i++)
	    {
	      p = pos_int_to_str((int)((unsigned char)string_value(vect)[i]), &nlen, ' ');
	      port_write_string(port)(sc, p, nlen - 1, port);
	    }
	  p = pos_int_to_str((int)((unsigned char)string_value(vect)[i]), &nlen, (too_long) ? '\0' : ')');
	  port_write_string(port)(sc, p, nlen - 1, port);

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	}
    }
}


static void int_or_float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write)
{
  s7_int i, len;
  int plen;
  bool too_long = false;

  len = vector_length(vect);
  if (use_write == USE_READABLE_WRITE)
    plen = len;
  else plen = sc->print_length;

  if (len == 0)
    port_write_string(port)(sc, "#()", 3, port);
  else
    {
      if (plen <= 0)
	port_write_string(port)(sc, "#(...)", 6, port);
      else
	{
	  char buf[128];
	  if (len > plen)
	    {
	      too_long = true;
	      len = plen;
	    }
	  if (is_int_vector(vect))
	    {
	      if (vector_rank(vect) > 1)
		port_write_string(port)(sc, "(make-shared-vector (int-vector", 31, port);
	      else port_write_string(port)(sc, "(int-vector", 11, port);

	      if (!is_string_port(port))
		{
		  for (i = 0; i < len; i++)
		    {
		      plen = snprintf(buf, 128, " %lld", int_vector_element(vect, i));
		      port_write_string(port)(sc, buf, plen, port);
		    }
		}
	      else
		{
		  /* an experiment */
		  int new_len, next_len;
		  unsigned char *dbuf;
		  new_len = port_position(port);
		  next_len = port_data_size(port) - 128;
		  dbuf = port_data(port);

		  for (i = 0; i < len; i++)
		    {
		      if (new_len >= next_len)
			{
			  resize_port_data(port, port_data_size(port) * 2);
			  next_len = port_data_size(port) - 128;
			  dbuf = port_data(port);
			}
		      plen = snprintf((char *)(dbuf + new_len), 128, " %lld", int_vector_element(vect, i));
		      new_len += plen;
		    }
		  port_position(port) = new_len;
		}
	    }
	  else
	    {
	      if (vector_rank(vect) > 1)
		port_write_string(port)(sc, "(make-shared-vector (float-vector", 33, port);
	      else port_write_string(port)(sc, "(float-vector", 13, port);

	      for (i = 0; i < len; i++)
		{
		  port_write_character(port)(sc, ' ', port);
		  plen = snprintf(buf, 124, float_format_g, float_format_precision, float_vector_element(vect, i)); /* 124 so floatify has room */
		  floatify(buf, &plen);
		  port_write_string(port)(sc, buf, plen, port);
		}
	    }

	  if (too_long)
	    port_write_string(port)(sc, " ...)", 5, port);
	  else port_write_character(port)(sc, ')', port);

	  if (vector_rank(vect) > 1)
	    {
	      unsigned int dim;
	      port_write_string(port)(sc, " '(", 3, port);
	      for (dim = 0; dim < vector_ndims(vect) - 1; dim++)
		{
		  plen = snprintf(buf, 128, "%lld ", vector_dimension(vect, dim));
		  port_write_string(port)(sc, buf, plen, port);
		}
	      plen = snprintf(buf, 128, "%lld", vector_dimension(vect, dim));
	      port_write_string(port)(sc, buf, plen, port);
	      port_write_string(port)(sc, "))", 2, port);
	    }
	}
    }
}


static void list_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info *ci)
{
  /* we need list_to_starboard... */
  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_symbol) ||
       (car(lst) == sc->quote_unchecked_symbol)) && /* 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)
       */
      port_write_character(port)(sc, '\'', port);
      object_to_port_with_circle_check(sc, cadr(lst), port, USE_WRITE, 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, 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, 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, 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, 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, ci);
		}
	      port_write_character(port)(sc, ' ', port);
	      object_to_port_with_circle_check(sc, x, port, use_write, ci);
	      for (i = 1; i < len; i++)
		port_write_character(port)(sc, ')', port);
	    }
	}
    }
  else
    {
      if (ci)
	{
	  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), 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), ci);
	    }
	  port_write_character(port)(sc, ')', port);
	}
      else
	{
	  for (x = lst, i = 0; (is_pair(x)) && (i < len); i++, x = cdr(x))
	    {
	      object_to_port(sc, car(x), port, DONT_USE_DISPLAY(use_write), ci);
	      if (i < (len - 1))
		port_write_character(port)(sc, ' ', port);
	    }
	  if (is_not_null(x))
	    {
	      port_write_string(port)(sc, ". ", 2, port);
	      object_to_port(sc, x, port, DONT_USE_DISPLAY(use_write), 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, shared_info *ci)
{
  int i, len, gc_iter;
  bool too_long = false;
  s7_pointer iterator, p;

  /* 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)
    {
      port_write_string(port)(sc, "(hash-table)", 12, port);
      return;
    }

  if (use_write != USE_READABLE_WRITE)
    {
      s7_int plen;
      plen = sc->print_length;
      if (plen <= 0)
	{
	  port_write_string(port)(sc, "(hash-table ...)", 16, port);
	  return;
	}
      if (len > plen)
	{
	  too_long = true;
	  len = plen;
	}
    }

  iterator = s7_make_iterator(sc, hash);
  gc_iter = s7_gc_protect(sc, iterator);
  p = cons(sc, sc->F, sc->F);
  iterator_current(iterator) = p;
  set_mark_seq(iterator);

  if ((use_write == USE_READABLE_WRITE) &&
      (ci) &&
      (peek_shared_ref(ci, hash) != 0))
    {
      port_write_string(port)(sc, "(let (({ht} (make-hash-table)))", 31, port);
      if (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, 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, ci);
	  port_write_character(port)(sc, ')', port);
	}
      port_write_string(port)(sc, " {ht})", 6, port);
    }
  else
    {
      port_write_string(port)(sc, "(hash-table", 11, port);
      for (i = 0; i < len; i++)
	{
	  s7_pointer key_val;
	  if (use_write == USE_READABLE_WRITE)
	    port_write_character(port)(sc, ' ', port);
	  else port_write_string(port)(sc, " '", 2, port);
	  key_val = hash_table_iterate(sc, iterator);
	  object_to_port_with_circle_check(sc, key_val, port, DONT_USE_DISPLAY(use_write), 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 int slot_to_port_1(s7_scheme *sc, s7_pointer x, s7_pointer port, use_write_t use_write, shared_info *ci, int n)
{
  if (is_slot(x))
    {
      n = slot_to_port_1(sc, next_slot(x), port, use_write, ci, n);
      if (n <= sc->print_length)
	{
	  port_write_character(port)(sc, ' ', port);
	  object_to_port_with_circle_check(sc, x, port, use_write, ci);
	}
      if (n == (sc->print_length + 1))
	port_write_string(port)(sc, " ...", 4, port);
    }
  return(n + 1);
}

static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, 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_symbol);
      if (print_func != sc->undefined)
	{
	  s7_pointer p;
	  /* what needs to be protected here? for one, the function might not return a string! */

	  clear_has_methods(obj);
	  if (use_write == 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_symbol));
	  set_has_methods(obj);

	  if ((is_string(p)) && 
	      (string_length(p) > 0))
	    port_write_string(port)(sc, string_value(p), string_length(p), port);
	  return;
	}
    }
  if (obj == sc->rootlet)
    port_write_string(port)(sc, "(rootlet)", 9, port);
  else
    {
      if (sc->short_print)
	port_write_string(port)(sc, "#<let>", 6, port);
      else
	{
	  /* circles can happen here:
	   *    (let () (let ((b (curlet))) (curlet)))
	   *    #<let 'b #<let>>
	   * or (let ((b #f)) (set! b (curlet)) (curlet))
	   *    #1=#<let 'b #1#>
	   */
	  if ((use_write == USE_READABLE_WRITE) &&
	      (ci) &&
	      (peek_shared_ref(ci, obj) != 0))
	    {
	      s7_pointer x;
	      port_write_string(port)(sc, "(let (({e} (inlet))) ", 21, 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 varlet {e} (reverse (list ", 33, port);
	      for (x = let_slots(obj); is_slot(x); x = next_slot(x))
		{
		  port_write_string(port)(sc, "(cons ", 6, port);
		  symbol_to_port(sc, slot_symbol(x), port, use_write);
		  port_write_character(port)(sc, ' ', port);
		  object_to_port_with_circle_check(sc, slot_value(x), port, use_write, ci);
		  port_write_character(port)(sc, ')', port);
		}
	      port_write_string(port)(sc, "))) {e})", 8, port);
	    }
	  else
	    {
	      port_write_string(port)(sc, "(inlet", 6, port);
	      slot_to_port_1(sc, let_slots(obj), port, use_write, ci, 0);
	      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;

  body = closure_body(obj);
  arglist = closure_args(obj);

  port_write_string(port)(sc, "(define-", 8, port);
  port_write_string(port)(sc, ((is_macro(obj)) || (is_macro_star(obj))) ? "macro" : "bacro", 5, port);
  if ((is_macro_star(obj)) || (is_bacro_star(obj)))
    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, NULL);
	    }
	  if (!is_null(expr))
	    {
	      port_write_string(port)(sc, " . ", 3, port);
	      object_to_port(sc, expr, port, USE_WRITE, 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, NULL);
  port_write_character(port)(sc, ')', port);
}


static s7_pointer match_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  s7_pointer y, le;
  for (le = e; is_let(le) && (le != sc->rootlet); le = outlet(le))
    for (y = let_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(car(x)) == symbol)
      return(true);
  return(false);
}

static bool arg_memq(s7_pointer symbol, s7_pointer args)
{
  s7_pointer x;
  for (x = args; is_pair(x); x = cdr(x))
    if ((car(x) == symbol) ||
	((is_pair(car(x))) &&
	 (caar(x) == symbol)))
      return(true);
  return(false);
}


static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, s7_pointer args, int gc_loc)
{
  if (is_pair(body))
    {
      collect_locals(sc, car(body), e, args, gc_loc);
      collect_locals(sc, cdr(body), e, args, gc_loc);
    }
  else
    {
      if ((is_symbol(body)) &&
	  (!arg_memq(body, args)) &&
	  (!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 s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer cur_env)
{
  s7_pointer e, y;
  for (e = cur_env; is_let(e); e = outlet(e))
    {
      if ((is_function_env(e)) &&
	  (is_global(funclet_function(e))) &&         /* (define (f1) (lambda () 1)) shouldn't say the returned closure is named f1 */
	  (slot_value(global_slot(funclet_function(e))) == closure))
	return(funclet_function(e));

      for (y = let_slots(e); is_slot(y); y = next_slot(y))
	if (slot_value(y) == closure)
	  return(slot_symbol(y));
    }
  return(sc->nil);
}

static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port)
{
  s7_pointer x;
  x = find_closure(sc, closure, closure_let(closure));
  /* this can be confusing!  In some cases, the function is in its environment, and in other very similar-looking cases it isn't:
   * (let ((a (lambda () 1))) a)
   * #<lambda ()>
   * (letrec ((a (lambda () 1))) a)
   * a
   * (let () (define (a) 1) a)
   * a
   */
  if (is_symbol(x)) /* after find_closure */
    {
      port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port);
      return;
    }
  
  /* names like #<closure> and #<macro> are useless -- try to be a bit more informative */
  switch (type(closure))
    {
    case T_CLOSURE:      
      port_write_string(port)(sc, "#<lambda ", 9, port);  
      break;

    case T_CLOSURE_STAR: 
      port_write_string(port)(sc, "#<lambda* ", 10, port);  
      break;

    case T_MACRO:        
      if (is_expansion(closure)) 
	port_write_string(port)(sc, "#<expansion ", 12, port); 
      else port_write_string(port)(sc, "#<macro ", 8, port); 
      break;

    case T_MACRO_STAR:   
      port_write_string(port)(sc, "#<macro* ", 9, port);  
      break;
						   
    case T_BACRO:        
      port_write_string(port)(sc, "#<bacro ", 8, port);   
      break;

    case T_BACRO_STAR:   
      port_write_string(port)(sc, "#<bacro* ", 9, port); 
      break;
    }

  if (is_null(closure_args(closure)))
    port_write_string(port)(sc, "()>", 3, port);
  else
    {
      s7_pointer args;
      args = closure_args(closure);
      if (is_symbol(args))
	{
	  port_write_string(port)(sc, symbol_name(args), symbol_name_length(args), port);
	  port_write_character(port)(sc, '>', port);    /* (lambda a a) -> #<lambda a> */
	}
      else
	{
	  port_write_character(port)(sc, '(', port);
	  x = car(args);
	  if (is_pair(x)) x = car(x);
	  port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port);
	  if (!is_null(cdr(args)))
	    {
	      s7_pointer y;
	      port_write_character(port)(sc, ' ', port);
	      if (is_pair(cdr(args)))
		{
		  y = cadr(args);
		  if (is_pair(y)) 
		    y = car(y);
		  else
		    {
		      if (y == sc->key_rest_symbol)
			{
			  port_write_string(port)(sc, ":rest ", 6, port);
			  args = cdr(args);
			  y = cadr(args);
			  if (is_pair(y)) y = car(y);
			}
		    }
		}
	      else 
		{
		  port_write_string(port)(sc, ". ", 2, port);
		  y = cdr(args);
		}
	      port_write_string(port)(sc, symbol_name(y), symbol_name_length(y), port);
	      if ((is_pair(cdr(args))) &&
		  (!is_null(cddr(args))))
		port_write_string(port)(sc, " ...", 4, port);
	    }
	  port_write_string(port)(sc, ")>", 2, port);
	}
    }
}

static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure)
{
  /* this is used by the error handlers to get the current function name
   */
  s7_pointer x;

  x = find_closure(sc, closure, sc->envir);
  if (is_symbol(x))
    return(x);

  if (is_pair(current_code(sc)))
    return(current_code(sc));

  return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */
}


static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port)
{
  s7_int old_print_length;
  s7_pointer p;

  if (type(obj) == T_CLOSURE_STAR)  
    port_write_string(port)(sc, "(lambda* ", 9, port);
  else port_write_string(port)(sc, "(lambda ", 8, port);

  if ((is_pair(arglist)) &&
      (allows_other_keys(arglist)))
    {
      sc->temp9 = s7_append(sc, arglist, cons(sc, sc->key_allow_other_keys_symbol, sc->nil));
      object_out(sc, sc->temp9, port, USE_WRITE);
      sc->temp9 = sc->nil;
    }
  else object_out(sc, arglist, port, USE_WRITE); /* here we just want the straight output (a b) not (list 'a 'b) */

  old_print_length = sc->print_length;
  sc->print_length = 1048576;
  for (p = body; is_pair(p); p = cdr(p))
    {
      port_write_character(port)(sc, ' ', port);
      object_out(sc, car(p), port, USE_WRITE);
    }
  port_write_character(port)(sc, ')', port);
  sc->print_length = old_print_length;
}

static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  s7_pointer body, arglist, pe, local_slots, setter = NULL;
  int gc_loc;
  
  body = closure_body(obj);
  arglist = closure_args(obj);
  pe = closure_let(obj);               /* perhaps check for documentation? */

  gc_loc = s7_gc_protect(sc, sc->nil);
  collect_locals(sc, body, pe, arglist, gc_loc);   /* collect locals used only here */
  if (s7_is_dilambda(obj))
    {
      setter = closure_setter(obj);
      if ((!(has_closure_let(setter))) ||
	  (closure_let(setter) != pe))
	setter = NULL;
    }
  if (setter)
    collect_locals(sc, closure_body(setter), pe, closure_args(setter), gc_loc);
  local_slots = _TLst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */

  if (!is_null(local_slots))
    {
      s7_pointer x;
      port_write_string(port)(sc, "(let (", 6, port);
      for (x = local_slots; is_pair(x); x = cdr(x))
	{
	  s7_pointer slot;
	  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);
	  object_out(sc, slot_value(slot), port, USE_WRITE);
	  if (is_null(cdr(x)))
	    port_write_character(port)(sc, ')', port);
	  else port_write_string(port)(sc, ") ", 2, port);
	}
      port_write_string(port)(sc, ") ", 2, port);
    }

  if (setter)
    port_write_string(port)(sc, "(dilambda ", 10, port);

  write_closure_readably_1(sc, obj, arglist, body, port);

  if (setter)
    {
      port_write_character(port)(sc, ' ', port);
      write_closure_readably_1(sc, setter, closure_args(setter), closure_body(setter), port);
      port_write_character(port)(sc, ')', port);
    }

  if (!is_null(local_slots))
    port_write_character(port)(sc, ')', port);
  s7_gc_unprotect_at(sc, gc_loc);
}


#if TRAP_SEGFAULT
#include <signal.h>
static sigjmp_buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */
static volatile sig_atomic_t can_jump = 0;
static void segv(int ignored) {if (can_jump) siglongjmp(senv, 1);}
#endif

bool s7_is_valid(s7_scheme *sc, s7_pointer arg)
{
  bool result = false;
  if (!arg) return(false);

#if TRAP_SEGFAULT
  if (sigsetjmp(senv, 1) == 0)
    {
      void (*old_segv)(int sig);
      can_jump = 1;
      old_segv = signal(SIGSEGV, segv);
#endif
      result = ((!is_free(arg)) &&
		(type(arg) < NUM_TYPES) &&
		(arg->hloc >= not_heap) &&
		((arg->hloc < 0) ||
		 ((arg->hloc < (int)sc->heap_size) && (sc->heap[arg->hloc] == arg))));

#if TRAP_SEGFAULT
      signal(SIGSEGV, old_segv);
    }
  else result = false;
  can_jump = 0;
#endif

  return(result);
}

enum {NO_ARTICLE, INDEFINITE_ARTICLE};

static char *describe_type_bits(s7_scheme *sc, s7_pointer obj)
{
  unsigned int full_typ;
  unsigned char typ;
  char *buf;

  buf = (char *)malloc(512 * sizeof(char));
  typ = unchecked_type(obj);
  full_typ = typeflag(obj);

  /* if debugging all of these bits are being watched, so we need some ugly subterfuges */
  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%s%s",
	   typ,
	   type_name(sc, obj, NO_ARTICLE),
	   full_typ,
	   ((full_typ & T_PROCEDURE) != 0) ?             " procedure" : "",
	   ((full_typ & T_GC_MARK) != 0) ?               " gc-marked" : "",
	   ((full_typ & T_IMMUTABLE) != 0) ?             " immutable" : "",
	   ((full_typ & T_EXPANSION) != 0) ?             " expansion" : "",
	   ((full_typ & T_MULTIPLE_VALUE) != 0) ?        " values or matched" : "",
	   ((full_typ & T_KEYWORD) != 0) ?               " keyword" : "",
	   ((full_typ & T_DONT_EVAL_ARGS) != 0) ?        " dont-eval-args" : "",
	   ((full_typ & T_SYNTACTIC) != 0) ?             " syntactic" : "",
	   ((full_typ & T_OVERLAY) != 0) ?               " overlay" : "",
	   ((full_typ & T_CHECKED) != 0) ?               " checked" : "",
	   ((full_typ & T_UNSAFE) != 0) ?                ((is_symbol(obj)) ? " clean" : " unsafe") : "",
	   ((full_typ & T_OPTIMIZED) != 0) ?             " optimized" : "",
	   ((full_typ & T_SAFE_CLOSURE) != 0) ?          " safe-closure" : "",
	   ((full_typ & T_SAFE_PROCEDURE) != 0)  ?       " safe-procedure" : "",
	   ((full_typ & T_SETTER) != 0) ?                " setter" : "",
	   ((full_typ & T_COPY_ARGS) != 0) ?             " copy-args" : "",
	   ((full_typ & T_COLLECTED) != 0) ?             " collected" : "",
	   ((full_typ & T_SHARED) != 0) ?                " shared" : "",
	   ((full_typ & T_HAS_METHODS) != 0) ?           " has-methods" : "",
	   ((full_typ & T_GLOBAL) != 0) ?                ((is_pair(obj)) ? " unsafe-do" : " global") : "",
	   ((full_typ & T_SAFE_STEPPER) != 0) ?          ((is_let(obj)) ? " let-set!-fallback" : ((is_slot(obj)) ? " safe-stepper" : " print-name")) : "",
	   ((full_typ & T_LINE_NUMBER) != 0) ? 
	        ((is_pair(obj)) ? " line number" : ((is_input_port(obj)) ? " loader-port" : ((is_let(obj)) ? " with-let" : " has accessor"))) : "",
	   ((full_typ & T_MUTABLE) != 0) ? 
               ((is_string(obj)) ? " byte-vector" : ((is_let(obj)) ? " let-ref-fallback" : 
		   ((is_iterator(obj)) ? " mark-seq" : ((is_slot(obj)) ? " stepper" : " mutable")))) : "",
	   ((full_typ & T_GENSYM) != 0) ?             
               ((is_let(obj)) ? " function-env" : ((is_unspecified(obj)) ? " no-value" : ((is_pair(obj)) ? " list-in-use" :
	       ((is_closure_star(obj)) ? " simple-args" : ((is_string(obj)) ? " documented" : " gensym"))))) : "");
  return(buf);
}

#if DEBUGGING
static const char *check_name(int typ)
{
  if ((typ >= 0) && (typ < NUM_TYPES))
    {
      s7_pointer p;
      p = prepackaged_type_names[typ];
      if (is_string(p)) return(string_value(p));
      
      switch (typ)
	{
	case T_C_OBJECT:    return("a c-object");
	case T_INPUT_PORT:  return("an input port");
	case T_OUTPUT_PORT: return("an output port");
	}
    }
  return("unknown type!");
}

static s7_pointer check_seti(s7_scheme *sc, s7_pointer x, const char *func, int line)
{
  if (is_immutable(x)) 
    {
      fprintf(stderr, "%s%s[%d]: set! immutable %s: %s%s\n", BOLD_TEXT, func, line, type_name(sc, x, NO_ARTICLE), DISPLAY(x), UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(x);
}

static s7_pointer check_ref(s7_pointer p, int expected_type, const char *func, int line, const char *func1, const char *func2)
{
  int typ;
  typ = unchecked_type(p);
  if (typ != expected_type)
    {
      if ((!func1) || (typ != T_FREE))
	{
	  fprintf(stderr, "%s%s[%d]: not %s, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(expected_type), check_name(typ), typ, UNBOLD_TEXT);
	  if (stop_at_error) abort();
	}
      else
	{
	  if ((strcmp(func, func1) != 0) &&
	      ((!func2) || (strcmp(func, func2) != 0)))
	    {
	      fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", BOLD_TEXT, func, line, check_name(expected_type), UNBOLD_TEXT);
	      if (stop_at_error) abort();
	    }
	}
    }
  return(p);
}

static s7_pointer check_ref2(s7_pointer p, int expected_type, int other_type, const char *func, int line, const char *func1, const char *func2)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ != expected_type) && (typ != other_type))
    return(check_ref(p, expected_type, func, line, func1, func2));
  return(p);
}

static s7_pointer check_ref3(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE))
    {
      fprintf(stderr, "%s%s[%d]: not a port, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref4(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ != T_VECTOR) && (typ != T_FLOAT_VECTOR) && (typ != T_INT_VECTOR) && (typ != T_FREE))
    {
      fprintf(stderr, "%s%s[%d]: not a vector, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref5(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if (!t_has_closure_let[typ])
    {
      fprintf(stderr, "%s%s[%d]: not a closure, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref6(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ < T_C_FUNCTION_STAR) && (typ != T_C_MACRO))
    {
      fprintf(stderr, "%s%s[%d]: not a c function, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref7(s7_pointer p, const char *func, int line)
{
  if ((!func) || (strcmp(func, "decribe_type_bits") != 0))
    {
      int typ;
      typ = unchecked_type(p);
      if ((typ < T_INTEGER) || (typ > T_COMPLEX))
	{
	  fprintf(stderr, "%s%s[%d]: not a number, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
	  if (stop_at_error) abort();
	}
    }
  return(p);
}

static s7_pointer check_ref8(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure calling itself an iterator?? */
    {
      fprintf(stderr, "%s%s[%d]: not a sequence or structure, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref9(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)))
    {
      fprintf(stderr, "%s%s[%d]: not a possible method holder, but %s (%d)%s\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref10(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL))
    {
      fprintf(stderr, "%s%s[%d]: arglist is %s (%d)%s?\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_ref11(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if ((typ < T_CLOSURE) && (typ != T_BOOLEAN)) /* actually #t is an error here */
    {
      fprintf(stderr, "%s%s[%d]: setter is %s (%d)%s?\n", BOLD_TEXT, func, line, check_name(typ), typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static s7_pointer check_nref(s7_pointer p, const char *func, int line)
{
  int typ;
  typ = unchecked_type(p);
  if (typ == T_FREE)
    {
      fprintf(stderr, "%s%s[%d]: attempt to use cleared type%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  if ((typ < 0) || (typ >= NUM_TYPES))
    {
      fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", BOLD_TEXT, func, line, typ, UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}

static void print_gc_info(s7_pointer obj, int line)
{
  fprintf(stderr, "%s%p is free (line %d), current: %s[%d], previous: %s[%d],  gc call: %s[%d], clear: %d, alloc: %s[%d]%s\n",
	  BOLD_TEXT, 
	  obj, line,
	  obj->current_alloc_func, obj->current_alloc_line,
	  obj->previous_alloc_func, obj->previous_alloc_line,
	  obj->gc_func, obj->gc_line, obj->clear_line, obj->alloc_func, obj->alloc_line,
	  UNBOLD_TEXT);
  abort();
}

static void show_opt1_bits(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  fprintf(stderr, "%sopt1 %s[%d]: %p->%p %x%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s\n", BOLD_TEXT, func, line, p, p->object.cons.opt1, p->debugger_bits,
	  ((p->debugger_bits & E_SET) != 0) ? " e-set" : "",
	  ((p->debugger_bits & E_FAST) != 0) ? " fast" : "",
	  ((p->debugger_bits & E_CFUNC) != 0) ? " cfunc" : "",
	  ((p->debugger_bits & E_CLAUSE) != 0) ? " clause" : "",
	  ((p->debugger_bits & E_BACK) != 0) ? " back" : "",
	  ((p->debugger_bits & E_LAMBDA) != 0) ? " lambda" : "",
	  ((p->debugger_bits & E_SYM) != 0) ? " sym" : "",
	  ((p->debugger_bits & E_PAIR) != 0) ? " pair" : "",
	  ((p->debugger_bits & E_CON) != 0) ? " con" : "",
	  ((p->debugger_bits & E_GOTO) != 0) ? " goto" : "",
	  ((p->debugger_bits & E_VECTOR) != 0) ? " vector" : "",
	  ((p->debugger_bits & E_ANY) != 0) ? " any" : "",
	  ((p->debugger_bits & E_SLOT) != 0) ? " slot" : "",
	  ((p->debugger_bits & S_HASH) != 0) ? " raw-hash" : "",	
  UNBOLD_TEXT);
}

static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line)
{
  if ((!opt1_is_set(p)) ||
      ((!opt1_role_matches(p, role)) &&
       (role != E_ANY)))
    {
      show_opt1_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.cons.opt1);
}

static s7_pointer set_opt1_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line)
{
  p->object.cons.opt1 = x;
  set_opt1_role(p, role);
  set_opt1_is_set(p);
  return(x);
}

static unsigned long long int s_hash_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt1_is_set(p)) ||
      (!opt1_role_matches(p, S_HASH)))
    {
      show_opt1_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.hash);
}

static void set_s_hash_1(s7_scheme *sc, s7_pointer p, unsigned long long int x, const char *func, int line)
{
  p->object.sym_cons.hash = x;
  set_opt1_role(p, S_HASH);
  set_opt1_is_set(p);
}

static void show_opt2_bits(s7_scheme *sc, s7_pointer p, const char *func, int line, unsigned int role)
{
  fprintf(stderr, "%s%s[%d]: opt2: %p->%p is %x%s%s%s%s%s%s%s%s%s but expects %x%s%s%s%s%s%s%s%s%s%s\n", 
	  BOLD_TEXT, func, line, p, p->object.cons.opt2, 

	  p->debugger_bits,
	  ((p->debugger_bits & F_SET) != 0) ? " f-set" : "",
	  ((p->debugger_bits & F_KEY) != 0) ? " key" : "",
	  ((p->debugger_bits & F_SLOW) != 0) ? " slow" : "",
	  ((p->debugger_bits & F_SYM) != 0) ? " sym" : "",
	  ((p->debugger_bits & F_PAIR) != 0) ? " pair" : "",
	  ((p->debugger_bits & F_CON) != 0) ? " con" : "",
	  ((p->debugger_bits & F_CALL) != 0) ? " call" : "",
	  ((p->debugger_bits & F_LAMBDA) != 0) ? " lambda" : "",
	  ((p->debugger_bits & S_NAME) != 0) ? " raw-name" : "",

	  role,
	  ((role & F_SET) != 0) ? " f-set" : "",
	  ((role & F_KEY) != 0) ? " key" : "",
	  ((role & F_SLOW) != 0) ? " slow" : "",
	  ((role & F_SYM) != 0) ? " sym" : "",
	  ((role & F_PAIR) != 0) ? " pair" : "",
	  ((role & F_CON) != 0) ? " con" : "",
	  ((role & F_CALL) != 0) ? " call" : "",
	  ((role & F_LAMBDA) != 0) ? " lambda" : "",
	  ((role & S_NAME) != 0) ? " raw-name" : "",

	  UNBOLD_TEXT);
}

static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line)
{
  if ((!opt2_is_set(p)) ||
      (!opt2_role_matches(p, role)))
    {
      show_opt2_bits(sc, p, func, line, role);
      fprintf(stderr, "p: %s\n", DISPLAY(p));
      if (stop_at_error) abort();
    }
  return(p->object.cons.opt2);
}

static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line)
{
  p->object.cons.opt2 = x;
  set_opt2_role(p, role);
  set_opt2_is_set(p);
}

static const char *s_name_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt2_is_set(p)) ||
      (!opt2_role_matches(p, S_NAME)))
    {
      show_opt2_bits(sc, p, func, line, (unsigned int)S_NAME);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.fstr);
}

static void set_s_name_1(s7_scheme *sc, s7_pointer p, const char *str, const char *func, int line)
{
  p->object.sym_cons.fstr = str;
  set_opt2_role(p, S_NAME);
  set_opt2_is_set(p);
}

static void show_opt3_bits(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  fprintf(stderr, "%s%s[%d]: opt3: %x%s%s%s%s%s%s%s%s%s\n", BOLD_TEXT, func, line, 
	  p->debugger_bits, 
	  ((p->debugger_bits & G_SET) != 0) ? " g-set" : "",
	  ((p->debugger_bits & G_ARGLEN) != 0) ? " arglen" : "",
	  ((p->debugger_bits & G_SYM) != 0) ? " sym" : "",
	  ((p->debugger_bits & G_AND) != 0) ? " and" : "",
	  ((p->debugger_bits & S_LINE) != 0) ? " line" : "",
	  ((p->debugger_bits & S_LEN) != 0) ? " len" : "",
	  ((p->debugger_bits & S_OP) != 0) ? " op" : "",
	  ((p->debugger_bits & S_SYNOP) != 0) ? " syn-op" : "",
	  UNBOLD_TEXT);
}

static s7_pointer opt3_1(s7_scheme *sc, s7_pointer p, unsigned int role, const char *func, int line)
{
  if ((!opt3_is_set(p)) || 
      (!opt3_role_matches(p, role)))
    {
      show_opt3_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.cons.opt3);
}

static void set_opt3_1(s7_scheme *sc, s7_pointer p, s7_pointer x, unsigned int role, const char *func, int line)
{
  typeflag(p) &= ~(T_OPTIMIZED | T_LINE_NUMBER);
  p->object.cons.opt3 = x;
  set_opt3_is_set(p);
  set_opt3_role(p, role);
}

/* S_LINE */
static unsigned int s_line_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt3_is_set(p)) || 
      ((p->debugger_bits & S_LINE) == 0) ||
      (!has_line_number(p)))
    {
      show_opt3_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.line);
}

static void set_s_line_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line)
{
  p->object.sym_cons.line = x;
  (p)->debugger_bits = (S_LINE | (p->debugger_bits & ~S_LEN)); /* turn on line, cancel len */
  set_opt3_is_set(p);
}

/* S_LEN (collides with S_LINE) */
static unsigned int s_len_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt3_is_set(p)) || 
      ((p->debugger_bits & S_LEN) == 0) ||
      (has_line_number(p)))
    {
      show_opt3_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.line);
}

static void set_s_len_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line)
{
  typeflag(p) &= ~(T_LINE_NUMBER);
  p->object.sym_cons.line = x;
  (p)->debugger_bits = (S_LEN | (p->debugger_bits & ~(S_LINE)));
  set_opt3_is_set(p);
}

/* S_OP */
static unsigned int s_op_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt3_is_set(p)) || 
      ((p->debugger_bits & S_OP) == 0))
    {
      show_opt3_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.op);
}

static void set_s_op_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line)
{
  p->object.sym_cons.op = x;
  (p)->debugger_bits = (S_OP | (p->debugger_bits & ~(S_SYNOP)));
  set_opt3_is_set(p);
}

/* S_SYNOP (collides with S_OP) */
static unsigned int s_syn_op_1(s7_scheme *sc, s7_pointer p, const char *func, int line)
{
  if ((!opt3_is_set(p)) || 
      ((p->debugger_bits & S_SYNOP) == 0))
    {
      show_opt3_bits(sc, p, func, line);
      if (stop_at_error) abort();
    }
  return(p->object.sym_cons.op);
}

static void set_s_syn_op_1(s7_scheme *sc, s7_pointer p, unsigned int x, const char *func, int line)
{
  p->object.sym_cons.op = x;
  (p)->debugger_bits = (S_SYNOP | (p->debugger_bits & ~(S_OP)));
  set_opt3_is_set(p);
}

static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  /* show current state, current allocated state, and previous allocated state.
   */
  char *current_bits, *allocated_bits, *previous_bits, *str;
  int save_typeflag, len, nlen;
  const char *excl_name;

  if (is_free(obj))
    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;
  tmpbuf_malloc(str, len);

  nlen = snprintf(str, len,
		  "\n<%s %s,\n  current: %s[%d] %s,\n  previous: %s[%d] %s\n  hloc: %d (%d uses), free: %s[%d], clear: %d, alloc: %s[%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), obj->uses,
		  obj->gc_func, obj->gc_line, obj->clear_line, obj->alloc_func, obj->alloc_line);

  free(current_bits);
  free(allocated_bits);
  free(previous_bits);
  if (is_null(port))
    fprintf(stderr, "%p: %s\n", obj, str);
  else port_write_string(port)(sc, str, nlen, port);
  tmpbuf_free(str, len);
}

static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int line, const char *func)
{
  if (!p)
    {
      fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, symbol_name(sym), UNBOLD_TEXT);
      if (stop_at_error) abort();
    }
  return(p);
}
#endif

static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
{
  if (use_write == USE_READABLE_WRITE)
    {
      if (iterator_is_at_end(obj))
	port_write_string(port)(sc, "(make-iterator #())", 19, port);
      else
	{
	  s7_pointer seq;
	  seq = iterator_sequence(obj);
	  if ((is_string(seq)) && (!is_byte_vector(seq)))
	    {
	      port_write_string(port)(sc, "(make-iterator \"", 16, port);
	      port_write_string(port)(sc, (char *)(string_value(seq) + iterator_position(obj)), string_length(seq) - iterator_position(obj), port);
	      port_write_string(port)(sc, "\")", 2, port);
	    }
	  else
	    {
	      if (iterator_position(obj) > 0)
		port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port);
	      else port_write_string(port)(sc, "(make-iterator ", 15, port);
	      object_to_port_with_circle_check(sc, iterator_sequence(obj), port, use_write, ci);
	      if (iterator_position(obj) > 0)
		{
		  int nlen;
		  char *str;
		  str = (char *)malloc(128 * sizeof(char));
		  nlen = snprintf(str, 128, "))) (do ((i 0 (+ i 1))) ((= i %lld) iter) (iterate iter)))", iterator_position(obj));
		  port_write_string(port)(sc, str, nlen, port);
		  free(str);
		}
	      else port_write_character(port)(sc, ')', port);
	    }
	}
    }
  else
    {
      const char *str;
      str = type_name(sc, iterator_sequence(obj), NO_ARTICLE);
      port_write_string(port)(sc, "#<iterator: ", 12, port);
      port_write_string(port)(sc, str, safe_strlen(str), port);
      port_write_character(port)(sc, '>', port);
    }
}

static void baffle_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  int nlen;
  char buf[64];
  nlen = snprintf(buf, 64, "#<baffle: %d>", baffle_key(obj));
  port_write_string(port)(sc, buf, nlen, port);
}

static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  int nlen;
  char buf[64];

  if (use_write == USE_READABLE_WRITE)
    nlen = snprintf(buf, 64, "(c-pointer " INT_FORMAT ")", (ptr_int)raw_pointer(obj));
  else nlen = snprintf(buf, 64, "#<c_pointer %p>", raw_pointer(obj));
  port_write_string(port)(sc, buf, nlen, port);
}

static void rng_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write)
{
  int nlen;
  char buf[128];
#if WITH_GMP
  if (use_write == USE_READABLE_WRITE)
    nlen = snprintf(buf, 128, "#<unprint-readable object>");
  else nlen = snprintf(buf, 128, "#<rng %p>", obj);
#else
  if (use_write == USE_READABLE_WRITE)
    nlen = snprintf(buf, 128, "(random-state %llu %llu)", random_seed(obj), random_carry(obj));
  else nlen = snprintf(buf, 128, "#<rng %llu %llu>", random_seed(obj), random_carry(obj));
#endif
  port_write_string(port)(sc, buf, nlen, port);
}

static void object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
{
  int nlen;
  char *str;
  switch (type(obj))
    {
    case T_FLOAT_VECTOR:
    case T_INT_VECTOR:
      int_or_float_vector_to_port(sc, obj, port, use_write);
      break;

    case T_VECTOR:
      vector_to_port(sc, obj, port, use_write, ci);
      break;

    case T_PAIR:
      list_to_port(sc, obj, port, use_write, ci);
      break;

    case T_HASH_TABLE:
      hash_table_to_port(sc, obj, port, use_write, ci);
      break;

    case T_ITERATOR:
      iterator_to_port(sc, obj, port, use_write, ci);
      break;

    case T_LET:
      let_to_port(sc, obj, port, use_write, ci);
      break;

    case T_UNIQUE:
      /* if file has #<eof> it causes read to return #<eof> -> end of read! what is readable version? */
      if ((use_write == USE_READABLE_WRITE) &&
	  (obj == sc->eof_object))
	port_write_string(port)(sc, "(begin #<eof>)", 14, port);
      else port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
      break;

    case T_BOOLEAN:
    case T_NIL:
    case T_UNSPECIFIED:
      port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
      break;

    case T_INPUT_PORT:
      input_port_to_port(sc, obj, port, use_write);
      break;

    case T_OUTPUT_PORT:
      output_port_to_port(sc, obj, port, use_write);
      break;

    case T_COUNTER:
      port_write_string(port)(sc, "#<counter>", 10, port);
      break;

    case T_BAFFLE:
      baffle_to_port(sc, obj, 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, float_format_precision, 'g', &nlen, use_write); /* was 14 */
	  set_print_name(obj, str, nlen);
	  port_write_string(port)(sc, str, nlen, 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);
      port_write_string(port)(sc, str, nlen, port);
      free(str);
      break;
#endif

    case T_SYMBOL:
      symbol_to_port(sc, obj, port, use_write);
      break;

    case T_SYNTAX:
      port_display(port)(sc, symbol_name(syntax_symbol(obj)), port);
      break;

    case T_STRING:
      if (is_byte_vector(obj))
	byte_vector_to_port(sc, obj, port, use_write);
      else string_to_port(sc, obj, port, use_write);
      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_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_let here because then the fallback name is #<let>.
	   */
	  s7_pointer print_func;
	  print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol);
	  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 write_closure_name(sc, obj, port);
      break;

    case T_MACRO:
    case T_MACRO_STAR:
    case T_BACRO:
    case T_BACRO_STAR:
      if (use_write == USE_READABLE_WRITE)
	write_macro_readably(sc, obj, port);
      else write_closure_name(sc, obj, port);
      break;

    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION:
    case T_C_FUNCTION_STAR:
      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:
      c_pointer_to_port(sc, obj, port, use_write);
      break;

    case T_RANDOM_STATE:
      rng_to_port(sc, obj, port, use_write);
      break;

    case T_CONTINUATION:
      if (use_write == USE_READABLE_WRITE)
	port_write_string(port)(sc, "continuation", 12, port);
      else port_write_string(port)(sc, "#<continuation>", 15, port);
      break;

    case T_GOTO:
      if (use_write == USE_READABLE_WRITE)
	port_write_string(port)(sc, "goto", 4, port);
      else port_write_string(port)(sc, "#<goto>", 7, port);
      break;

    case T_CATCH:
      port_write_string(port)(sc, "#<catch>", 8, port);
      break;

    case T_DYNAMIC_WIND:
      /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */
      port_write_string(port)(sc, "#<dynamic-wind>", 15, port);
      break;

    case T_C_OBJECT:
      if (use_write == USE_READABLE_WRITE)
	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)
	port_write_character(port)(sc, '\'', port);
      symbol_to_port(sc, slot_symbol(obj), port, use_write);
      port_write_character(port)(sc, ' ', port);
      object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci);
      break;

    default:
#if DEBUGGING
      print_debugging_state(sc, obj, port);
#else
      {
	char *str, *tmp;
	int len;
	tmp = describe_type_bits(sc, obj);
	len = 32 + safe_strlen(tmp);
	tmpbuf_malloc(str, len);
	if (is_free(obj))
	  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);
	tmpbuf_free(str, len);
      }
#endif
      break;
    }
}


static void object_to_port_with_circle_check(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info *ci)
{
  if ((ci) &&
      (has_structure(vr)))
    {
      int ref;
      ref = shared_ref(ci, vr);
      if (ref != 0)
	{
	  char buf[32];
	  int nlen;
	  char *p;
	  unsigned int len;
	  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, ci);
		  port_write_character(port)(sc, ')', port);
		}
	      else
		{
		  p = pos_int_to_str((s7_int)ref, &len, '=');
		  *--p = '#';
		  port_write_string(port)(sc, p, len, port);
		  object_to_port(sc, vr, port, DONT_USE_DISPLAY(use_write), ci);
		}
	    }
	  else
	    {
	      if (use_write == USE_READABLE_WRITE)
		{
		  nlen = snprintf(buf, 32, "{%d}", -ref);
		  port_write_string(port)(sc, buf, nlen, port);
		}
	      else 
		{
		  p = pos_int_to_str((s7_int)(-ref), &len, '#');
		  *--p = '#';
		  port_write_string(port)(sc, p, len, port);
		}
	    }
	  return;
	}
    }
  object_to_port(sc, vr, port, use_write, ci);
}


static void setup_shared_reads(s7_scheme *sc, s7_pointer port, shared_info *ci)
{
  int i;
  char buf[64];

  port_write_string(port)(sc, "(let (", 6, port);
  for (i = 1; i <= ci->top; i++)
    {
      int len;
      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 object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice)
{
  if ((has_structure(obj)) &&
      (obj != sc->rootlet))
    {
      shared_info *ci;
      ci = make_shared_info(sc, obj, choice != USE_READABLE_WRITE);
      if (ci)
	{
	  if (choice == USE_READABLE_WRITE)
	    {
	      setup_shared_reads(sc, strport, ci);
	      object_to_port_with_circle_check(sc, obj, strport, choice, ci);
	      finish_shared_reads(sc, strport, ci);
	    }
	  else object_to_port_with_circle_check(sc, obj, strport, choice, ci);
	  return(obj);
	}
    }
  object_to_port(sc, obj, strport, choice, NULL);
  return(obj);
}
  

static s7_pointer format_ports = NULL;

static s7_pointer open_format_port(s7_scheme *sc)
{
  s7_pointer x;
  int len;

  if (format_ports)
    {
      x = format_ports;
      format_ports = (s7_pointer)(port_port(x)->next);
      port_position(x) = 0;
      port_data(x)[0] = '\0';
      return(x);
    }

  len = FORMAT_PORT_LENGTH;
  x = alloc_pointer();
  set_type(x, T_OUTPUT_PORT);
  port_port(x) = (port_t *)calloc(1, sizeof(port_t));
  port_type(x) = STRING_PORT;
  port_is_closed(x) = false;
  port_data_size(x) = len;
  port_data(x) = (unsigned char *)malloc(len * sizeof(unsigned char)); /* was +8 */
  port_data(x)[0] = '\0';
  port_position(x) = 0;
  port_needs_free(x) = false;
  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;
  return(x);
}

static void close_format_port(s7_scheme *sc, s7_pointer port)
{
  port_port(port)->next = (void *)format_ports;
  format_ports = port;
}


static char *s7_object_to_c_string_1(s7_scheme *sc, s7_pointer obj, use_write_t use_write, int *nlen)
{
  char *str;
  s7_pointer strport;

  strport = open_format_port(sc);
  object_out(sc, obj, strport, use_write);
  if (nlen) (*nlen) = port_position(strport);

  str = (char *)malloc((port_position(strport) + 1) * sizeof(char));
  memcpy((void *)str, (void *)port_data(strport), port_position(strport));
  str[port_position(strport)] = '\0';
  close_format_port(sc, strport);

  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;
  int len = 0;

  str = s7_object_to_c_string_1(sc, obj, (use_write) ? USE_WRITE : USE_DISPLAY, &len);
  if (str)
    return(make_string_uncopied_with_length(sc, str, len));
  return(s7_make_string_with_length(sc, "", 0));
}


/* -------------------------------- newline -------------------------------- */
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"
  #define Q_newline s7_make_signature(sc, 2, sc->T, sc->is_output_port_symbol)
  s7_pointer port;

  if (is_not_null(args))
    port = car(args);
  else port = sc->output_port;
  if (!is_output_port(port))
    {
      if (port == sc->F) return(sc->unspecified);
      method_or_bust_with_type(sc, port, sc->newline_symbol, args, an_output_port_string, 0);
    }
  s7_newline(sc, port);
  return(sc->unspecified);
}

static s7_pointer c_newline(s7_scheme *sc) {s7_newline(sc, sc->output_port); return(sc->unspecified);}
PF_0(newline, c_newline)


/* -------------------------------- write -------------------------------- */
void s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  if (port != sc->F)
    {
      if (port_is_closed(port))
	s7_wrong_type_arg_error(sc, "write", 2, port, "an open output port");
      object_out(sc, obj, port, USE_WRITE);
    }
}


static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
{
  #define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port"
  #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, sc->is_output_port_symbol)
  s7_pointer port;

  if (is_pair(cdr(args)))
    port = cadr(args);
  else port = sc->output_port;
  if (!is_output_port(port))
    {
      if (port == sc->F) return(car(args));
      method_or_bust_with_type(sc, port, sc->write_symbol, args, an_output_port_string, 2);
    }
  if (port_is_closed(port))
    return(s7_wrong_type_arg_error(sc, "write", 2, port, "an open output port"));
  return(object_out(sc, car(args), port, USE_WRITE));
}

static s7_pointer c_write_i(s7_scheme *sc, s7_int x) {return(g_write(sc, set_plist_1(sc, make_integer(sc, x))));}
static s7_pointer c_write_r(s7_scheme *sc, s7_double x) {return(g_write(sc, set_plist_1(sc, make_real(sc, x))));}
static s7_pointer c_write_p(s7_scheme *sc, s7_pointer x) {return(g_write(sc, set_plist_1(sc, x)));}
XF_TO_PF(write, c_write_i, c_write_r, c_write_p)


/* -------------------------------- display -------------------------------- */
void s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port)
{
  if (port != sc->F)
    {
      if (port_is_closed(port))
	s7_wrong_type_arg_error(sc, "display", 2, port, "an open output port");
      object_out(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"
  #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, sc->is_output_port_symbol)
  s7_pointer port;

  if (is_pair(cdr(args)))
    port = cadr(args);
  else port = sc->output_port;
  if (!is_output_port(port))
    {
      if (port == sc->F) return(car(args));
      method_or_bust_with_type(sc, port, sc->display_symbol, args, an_output_port_string, 2);
    }
  if (port_is_closed(port))
    return(s7_wrong_type_arg_error(sc, "display", 2, port, "an open output port"));
  return(object_out(sc, car(args), port, USE_DISPLAY));
}

static s7_pointer c_display(s7_scheme *sc, s7_pointer x) {return(g_display(sc, set_plist_1(sc, x)));}
PF_TO_PF(display, c_display)


/* -------------------------------- call-with-output-string -------------------------------- */
static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output"
  #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
  s7_pointer port, proc;

  proc = car(args);
  if (is_let(proc))
    check_method(sc, proc, sc->call_with_output_string_symbol, args);
  if (!s7_is_aritable(sc, proc, 1))
    method_or_bust_with_type(sc, proc, sc->call_with_output_string_symbol, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 1);

  if ((is_continuation(proc)) || (is_goto(proc)))
    return(wrong_type_argument_with_type(sc, sc->call_with_output_string_symbol, 1, proc, a_normal_procedure_string));

  port = s7_open_output_string(sc);
  push_stack(sc, OP_GET_OUTPUT_STRING_1, sc->F, port);
  push_stack(sc, OP_APPLY, list_1(sc, port), proc);
  return(sc->F);
}

static s7_pointer c_call_with_output_string(s7_scheme *sc, s7_pointer x) {return(g_call_with_output_string(sc, set_plist_1(sc, x)));}
PF_TO_PF(call_with_output_string, c_call_with_output_string)


/* -------------------------------- call-with-output-file -------------------------------- */
static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args)
{
  #define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument"
  #define Q_call_with_output_file pl_sf
  s7_pointer port, file, proc;

  file = car(args);
  if (!is_string(file))
    method_or_bust(sc, file, sc->call_with_output_file_symbol, args, T_STRING, 1);

  proc = cadr(args);
  if (!s7_is_aritable(sc, proc, 1))
    method_or_bust_with_type(sc, proc, sc->call_with_output_file_symbol, args, make_string_wrapper(sc, "a procedure of one argument (the port)"), 2);

  if ((is_continuation(proc)) || is_goto(proc))
    return(wrong_type_argument_with_type(sc, sc->call_with_output_file_symbol, 2, proc, a_normal_procedure_string));

  port = s7_open_output_file(sc, string_value(file), "w");
  push_stack(sc, OP_UNWIND_OUTPUT, sc->F, port);
  push_stack(sc, OP_APPLY, list_1(sc, port), proc);
  return(sc->F);
}

static s7_pointer c_call_with_output_file(s7_scheme *sc, s7_pointer x) {return(g_call_with_output_file(sc, set_plist_1(sc, x)));}
PF_TO_PF(call_with_output_file, c_call_with_output_file)


/* -------------------------------- with-output-to-string -------------------------------- */
static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args)
{
  #define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, calls thunk, then returns the collected output"
  #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
  s7_pointer old_output_port, p;

  p = car(args);
  if (!is_thunk(sc, p))
    method_or_bust_with_type(sc, p, sc->with_output_to_string_symbol, args, a_thunk_string, 1);

  old_output_port = sc->output_port;
  sc->output_port = s7_open_output_string(sc);
  push_stack(sc, OP_GET_OUTPUT_STRING_1, old_output_port, sc->output_port);

  push_stack(sc, OP_APPLY, sc->nil, p);
  return(sc->F);
}

static s7_pointer c_with_output_to_string(s7_scheme *sc, s7_pointer x) {return(g_with_output_to_string(sc, set_plist_1(sc, x)));}
PF_TO_PF(with_output_to_string, c_with_output_to_string)

/* (let () (define-macro (mac) (write "123")) (with-output-to-string mac))
 * (string-ref (with-output-to-string (lambda () (write "1234") (values (get-output-string) 1))))
 */


/* -------------------------------- with-output-to-file -------------------------------- */
static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args)
{
  #define H_with_output_to_file "(with-output-to-file filename thunk) opens filename as the temporary current-output-port and calls thunk"
  #define Q_with_output_to_file pl_sf
  s7_pointer old_output_port, file, proc;

  file = car(args);
  if (!is_string(file))
    method_or_bust(sc, file, sc->with_output_to_file_symbol, args, T_STRING, 1);

  proc = cadr(args);
  if (!is_thunk(sc, proc))
    method_or_bust_with_type(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2);

  old_output_port = sc->output_port;
  sc->output_port = s7_open_output_file(sc, string_value(file), "w");
  push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, sc->output_port);

  push_stack(sc, OP_APPLY, sc->nil, proc);
  return(sc->F);
}

static s7_pointer c_with_output_to_file(s7_scheme *sc, s7_pointer x) {return(g_with_output_to_file(sc, set_plist_1(sc, x)));}
PF_TO_PF(with_output_to_file, c_with_output_to_file)


/* -------------------------------- format -------------------------------- */

static s7_pointer format_error_1(s7_scheme *sc, s7_pointer msg, const char *str, s7_pointer args, format_data *fdat)
{
  s7_pointer x = NULL, ctrl_str;
  static s7_pointer format_string_1 = NULL, format_string_2, format_string_3, format_string_4;

  if (!format_string_1)
    {
      format_string_1 = s7_make_permanent_string("format: ~S ~{~S~^ ~}: ~A");
      format_string_2 = s7_make_permanent_string("format: ~S: ~A");
      format_string_3 = s7_make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A");
      format_string_4 = s7_make_permanent_string("format: ~S~&~NT^: ~A");
    }

  if (fdat->orig_str)
    ctrl_str = fdat->orig_str;
  else ctrl_str = make_string_wrapper(sc, str);

  if (fdat->loc == 0)
    {
      if (is_pair(args))
	x = set_elist_4(sc, format_string_1, ctrl_str, args, msg);
      else x = set_elist_3(sc, format_string_2, ctrl_str, msg);
    }
  else
    {
      if (is_pair(args))
	x = set_elist_5(sc, format_string_3, ctrl_str, args, make_integer(sc, fdat->loc + 20), msg);
      else x = set_elist_4(sc, format_string_4, ctrl_str, make_integer(sc, fdat->loc + 20), msg);
    }
  if (fdat->port)
    {
      close_format_port(sc, fdat->port);
      fdat->port = NULL;
    }
  return(s7_error(sc, sc->format_error_symbol, x));
}

#define format_error(Sc, Msg, Str, Args, Fdat) \
  do {static s7_pointer _Err_ = NULL; if (!_Err_) _Err_ = s7_make_permanent_string(Msg);  return(format_error_1(Sc, _Err_, Str, Args, Fdat));} while (0)

#define just_format_error(Sc, Msg, Str, Args, Fdat) \
  do {static s7_pointer _Err_ = NULL; if (!_Err_) _Err_ = s7_make_permanent_string(Msg);  format_error_1(Sc, _Err_, Str, Args, Fdat);} while (0)

static void format_append_char(s7_scheme *sc, format_data *fdat, char c, s7_pointer port)
{
  port_write_character(port)(sc, c, port);
  sc->format_column++;

  /* 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);
  sc->format_column = 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;
  sc->format_column += len;
}

static void format_append_chars(s7_scheme *sc, format_data *fdat, char pad, int chars, s7_pointer port)
{
  int j;
  if (chars > 0)
    {
      if (chars < TMPBUF_SIZE)
	{
	  for (j = 0; j < chars; j++)
	    sc->tmpbuf[j] = pad;
	  sc->tmpbuf[chars] = '\0';
	  format_append_string(sc, fdat, sc->tmpbuf, chars, port);
	}
      else
	{
	  for (j = 0; j < chars; j++)
	    format_append_char(sc, fdat, pad, port);
	}
    }
}


static int format_read_integer(s7_scheme *sc, int *cur_i, int str_len, const char *str, s7_pointer args, format_data *fdat)
{
  /* we know that str[*cur_i] is a digit */
  int i, lval = 0;
  for (i = *cur_i; i < str_len - 1; i++)
    {
      int dig;
      dig = digits[(unsigned char)str[i]];
      if (dig < 10)
	{
#if HAVE_OVERFLOW_CHECKS
	  if ((int_multiply_overflow(lval, 10, &lval)) ||
	      (int_add_overflow(lval, dig, &lval)))
	    break;
#else        
	  lval = dig + (lval * 10);
#endif
	}
      else break;
    }

  if (i >= str_len)
    just_format_error(sc, "numeric argument, but no directive!", str, args, fdat);
  *cur_i = i;
  return(lval);
}


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, port);

  free(tmp);
  fdat->args = cdr(fdat->args);
  fdat->ctr++;
}


static int format_nesting(const char *str, char opener, char closer, int start, int end) /* start=i, end=str_len-1 */
{
  int k, nesting = 1;
  for (k = start + 2; k < end; k++)
    if (str[k] == '~')
      {
	if (str[k + 1] == closer)
	  {
	    nesting--;
	    if (nesting == 0)
	      return(k - start - 1);
	  }
	else
	  {
	    if (str[k + 1] == opener)
	      nesting++;
	  }
      }
  return(-1);
}

static bool format_method(s7_scheme *sc, const char *str, format_data *fdat, s7_pointer port)
{
  s7_pointer obj, func;

  obj = car(fdat->args);
  if ((has_methods(obj)) &&
      ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) != sc->undefined))
    {
      s7_pointer ctrl_str;
      if (fdat->orig_str)
	ctrl_str = fdat->orig_str;
      else ctrl_str = make_string_wrapper(sc, str);

      obj = s7_apply_function(sc, func, cons(sc, ctrl_str, fdat->args));
      if (is_string(obj))
	{
	  format_append_string(sc, fdat, string_value(obj), string_length(obj), port);
	  fdat->args = cdr(fdat->args);
	  fdat->ctr++;
	  return(true);
	}
    }
  return(false);
}


#define MAX_FORMAT_NUMERIC_ARG 10000
static int format_n_arg(s7_scheme *sc, const char *str, int str_len, format_data *fdat, s7_pointer args)
{
  int n;

  if (is_null(fdat->args))          /* (format #f "~nT") */
    just_format_error(sc, "~~N: missing argument", str, args, fdat);
  if (!s7_is_integer(car(fdat->args)))
    just_format_error(sc, "~~N: integer argument required", str, args, fdat);
  n = (int)s7_integer(car(fdat->args));

  if (n < 0)
    just_format_error(sc, "~~N value is negative?", str, args, fdat);
  else
    {
      if (n > MAX_FORMAT_NUMERIC_ARG)
	just_format_error(sc, "~~N value is too big", str, args, fdat);
    }

  fdat->args = cdr(fdat->args);    /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */
  return(n);
}


static int format_numeric_arg(s7_scheme *sc, const char *str, int str_len, format_data *fdat, s7_pointer args, int *i)
{
  int width;
  width = format_read_integer(sc, i, str_len, str, args, fdat);
  if (width < 0)
    just_format_error(sc, "width value is negative?", str, fdat->args, fdat);
  else
    {
      if (width > MAX_FORMAT_NUMERIC_ARG)
	just_format_error(sc, "width value is too big", str, fdat->args, fdat);
    }
  return(width);
}


#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 object_to_list(s7_scheme *sc, s7_pointer obj);

static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args,
				   s7_pointer *next_arg, bool with_result, bool columnized, int len, s7_pointer orig_str)
{
  int i, str_len;
  format_data *fdat;
  s7_pointer deferred_port;

  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))
	    {
	      static s7_pointer null_err = NULL;
	      if (!null_err)
		null_err = s7_make_permanent_string("format control string is null, but there are arguments: ~S");
	      return(s7_error(sc, sc->format_error_symbol, set_elist_2(sc, null_err, args)));
	    }
	  if (with_result)
	    return(make_string_wrapper_with_length(sc, "", 0));
	  return(sc->F);
	}
    }
  else str_len = len;

  sc->format_depth++;
  if (sc->format_depth >= sc->num_fdats)
    {
      int k, new_num_fdats;
      new_num_fdats = sc->format_depth * 2;
      sc->fdats = (format_data **)realloc(sc->fdats, sizeof(format_data *) * new_num_fdats);
      for (k = sc->num_fdats; k < new_num_fdats; k++) sc->fdats[k] = NULL;
      sc->num_fdats = new_num_fdats;
    }

  fdat = sc->fdats[sc->format_depth];
  if (!fdat)
    {
      fdat = (format_data *)malloc(sizeof(format_data));
      sc->fdats[sc->format_depth] = fdat;
      fdat->curly_len = 0;
      fdat->curly_str = NULL;
      fdat->ctr = 0;
    }
  else
    {
      if (fdat->port)
	close_format_port(sc, fdat->port);
      if (fdat->strport)
	close_format_port(sc, fdat->strport);
    }
  fdat->port = NULL;
  fdat->strport = NULL;
  fdat->loc = 0;
  fdat->args = args;
  fdat->orig_str = orig_str;
  fdat->curly_arg = sc->nil;

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

  if (with_result)
    {
      deferred_port = port;
      port = open_format_port(sc); 
      fdat->port = port;
    }
  else deferred_port = sc->F;

  for (i = 0; i < str_len - 1; i++)
    {
      if ((unsigned char)(str[i]) == (unsigned char)'~') /* what does MS C want? */
	{
	  use_write_t use_write;
	  switch (str[i + 1])
	    {
	    case '%':                           /* -------- newline -------- */
	      /* sbcl apparently accepts numeric args here (including 0) */

	      if ((port_data(port)) &&
		  (port_position(port) < port_data_size(port)))
		{
		  port_data(port)[port_position(port)++] = '\n';
		  /* 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.
		   */
		  sc->format_column = 0;
		}
	      else format_append_newline(sc, fdat, port);
	      i++;
	      break;

	    case '&':                           /* -------- conditional newline -------- */
	      /* this only works if all output goes through format -- display/write for example do not update format_column */
	      if (sc->format_column > 0)
		format_append_newline(sc, 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++;
	      if (is_null(fdat->args))          /* (format #f "~*~A") */
		format_error(sc, "can't skip argument!", str, args, fdat);
	      fdat->args = cdr(fdat->args);
	      break;

	    case '|':                           /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */
	      if ((is_pair(fdat->args)) &&
		  (fdat->ctr >= sc->print_length))
		{
		  format_append_string(sc, fdat, " ...", 4, port);
		  fdat->args = sc->nil;
		}
	      /* fall through */

	    case '^':                           /* -------- exit -------- */
	      if (is_null(fdat->args))
		{
		  i = str_len;
		  goto ALL_DONE;
		}
	      i++;
	      break;

	    case '@':                           /* -------- plural, 'y' or 'ies' -------- */
	      i += 2;
	      if ((str[i] != 'P') && (str[i] != 'p'))
		format_error(sc, "unknown '@' directive", str, args, fdat);
	      if (!s7_is_real(car(fdat->args)))        /* CL accepts non numbers here */
		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)))
		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 curly_len;

		if (is_null(fdat->args))
		  format_error(sc, "missing argument", str, args, fdat);

		curly_len = format_nesting(str, '{', '}', i, str_len - 1);

		if (curly_len == -1)
		  format_error(sc, "'{' directive, but no matching '}'", str, args, fdat);
		if (curly_len == 1)
		  format_error(sc, "~{~}' doesn't consume any arguments!", 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 a pair, this simply returns the original */
		    if (is_not_null(curly_arg))                /* (format #f "~{~A ~}" #()) -> "" */
		      {
			char *curly_str = NULL;                /* this is the local (nested) format control string */
			s7_pointer orig_arg;

			if (!is_proper_list(sc, curly_arg))
			  format_error(sc, "'{' directive argument should be a proper list or something we can turn into a list", str, args, fdat);
			
			fdat->curly_arg = curly_arg;
			if (curly_arg != car(fdat->args))
			  orig_arg = curly_arg;
			else orig_arg = sc->nil;

			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';

			if ((sc->format_depth < sc->num_fdats - 1) &&
			    (sc->fdats[sc->format_depth + 1]))
			  sc->fdats[sc->format_depth + 1]->ctr = 0;
			
			/* it's not easy to use an iterator here instead of a list (so object->list isn't needed above),
			 *   because the curly brackets may enclose multiple arguments -- we would need to use
			 *   iterators throughout this function.
			 */
			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, NULL);
			    if (curly_arg == new_arg)
			      {
				fdat->curly_arg = sc->nil;
				format_error(sc, "'{...}' doesn't consume any arguments!", str, args, fdat);
			      }
			    curly_arg = new_arg;
			  }
			fdat->curly_arg = sc->nil;
			while (is_pair(orig_arg))
 			  {
 			    s7_pointer p;
 			    p = orig_arg;
 			    orig_arg = cdr(orig_arg);
 			    free_cell(sc, p);   /* if car(fdar->args) is a hash-table, we could also free_cell(car(p)), but not in any other case */
			  }
		      }
		  }

		i += (curly_len + 2); /* jump past the ending '}' too */
		fdat->args = cdr(fdat->args);
		fdat->ctr++;
	      }
	      break;

	    case '}':
	      format_error(sc, "unmatched '}'", str, args, fdat);

	    case 'W': case 'w':
	      use_write = USE_READABLE_WRITE;
	      goto OBJSTR;

	    case 'S': case 's':
	      use_write = USE_WRITE;
	      goto OBJSTR;

	    case 'A': case 'a':
	      use_write = USE_DISPLAY;
	    OBJSTR:
	      /* object->string */
	      {
		s7_pointer obj, strport;
		if (is_null(fdat->args))
		  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)
		  {
		    strport = open_format_port(sc);
		    fdat->strport = strport;
		  }
		else strport = port;
		object_out(sc, obj, strport, use_write);
		if (columnized)
		  {
		    if (port_position(strport) >= port_data_size(strport))
		      resize_port_data(strport, port_data_size(strport) * 2);
		    
		    port_data(strport)[port_position(strport)] = '\0';		    
		    if (port_position(strport) > 0)
		      format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port);
		    close_format_port(sc, strport);
		    fdat->strport = NULL;
		  }

		fdat->args = cdr(fdat->args);
		fdat->ctr++;
	      }
	      break;


	      /* -------- numeric args -------- */
	    case '0': case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9': case ',':
	    case 'N': case 'n':

	    case 'B': case 'b':
	    case 'D': case 'd':
	    case 'E': case 'e':
	    case 'F': case 'f':
	    case 'G': case 'g':
	    case 'O': case 'o':
	    case 'X': case 'x':

	    case 'T': case 't':
	    case 'C': case 'c':
	      {
		int width = -1, precision = -1;
		char pad = ' ';
		i++;                                      /* str[i] == '~' */

		if (isdigit((int)(str[i])))
		  width = format_numeric_arg(sc, str, str_len, fdat, args, &i); 
		else
		  {
		    if ((str[i] == 'N') || (str[i] == 'n'))
		      {
			i++;
			width = format_n_arg(sc, str, str_len, fdat, args); 
		      }
		  }
		if (str[i] == ',')
		  {
		    i++;                                  /* is (format #f "~12,12D" 1) an error?  The precision has no use here. */
		    if (isdigit((int)(str[i])))
		      precision = format_numeric_arg(sc, str, str_len, fdat, args, &i); 
		    else
		      {
			if ((str[i] == 'N') || (str[i] == 'n'))
			  {
			    i++;
			    precision = format_n_arg(sc, str, str_len, fdat, args); 
			  }
			else
			  {
			    if (str[i] == '\'')              /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
			      {
				pad = str[i + 1];
				i += 2;
				if (i >= str_len)            /* (format #f "~,'") */
				  format_error(sc, "incomplete numeric argument", str, args, fdat);
			      }
			    /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */
			  }
		      }
		  }

		switch (str[i])
		  {
		    /* -------- pad to column --------
		     *   are columns numbered from 1 or 0?  there seems to be disagreement about this directive
		     *   does "space over to" mean including?
		     */

		  case 'T': case 't':
		    if (width == -1) width = 0;
		    if (precision == -1) precision = 0;
		    if ((width > 0) || (precision > 0))         /* (format #f "a~8Tb") */
		      {
			/* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T."))
			 * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%"))
			 */
			if (precision > 0)
			  {
			    int mult;
			    mult = (int)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */
			    if (mult < 1) mult = 1;
			    width += (precision * mult);
			  }
			format_append_chars(sc, fdat, pad, width - sc->format_column - 1, port);
		      }
		    break;

		  case 'C': case 'c':
		    {
		      s7_pointer obj;

		      if (is_null(fdat->args))
			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))
			{
			  if (!format_method(sc, str, fdat, port))
			    format_error(sc, "'C' directive requires a character argument", str, args, fdat);
			}
		      else
			{
			  /* here use_write is false, so we just add the char, not its name */
			  if (width == -1)
			    format_append_char(sc, fdat, character(obj), port);
			  else format_append_chars(sc, fdat, character(obj), width, port);
			  fdat->args = cdr(fdat->args);
			  fdat->ctr++;
			}
		    }
		    break;

		    /* -------- numbers -------- */
		  case 'F': case 'f':
		    if (is_null(fdat->args))
		      format_error(sc, "~~F: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~F: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'f', pad, port);
		    break;

		  case 'G': case 'g':
		    if (is_null(fdat->args))
		      format_error(sc, "~~G: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~G: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'g', pad, port);
		    break;

		  case 'E': case 'e':
		    if (is_null(fdat->args))
		      format_error(sc, "~~E: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~E: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'e', pad, port);
		    break;

		    /* how to handle non-integer arguments in the next 4 cases?  clisp just returns
		     *   the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581:
		     *   "if arg is not an integer, it is printed in ~A format and decimal base")!!
		     *   I think I'll use the type of the number to choose the output format.
		     */
		  case 'D': case 'd':
		    if (is_null(fdat->args))
		      format_error(sc, "~~D: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			/* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123)))
			 *    port here is a string-port, str has the width/precision data if the caller wants it,
			 *    args is the current arg.  But format_number handles fdat->args and so on, so
			 *    I think I'll pass the format method the current control string (str), the
			 *    current object (car(fdat->args)), and the arglist (args), and assume it will
			 *    return a (scheme) string.
			 */
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~D: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 10, width, precision, 'd', pad, port);
		    break;

		  case 'O': case 'o':
		    if (is_null(fdat->args))
		      format_error(sc, "~~O: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~O: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 8, width, precision, 'o', pad, port);
		    break;

		  case 'X': case 'x':
		    if (is_null(fdat->args))
		      format_error(sc, "~~X: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~X: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 16, width, precision, 'x', pad, port);
		    break;

		  case 'B': case 'b':
		    if (is_null(fdat->args))
		      format_error(sc, "~~B: missing argument", str, args, fdat);
		    if (!(s7_is_number(car(fdat->args))))
		      {
			if (!format_method(sc, str, fdat, port))
			  format_error(sc, "~~B: numeric argument required", str, args, fdat);
		      }
		    else format_number(sc, fdat, 2, width, precision, 'b', pad, port);
		    break;

		  default:
		    if (width > 0) 
		      format_error(sc, "unused numeric argument", str, args, fdat);
		    format_error(sc, "unimplemented format directive", str, args, fdat);
		  }
	      }
	      break;

	    default:
	      format_error(sc, "unimplemented format directive", str, args, fdat);
	    }
	}
      else /* str[i] is not #\~ */
	{
	  int j, new_len;
	  const char *p;

	  p = (char *)strchr((const char *)(str + i + 1), (int)'~');
	  if (!p)
	    j = str_len;
	  else j = (int)(p - str);
	  new_len = j - i;

	  if ((port_data(port)) &&
	      ((port_position(port) + new_len) < port_data_size(port)))
	    {
	      memcpy((void *)(port_data(port) + port_position(port)), (void *)(str + i), new_len);
	      port_position(port) += new_len;
	    }
	  else port_write_string(port)(sc, (char *)(str + i), new_len, port);
	  fdat->loc += new_len;
	  sc->format_column += new_len;
	  i = j - 1;
	}
    }

 ALL_DONE:
  if (next_arg)
    (*next_arg) = fdat->args;
  else
    {
      if (is_not_null(fdat->args))
	format_error(sc, "too many arguments", str, args, fdat);
    }
  if (i < str_len)
    {
      if (str[i] == '~')
	format_error(sc, "control string ends in tilde", str, args, fdat);
      format_append_char(sc, fdat, str[i], port);
    }

  sc->format_depth--;

  if (with_result)
    {
      s7_pointer result;

      if ((is_output_port(deferred_port)) &&
	  (port_position(port) > 0))
	{
	  port_data(port)[port_position(port)] = '\0';
	  port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port);
	}
      result = s7_make_string_with_length(sc, (char *)port_data(port), port_position(port));
      close_format_port(sc, port);
      fdat->port = NULL;
      return(result);
    }
  return(sc->F);
}


static bool is_columnizing(const char *str)
{
  /* look for ~t ~,<int>T ~<int>,<int>t */
  char *p;

  for (p = (char *)str; (*p);)
    if (*p++ == '~') /* this is faster than strchr */
      {
	char c;
	c = *p++;
	if ((c == 't') || (c == 'T')) return(true);
	if (!c) return(false);
	if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N'))
	  {
	    while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++;
	    if ((c == 't') || (c == 'T')) return(true);
	    if (!c) return(false);                       /* ~,1 for example */
	    if (c == ',')
	      {
		c = *p++;
		while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++;
		if ((c == 't') || (c == 'T')) return(true);
		if (!c) return(false);
	      }
	  }
      }
  return(false);
}


static s7_pointer 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, true /* is_columnizing(str) */, len, NULL));
  /* is_columnizing on every call is much slower than ignoring the issue */
}


static s7_pointer g_format_1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer pt, str;
  sc->format_column = 0;
  pt = car(args);

  if (is_string(pt))
    return(format_to_port_1(sc, sc->F, string_value(pt), cdr(args), NULL, true, true, string_length(pt), pt));
  if (is_null(pt)) pt = sc->output_port;     /* () -> (current-output-port) */

  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)))))
    method_or_bust_with_type(sc, pt, sc->format_symbol, args, an_output_port_string, 1);

  str = cadr(args);
  if (!is_string(str))
    method_or_bust(sc, str, sc->format_symbol, args, T_STRING, 2);

  return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt, 
			  string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str));
}


static s7_pointer g_format(s7_scheme *sc, s7_pointer args)
{
  #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \
s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \
no a newline, ~~ = ~, ~<newline> trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \
~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \
~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \
spacing (and spacing character) and precision.  ~{ starts an embedded format directive which is ended by ~}: \n\
\n\
  >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\
  \"dashed: 1-2-3\"\n\
\n\
~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\
~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\
~E: (format #f \"~E\" 100.1) -&gt; \"1.001000e+02\" (%e in C)\n\
~F: (format #f \"~F\" 100.1) -&gt; \"100.100000\"   (%f in C)\n\
~G: (format #f \"~G\" 100.1) -&gt; \"100.1\"        (%g in C)\n\
\n\
If the 'out' it is not an output port, the resultant string is returned.  If it \
is #t, the string is also sent to the current-output-port."

  #define Q_format s7_make_circular_signature(sc, 1, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
  return(g_format_1(sc, args));
}


const char *s7_format(s7_scheme *sc, s7_pointer args)
{
  s7_pointer result;
  result = g_format_1(sc, args);
  if (is_string(result))
    return(string_value(result));
  return(NULL);
}



/* -------------------------------- system extras -------------------------------- */

#if WITH_SYSTEM_EXTRAS
#include <fcntl.h>

static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args)
{
  #define H_is_directory "(directory? str) returns #t if str is the name of a directory"
  #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->is_directory_symbol, args, T_STRING, 0);
  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"
  #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)

  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->file_exists_symbol, args, T_STRING, 0);
  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."
  #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)

  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->delete_file_symbol, args, T_STRING, 0);
  return(make_integer(sc, unlink(string_value(name))));
}


static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args)
{
  #define H_getenv "(getenv var) returns the value of an environment variable."
  #define Q_getenv pcl_s

  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->getenv_symbol, args, T_STRING, 0);
  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.  If the optional second it is #t, \
system captures the output as a string and returns it."
  #define Q_system s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, sc->is_boolean_symbol)

  s7_pointer name;
  name = car(args);

  if (!is_string(name))
    method_or_bust(sc, name, sc->system_symbol, args, T_STRING, 0);

  if ((is_pair(cdr(args))) &&
      (cadr(args) == sc->T))
    {
      #define BUF_SIZE 256
      char buf[BUF_SIZE];
      char *str = NULL;
      int cur_len = 0, full_len = 0;
      FILE *fd;
      s7_pointer res;

      fd = popen(string_value(name), "r");
      while (fgets(buf, BUF_SIZE, fd))
	{
	  int buf_len;
	  buf_len = safe_strlen(buf);
	  if (cur_len + buf_len >= full_len)
	    {
	      full_len += BUF_SIZE * 2;
	      if (str)
		str = (char *)realloc(str, full_len * sizeof(char));
	      else str = (char *)malloc(full_len * sizeof(char));
	    }
	  memcpy((void *)(str + cur_len), (void *)buf, buf_len);
	  cur_len += buf_len;
	}
      pclose(fd);

      res = s7_make_string_with_length(sc, str, cur_len);
      if (str) free(str);
      return(res);
    }
  return(make_integer(sc, system(string_value(name))));
}


#ifndef _MSC_VER
#include <dirent.h>

static s7_pointer c_directory_to_list(s7_scheme *sc, s7_pointer name)
{
  DIR *dpos;
  s7_pointer result;

  if (!is_string(name))
    method_or_bust(sc, name, sc->directory_to_list_symbol, list_1(sc, name), T_STRING, 0);

  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_directory_to_list(s7_scheme *sc, s7_pointer args)
{
  #define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)."
  #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_string_symbol)
  return(c_directory_to_list(sc, car(args)));
}

PF_TO_PF(directory_to_list, c_directory_to_list)


static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args)
{
  #define H_file_mtime "(file-mtime file): return the write date of file"
  #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)

  struct stat statbuf;
  int err;
  s7_pointer name;

  name = car(args);
  if (!is_string(name))
    method_or_bust(sc, name, sc->file_mtime_symbol, args, T_STRING, 0);

  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, T_PAIR | T_SAFE_PROCEDURE);
  set_car(x, a);
  set_cdr(x, b);
  return(x);
}


static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  /* apparently slightly faster as a function? */
  s7_pointer x;
  new_cell_no_check(sc, x, T_PAIR | T_SAFE_PROCEDURE);
  set_car(x, a);
  set_cdr(x, b);
  return(x);
}


static s7_pointer permanent_cons(s7_pointer a, s7_pointer b, unsigned int type)
{
  /* for the symbol table which is never GC'd (and its contents aren't marked) */
  s7_pointer x;
  x = alloc_pointer();
  set_type(x, type);
  unheap(x);
  set_car(x, a);
  set_cdr(x, b);
  return(x);
}

static s7_pointer permanent_list(s7_scheme *sc, int len)
{
  int j;
  s7_pointer p;
  p = sc->nil;
  for (j = 0; j < len; j++)
    p = permanent_cons(sc->nil, p, T_PAIR | T_IMMUTABLE);
  return(p);
}

#if DEBUGGING
static int sigs = 0, sig_pairs = 0;
#endif

static void check_sig_entry(s7_scheme *sc, s7_pointer p, s7_pointer res, bool circle)
{
  if ((!is_symbol(car(p))) && 
      (!s7_is_boolean(car(p))) &&
      (!is_pair(car(p))))
    {
      s7_pointer np;
      int i;
      for (np = res, i = 0; np != p; np = cdr(np), i++);
      fprintf(stderr, "s7_make_%ssignature got an invalid entry at position %d: (", (circle) ? "circular_" : "", i);
      for (np = res; np != p; np = cdr(np))
	fprintf(stderr, "%s ", DISPLAY(car(np)));
      fprintf(stderr, "...");
      set_car(p, sc->nil);
    }
}

s7_pointer s7_make_signature(s7_scheme *sc, int len, ...)
{
  va_list ap;
  s7_pointer p, res;
#if DEBUGGING
  sigs++;
  sig_pairs += len;
#endif

  res = permanent_list(sc, len);
  va_start(ap, len);
  for (p = res; is_pair(p); p = cdr(p))
    {
      set_car(p, va_arg(ap, s7_pointer));
      check_sig_entry(sc, p, res, false);
    }
  va_end(ap);

  return((s7_pointer)res);
}

s7_pointer s7_make_circular_signature(s7_scheme *sc, int cycle_point, int len, ...)
{
  va_list ap;
  int i;
  s7_pointer p, res, back = NULL, end = NULL;
#if DEBUGGING
  sigs++;
  sig_pairs += len;
#endif

  res = permanent_list(sc, len);
  va_start(ap, len);
  for (p = res, i = 0; is_pair(p); p = cdr(p), i++)
    {
      set_car(p, va_arg(ap, s7_pointer));
      check_sig_entry(sc, p, res, true);
      if (i == cycle_point) back = p;
      if (i == (len - 1)) end = p;
    }
  va_end(ap);
  if (end) set_cdr(end, back);
  if (i < len) 
    fprintf(stderr, "s7_make_circular_signature got too few entries: %s\n", DISPLAY(res));
  return((s7_pointer)res);
}


bool s7_is_pair(s7_pointer p)
{
  return(is_pair(p));
}


s7_pointer s7_car(s7_pointer p) {return(car(p));}
s7_pointer s7_cdr(s7_pointer p) {return(cdr(p));}

s7_pointer s7_cadr(s7_pointer p) {return(cadr(p));}
s7_pointer s7_cddr(s7_pointer p) {return(cddr(p));}
s7_pointer s7_cdar(s7_pointer p) {return(cdar(p));}
s7_pointer s7_caar(s7_pointer p) {return(caar(p));}

s7_pointer s7_caadr(s7_pointer p) {return(caadr(p));}
s7_pointer s7_caddr(s7_pointer p) {return(caddr(p));}
s7_pointer s7_cadar(s7_pointer p) {return(cadar(p));}
s7_pointer s7_caaar(s7_pointer p) {return(caaar(p));}
s7_pointer s7_cdadr(s7_pointer p) {return(cdadr(p));}
s7_pointer s7_cdddr(s7_pointer p) {return(cdddr(p));}
s7_pointer s7_cddar(s7_pointer p) {return(cddar(p));}
s7_pointer s7_cdaar(s7_pointer p) {return(cdaar(p));}

s7_pointer s7_caaadr(s7_pointer p) {return(caaadr(p));}
s7_pointer s7_caaddr(s7_pointer p) {return(caaddr(p));}
s7_pointer s7_caadar(s7_pointer p) {return(caadar(p));}
s7_pointer s7_caaaar(s7_pointer p) {return(caaaar(p));}
s7_pointer s7_cadadr(s7_pointer p) {return(cadadr(p));}
s7_pointer s7_cadddr(s7_pointer p) {return(cadddr(p));}
s7_pointer s7_caddar(s7_pointer p) {return(caddar(p));}
s7_pointer s7_cadaar(s7_pointer p) {return(cadaar(p));}

s7_pointer s7_cdaadr(s7_pointer p) {return(cdaadr(p));}
s7_pointer s7_cdaddr(s7_pointer p) {return(cdaddr(p));}
s7_pointer s7_cdadar(s7_pointer p) {return(cdadar(p));}
s7_pointer s7_cdaaar(s7_pointer p) {return(cdaaar(p));}
s7_pointer s7_cddadr(s7_pointer p) {return(cddadr(p));}
s7_pointer s7_cddddr(s7_pointer p) {return(cddddr(p));}
s7_pointer s7_cdddar(s7_pointer p) {return(cdddar(p));}
s7_pointer s7_cddaar(s7_pointer p) {return(cddaar(p));}


s7_pointer s7_set_car(s7_pointer p, s7_pointer q)
{
  set_car(p, q);
  return(p);
}


s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q)
{
  set_cdr(p, q);
  return(p);
}

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

s7_pointer s7_apply_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1))
{
  /* not currently used */
  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;
      a1 = car(args); args = cdr(args);
      if (is_pair(args))
	{
	  s7_pointer a2;
	  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;
      a1 = car(args); args = cdr(args);
      if (is_pair(args))
	{
	  s7_pointer a2;
	  a2 = car(args); args = cdr(args);
	  if (is_pair(args))
	    {
	      s7_pointer a3;
	      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;
      a1 = car(args); args = cdr(args);
      if (is_pair(args))
	{
	  s7_pointer a2;
	  a2 = car(args); args = cdr(args);
	  if (is_pair(args))
	    {
	      s7_pointer a3;
	      a3 = car(args); args = cdr(args);
	      if (is_pair(args))
		{
		  s7_pointer a4;
		  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_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)))
    set_car(x, _NFre(val));
  return(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? */
      set_cdr(p, result);
      result = p;
      p = q;
    }
  return(result);
}


static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_pointer list)
{
  s7_pointer p = list, result = term, q;

  while (is_not_null(p))
    {
      q = cdr(p);
      set_cdr(p, result);
      result = p;
      p = q;

      if (is_null(p)) break;
      q = cdr(p);
      set_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) */
      set_cdr(p, result);
      result = p;
      p = q;

      /* unroll the loop for speed */
      if (is_null(p)) break;
      q = cdr(p);
      set_cdr(p, result);
      result = p;
      p = q;

      if (is_null(p)) break;
      q = cdr(p);
      set_cdr(p, result);
      result = p;
      p = q;

      if (is_null(p)) break;
      q = cdr(p);
      set_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, tp, np;
  if (is_null(a)) return(b);

  tp = cons(sc, car(a), sc->nil);
  sc->y = tp;
  for (p = cdr(a), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
    set_cdr(np, cons(sc, car(p), sc->nil));
  set_cdr(np, b);
  sc->y = sc->nil;

  return(tp);
}


static s7_pointer copy_list(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer p, tp, np;
  if (!is_pair(lst)) return(sc->nil);
  tp = cons(sc, car(lst), sc->nil);
  sc->y = tp;
  for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
    set_cdr(np, cons(sc, car(p), sc->nil));
  sc->y = sc->nil;
  return(tp);
}


static s7_pointer copy_list_with_arglist_error(s7_scheme *sc, s7_pointer lst)
{
  s7_pointer p, tp, np;
  if (is_null(lst)) return(sc->nil);
  if (!is_pair(lst))
    s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "stray dot?: ~S"), lst));
  tp = cons(sc, car(lst), sc->nil);
  sc->y = tp;
  for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
    set_cdr(np, cons(sc, car(p), sc->nil));
  sc->y = sc->nil;
  if (!is_null(p))
    s7_error(sc, sc->syntax_error_symbol, set_elist_2(sc, make_string_wrapper(sc, "improper list of arguments: ~S"), lst));
  return(tp);
}


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


/* -------------------------------- null? pair? -------------------------------- */
static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args)
{
  #define H_is_null "(null? obj) returns #t if obj is the empty list"
  #define Q_is_null pl_bt
  check_boolean_method(sc, is_null, sc->is_null_symbol, 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)"
  #define Q_is_pair pl_bt
  check_boolean_method(sc, is_pair, sc->is_pair_symbol, args);
}


/* -------------------------------- list? proper-list? -------------------------------- */
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)
{
  /* #t if () or undotted/non-circular pair */
  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 pair or null"
  #define Q_is_list pl_bt
  #define is_a_list(p) s7_is_list(sc, p)
  check_boolean_method(sc, is_a_list, sc->is_list_symbol, args);
}


/* -------------------------------- make-list -------------------------------- */
static s7_pointer make_list(s7_scheme *sc, int len, s7_pointer init)
{
  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:
      {
	s7_pointer result;
	int i;

	if (len >= (sc->free_heap_top - sc->free_heap))
	  {
	    gc(sc);
	    while (len >= (sc->free_heap_top - sc->free_heap))
	      resize_heap(sc);
	  }

	sc->v = sc->nil;
	for (i = 0; i < len; i++)
	  sc->v = cons_unchecked(sc, init, sc->v);
	result = sc->v;
	sc->v = sc->nil;
	return(result);
	}
    }
  return(sc->nil); /* never happens, I hope */
}


static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args)
{
  #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'."
  #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T)

  s7_pointer init;
  s7_int len;

  if (!s7_is_integer(car(args)))
    method_or_bust(sc, car(args), sc->make_list_symbol, args, T_INTEGER, 1);

  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_symbol, small_int(1), car(args), its_negative_string));
  if (len == 0) return(sc->nil);          /* what about (make-list 0 123)? */
  if (len > sc->max_list_length)
    return(out_of_range(sc, sc->make_list_symbol, small_int(1), car(args), its_too_large_string));

  if (is_pair(cdr(args)))
    init = cadr(args);
  else init = sc->F;
  return(make_list(sc, (int)len, init));
}

static s7_pointer c_make_list(s7_scheme *sc, s7_int len) {return(make_list(sc, (int)len, sc->F));}
IF_TO_PF(make_list, c_make_list)


/* -------------------------------- list-ref -------------------------------- */
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))
    method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1);

  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_symbol, small_int(2), cadr(args), its_too_large_string));
      return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string));
    }
  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))
    {
      if (!s7_is_integer(p = check_values(sc, ind, cons(sc, ind, sc->nil))))
	method_or_bust(sc, ind, sc->list_ref_symbol, list_2(sc, lst, ind), T_INTEGER, 2);
      ind = p;
    }
  index = s7_integer(ind);
  if ((index < 0) || (index > sc->max_list_length))
    return(out_of_range(sc, sc->list_ref_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string));

  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_symbol, small_int(2), ind, its_too_large_string));
      return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string));
    }
  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"
  #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol)

  /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2))

    (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))
    method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1);

  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 c_list_ref(s7_scheme *sc, s7_pointer x, s7_int index)
{
  int i;
  s7_pointer p;
  if (!s7_is_pair(x))
    method_or_bust(sc, x, sc->list_ref_symbol, list_2(sc, x, make_integer(sc, index)), T_PAIR, 1);
  if (index < 0)
    return(out_of_range(sc, sc->list_ref_symbol, small_int(2), make_integer(sc, index), its_negative_string));
  for (i = 0, p = x; (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_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
      return(wrong_type_argument_with_type(sc, sc->list_ref_symbol, 1, x, a_proper_list_string));
    }
  return(car(p));
}

PIF_TO_PF(list_ref, c_list_ref)


/* -------------------------------- list-set! -------------------------------- */
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"
  #define Q_list_set s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->T)

  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))
    method_or_bust(sc, lst, sc->list_set_symbol, cons(sc, lst, args), T_PAIR, 1);

  ind = car(args);
  if (!s7_is_integer(ind))
    {
      if (!s7_is_integer(p = check_values(sc, ind, args)))
	method_or_bust(sc, ind, sc->list_set_symbol, cons(sc, lst, args), T_INTEGER, arg_num);
      ind = p;
    }
  index = s7_integer(ind);
  if ((index < 0) || (index > sc->max_list_length))
    return(out_of_range(sc, sc->list_set_symbol, small_int(arg_num), ind, (index < 0) ? its_negative_string : its_too_large_string));

  for (i = 0, p = _TSet(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_symbol, small_int(arg_num), ind, its_too_large_string));
      return(wrong_type_argument_with_type(sc, sc->list_set_symbol, 1, lst, a_proper_list_string));
    }
  if (is_null(cddr(args)))
    set_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 int c_list_tester(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1;
  a1 = cadr(expr);
  if (is_symbol(a1))
    {
      s7_pointer table;
      table = s7_slot(sc, a1);
      if ((is_slot(table)) && 
	  ((is_immutable_symbol(a1)) || (!is_stepper(table))) &&
	  (is_pair(slot_value(table))))
	{
	  s7_xf_store(sc, slot_value(table));
	  a1 = caddr(expr);
	  if (is_symbol(a1))
	    {
	      s7_pointer slot;
	      slot = s7_slot(sc, a1);
	      if ((is_slot(slot)) && 
		  (is_integer(slot_value(slot))))
		{
		  s7_xf_store(sc, slot);
		  return(TEST_SS);
		}
	    }
	  else
	    {
	      if (s7_arg_to_if(sc, a1))
		return(TEST_SI);
	    }
	  return(TEST_SQ);
	}
    }
  return(TEST_NO_S);
}

static s7_pointer c_list_set_s(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer val)
{
  s7_int i;
  s7_pointer p;

  if ((index < 0) || (index > sc->max_list_length))
    return(out_of_range(sc, sc->list_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));

  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_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
      return(wrong_type_argument_with_type(sc, sc->list_set_symbol, 1, lst, a_proper_list_string));
    }
  set_car(p, val);
  return(val);
}

static s7_pointer c_list_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
  if (!s7_is_pair(vec))
    method_or_bust(sc, vec, sc->list_set_symbol, set_plist_3(sc, vec, make_integer(sc, index), val), T_PAIR, 1);
  return(c_list_set_s(sc, vec, index, val));
}

PIPF_TO_PF(list_set, c_list_set_s, c_list_set, c_list_tester)

static s7_pointer list_set_ic;
static s7_pointer g_list_set_ic(s7_scheme *sc, s7_pointer args)
{
  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst))
    method_or_bust(sc, lst, sc->list_set_symbol, args, T_PAIR, 1);
  return(c_list_set_s(sc, lst, s7_integer(cadr(args)), caddr(args)));
}


/* -------------------------------- list-tail -------------------------------- */
static s7_pointer c_list_tail(s7_scheme *sc, s7_pointer lst, s7_int index)
{
  s7_int i;
  s7_pointer p;

  if (!s7_is_list(sc, lst))
    method_or_bust_with_type(sc, lst, sc->list_tail_symbol, list_2(sc, lst, make_integer(sc, index)), a_list_string, 1);

  if ((index < 0) || (index > sc->max_list_length))
    return(out_of_range(sc, sc->list_tail_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));

  for (i = 0, p = lst; (i < index) && (is_pair(p)); i++, p = cdr(p)) {}
  if (i < index)
    return(out_of_range(sc, sc->list_tail_symbol, small_int(2), make_integer(sc, index), its_too_large_string));
  return(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"
  #define Q_list_tail s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_pair_symbol, sc->is_integer_symbol)
  s7_pointer p;

  p = cadr(args);
  if (!s7_is_integer(p))
    {
      s7_pointer p1;
      if (!s7_is_integer(p1 = check_values(sc, p, cdr(args))))
	method_or_bust(sc, p, sc->list_tail_symbol, args, T_INTEGER, 2);
      p = p1;
    }
  return(c_list_tail(sc, car(args), s7_integer(p)));
}

PIF_TO_PF(list_tail, c_list_tail)


/* -------------------------------- cons -------------------------------- */
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"
  #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T)

  /* set_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, T_PAIR | T_SAFE_PROCEDURE);
  set_car(x, car(args));
  set_cdr(x, cadr(args));
  return(x);
}

PF2_TO_PF(cons, s7_cons)

static void init_car_a_list(void)
{
  car_a_list_string = s7_make_permanent_string("a list whose car is also a list");
  cdr_a_list_string = s7_make_permanent_string("a list whose cdr is also a list");

  caar_a_list_string = s7_make_permanent_string("a list whose caar is also a list");
  cadr_a_list_string = s7_make_permanent_string("a list whose cadr is also a list");
  cdar_a_list_string = s7_make_permanent_string("a list whose cdar is also a list");
  cddr_a_list_string = s7_make_permanent_string("a list whose cddr is also a list");

  caaar_a_list_string = s7_make_permanent_string("a list whose caaar is also a list");
  caadr_a_list_string = s7_make_permanent_string("a list whose caadr is also a list");
  cadar_a_list_string = s7_make_permanent_string("a list whose cadar is also a list");
  caddr_a_list_string = s7_make_permanent_string("a list whose caddr is also a list");
  cdaar_a_list_string = s7_make_permanent_string("a list whose cdaar is also a list");
  cdadr_a_list_string = s7_make_permanent_string("a list whose cdadr is also a list");
  cddar_a_list_string = s7_make_permanent_string("a list whose cddar is also a list");
  cdddr_a_list_string = s7_make_permanent_string("a list whose cdddr is also a list");

  a_list_string =                 s7_make_permanent_string("a list");
  an_eq_func_string =             s7_make_permanent_string("a procedure that can take 2 arguments");
  an_association_list_string =    s7_make_permanent_string("an association list");
  a_normal_real_string =          s7_make_permanent_string("a normal real");
  a_rational_string =             s7_make_permanent_string("an integer or a ratio");
  a_number_string =               s7_make_permanent_string("a number");
  a_procedure_string =            s7_make_permanent_string("a procedure");
  a_normal_procedure_string =     s7_make_permanent_string("a normal procedure (not a continuation)");
  a_let_string =                  s7_make_permanent_string("a let (environment)");
  a_proper_list_string =          s7_make_permanent_string("a proper list");
  a_boolean_string =              s7_make_permanent_string("a boolean");
  an_input_port_string =          s7_make_permanent_string("an input port");
  an_open_port_string =           s7_make_permanent_string("an open port");
  an_output_port_string =         s7_make_permanent_string("an output port");
  an_input_string_port_string =   s7_make_permanent_string("an input string port");
  an_input_file_port_string =     s7_make_permanent_string("an input file port");
  an_output_string_port_string =  s7_make_permanent_string("an output string port");
  an_output_file_port_string =    s7_make_permanent_string("an output file port");
  a_thunk_string =                s7_make_permanent_string("a thunk");
  a_symbol_string =               s7_make_permanent_string("a symbol");
  a_non_negative_integer_string = s7_make_permanent_string("a non-negative integer");
  an_unsigned_byte_string =       s7_make_permanent_string("an unsigned byte");
  something_applicable_string =   s7_make_permanent_string("a procedure or something applicable");
  a_random_state_object_string =  s7_make_permanent_string("a random-state object");
  a_format_port_string =          s7_make_permanent_string("#f, #t, or an open output port");
  a_binding_string =              s7_make_permanent_string("a pair whose car is a symbol: '(symbol . value)");
  a_non_constant_symbol_string =  s7_make_permanent_string("a non-constant symbol");
  a_sequence_string =             s7_make_permanent_string("a sequence");
  a_valid_radix_string =          s7_make_permanent_string("should be between 2 and 16");
  result_is_too_large_string =    s7_make_permanent_string("result is too large");
  its_too_large_string =          s7_make_permanent_string("it is too large");
  its_too_small_string =          s7_make_permanent_string("it is less than the start position");
  its_negative_string =           s7_make_permanent_string("it is negative");
  its_nan_string =                s7_make_permanent_string("NaN usually indicates a numerical error");
  its_infinite_string =           s7_make_permanent_string("it is infinite");
  too_many_indices_string =       s7_make_permanent_string("too many indices");
#if (!HAVE_COMPLEX_NUMBERS)
  no_complex_numbers_string =     s7_make_permanent_string("this version of s7 does not support complex numbers");
#endif
}


/* -------- car -------- */
static s7_pointer g_car_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst))
    method_or_bust(sc, lst, sc->car_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  return(car(lst));
}

static s7_pointer g_car(s7_scheme *sc, s7_pointer args)
{
  #define H_car "(car pair) returns the first element of the pair"
  #define Q_car pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst))
    method_or_bust(sc, lst, sc->car_symbol, args, T_PAIR, 0);
  return(car(lst));
}

PF_TO_PF(car, g_car_1)


static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args)
{
  #define H_set_car "(set-car! pair val) sets the pair's first element to val"
  #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
  s7_pointer p;

  p = car(args);
  if (!is_pair(p))
    method_or_bust(sc, p, sc->set_car_symbol, args, T_PAIR, 1);

  set_car(p, cadr(args));
  return(car(p));
}

static s7_pointer c_set_car(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_pair(x))
    method_or_bust(sc, x, sc->set_car_symbol, set_plist_2(sc, x, y), T_PAIR, 1);
  set_car(x, y);
  return(y);
}

PF2_TO_PF(set_car, c_set_car)


/* -------- cdr -------- */
static s7_pointer g_cdr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst))
    method_or_bust(sc, lst, sc->cdr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  return(cdr(lst));
}

static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdr "(cdr pair) returns the second element of the pair"
  #define Q_cdr pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst))
    method_or_bust(sc, lst, sc->cdr_symbol, args, T_PAIR, 0);
  return(cdr(lst));
}

PF_TO_PF(cdr, g_cdr_1)


static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args)
{
  #define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val"
  #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
  s7_pointer p;

  p = car(args);
  if (!is_pair(p))
    method_or_bust(sc, p, sc->set_cdr_symbol, args, T_PAIR, 1);

  set_cdr(p, cadr(args));
  return(cdr(p));
}

static s7_pointer c_set_cdr(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_pair(x))
    method_or_bust(sc, x, sc->set_cdr_symbol, set_plist_2(sc, x, y), T_PAIR, 1);
  set_cdr(x, y);
  return(y);
}

PF2_TO_PF(set_cdr, c_set_cdr)



/* -------- caar --------*/
static s7_pointer g_caar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst, car_a_list_string));
  /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
  return(caar(lst));
}

static s7_pointer g_caar(s7_scheme *sc, s7_pointer args)
{
  #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1"
  #define Q_caar pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caar_symbol, args, T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst, car_a_list_string));
  /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
  return(caar(lst));
}

PF_TO_PF(caar, g_caar_1)


/* -------- cadr --------*/
static s7_pointer g_cadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst, cdr_a_list_string));
  return(cadr(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"
  #define Q_cadr pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadr_symbol, args, T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst, cdr_a_list_string));
  return(cadr(lst));
}

PF_TO_PF(cadr, g_cadr_1)


/* -------- cdar -------- */
static s7_pointer g_cdar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst, car_a_list_string));
  return(cdar(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)"
  #define Q_cdar pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdar_symbol, args, T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst, car_a_list_string));
  return(cdar(lst));
}

PF_TO_PF(cdar, g_cdar_1)


/* -------- cddr -------- */
static s7_pointer g_cddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst, cdr_a_list_string));
  return(cddr(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)"
  #define Q_cddr pl_p  

  s7_pointer lst;
  lst = car(args);
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddr_symbol, args, T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst, cdr_a_list_string));
  return(cddr(lst));
}

PF_TO_PF(cddr, g_cddr_1)


/* -------- caaar -------- */
static s7_pointer g_caaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, car_a_list_string));
  if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, caar_a_list_string));
  return(caaar(lst));
}

static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args)
{
  #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1"
  #define Q_caaar pl_p  

  return(g_caaar_1(sc, car(args)));
}

PF_TO_PF(caaar, g_caaar_1)


/* -------- caadr -------- */
static s7_pointer g_caadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst, cadr_a_list_string));
  return(caadr(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"
  #define Q_caadr pl_p  

  return(g_caadr_1(sc, car(args)));
}

PF_TO_PF(caadr, g_caadr_1)


/* -------- cadar -------- */
static s7_pointer g_cadar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst, car_a_list_string));
  if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst, cdar_a_list_string));
  return(cadar(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"
  #define Q_cadar pl_p  

  return(g_cadar_1(sc, car(args)));
}

PF_TO_PF(cadar, g_cadar_1)


/* -------- cdaar -------- */
static s7_pointer g_cdaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, car_a_list_string));
  if (!is_pair(car(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, caar_a_list_string));
  return(cdaar(lst));
}

static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)"
  #define Q_cdaar pl_p  

  return(g_cdaar_1(sc, car(args)));
}

PF_TO_PF(cdaar, g_cdaar_1)


/* -------- caddr -------- */
static s7_pointer g_caddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst, cddr_a_list_string));
  return(caddr(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"
  #define Q_caddr pl_p  

  return(g_caddr_1(sc, car(args)));
}

PF_TO_PF(caddr, g_caddr_1)


/* -------- cdddr -------- */
static s7_pointer g_cdddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cdr(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst, cddr_a_list_string));
  return(cdddr(lst));
}

static s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)"
  #define Q_cdddr pl_p  

  return(g_cdddr_1(sc, car(args)));
}

PF_TO_PF(cdddr, g_cdddr_1)


/* -------- cdadr -------- */
static s7_pointer g_cdadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(car(cdr(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst, cadr_a_list_string));
  return(cdadr(lst));
}

static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)"
  #define Q_cdadr pl_p  

  return(g_cdadr_1(sc, car(args)));
}

PF_TO_PF(cdadr, g_cdadr_1)


/* -------- cddar -------- */
static s7_pointer g_cddar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, car_a_list_string));
  if (!is_pair(cdr(car(lst)))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, cdar_a_list_string));
  return(cddar(lst));
}

static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args)
{
  #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)"
  #define Q_cddar pl_p  

  return(g_cddar_1(sc, car(args)));
}

PF_TO_PF(cddar, g_cddar_1)


/* -------- caaaar -------- */
static s7_pointer g_caaaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, car_a_list_string));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, caar_a_list_string));
  if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, lst, caaar_a_list_string));
  return(caaaar(lst));
}

static s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args)
{
  #define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1"
  #define Q_caaaar pl_p  

  return(g_caaaar_1(sc, car(args)));
}

PF_TO_PF(caaaar, g_caaaar_1)


/* -------- caaadr -------- */
static s7_pointer g_caaadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, cadr_a_list_string));
  if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, lst, caadr_a_list_string));
  return(caaadr(lst));
}

static s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args)
{
  #define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2"
  #define Q_caaadr pl_p  

  return(g_caaadr_1(sc, car(args)));
}

PF_TO_PF(caaadr, g_caaadr_1)


/* -------- caadar -------- */
static s7_pointer g_caadar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, car_a_list_string));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, cdar_a_list_string));
  if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, lst, cadar_a_list_string));
  return(caadar(lst));
}

static s7_pointer g_caadar(s7_scheme *sc, s7_pointer args)
{
  #define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
  #define Q_caadar pl_p  

  return(g_caadar_1(sc, car(args)));
}

PF_TO_PF(caadar, g_caadar_1)


/* -------- cadaar -------- */
static s7_pointer g_cadaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, car_a_list_string));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, caar_a_list_string));
  if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, lst, cdaar_a_list_string));
  return(cadaar(lst));
}

static s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2"
  #define Q_cadaar pl_p  

  return(g_cadaar_1(sc, car(args)));
}

PF_TO_PF(cadaar, g_cadaar_1)


/* -------- caaddr -------- */
static s7_pointer g_caaddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, cddr_a_list_string));
  if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, lst, caddr_a_list_string));
  return(caaddr(lst));
}

static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args)
{
  #define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3"
  #define Q_caaddr pl_p  

  return(g_caaddr_1(sc, car(args)));
}

PF_TO_PF(caaddr, g_caaddr_1)


/* -------- cadddr -------- */
static s7_pointer g_cadddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cddr_a_list_string));
  if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, lst, cdddr_a_list_string));
  return(cadddr(lst));
}

static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4"
  #define Q_cadddr pl_p  

  return(g_cadddr_1(sc, car(args)));
}

PF_TO_PF(cadddr, g_cadddr_1)


/* -------- cadadr -------- */
static s7_pointer g_cadadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cadr_a_list_string));
  if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, lst, cdadr_a_list_string));
  return(cadadr(lst));
}

static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3"
  #define Q_cadadr pl_p  

  return(g_cadadr_1(sc, car(args)));
}

PF_TO_PF(cadadr, g_cadadr_1)


/* -------- caddar -------- */
static s7_pointer g_caddar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, car_a_list_string));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, cdar_a_list_string));
  if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, lst, cddar_a_list_string));
  return(caddar(lst));
}

static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args)
{
  #define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3"
  #define Q_caddar pl_p  

  return(g_caddar_1(sc, car(args)));
}

PF_TO_PF(caddar, g_caddar_1)


/* -------- cdaaar -------- */
static s7_pointer g_cdaaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, car_a_list_string));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, caar_a_list_string));
  if (!is_pair(caaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, lst, caaar_a_list_string));
  return(cdaaar(lst));
}

static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)"
  #define Q_cdaaar pl_p  

  return(g_cdaaar_1(sc, car(args)));
}

PF_TO_PF(cdaaar, g_cdaaar_1)


/* -------- cdaadr -------- */
static s7_pointer g_cdaadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, cadr_a_list_string));
  if (!is_pair(caadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, lst, caadr_a_list_string));
  return(cdaadr(lst));
}

static s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)"
  #define Q_cdaadr pl_p  

  return(g_cdaadr_1(sc, car(args)));
}

PF_TO_PF(cdaadr, g_cdaadr_1)


/* -------- cdadar -------- */
static s7_pointer g_cdadar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdadar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, car_a_list_string));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, cdar_a_list_string));
  if (!is_pair(cadar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, lst, cadar_a_list_string));
  return(cdadar(lst));
}

static s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)"
  #define Q_cdadar pl_p  

  return(g_cdadar_1(sc, car(args)));
}

PF_TO_PF(cdadar, g_cdadar_1)


/* -------- cddaar -------- */
static s7_pointer g_cddaar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddaar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, car_a_list_string));
  if (!is_pair(caar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, caar_a_list_string));
  if (!is_pair(cdaar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, lst, cdaar_a_list_string));
  return(cddaar(lst));
}

static s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args)
{
  #define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)"
  #define Q_cddaar pl_p  

  return(g_cddaar_1(sc, car(args)));
}

PF_TO_PF(cddaar, g_cddaar_1)


/* -------- cdaddr -------- */
static s7_pointer g_cdaddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdaddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, cddr_a_list_string));
  if (!is_pair(caddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, lst, caddr_a_list_string));
  return(cdaddr(lst));
}

static s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)"
  #define Q_cdaddr pl_p  

  return(g_cdaddr_1(sc, car(args)));
}

PF_TO_PF(cdaddr, g_cdaddr_1)


/* -------- cddddr -------- */
static s7_pointer g_cddddr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cddr_a_list_string));
  if (!is_pair(cdddr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, lst, cdddr_a_list_string));
  return(cddddr(lst));
}

static s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args)
{
  #define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)"
  #define Q_cddddr pl_p  
  return(g_cddddr_1(sc, car(args)));
}

PF_TO_PF(cddddr, g_cddddr_1)


/* -------- cddadr -------- */
static s7_pointer g_cddadr_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(cdr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cdr_a_list_string));
  if (!is_pair(cadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cadr_a_list_string));
  if (!is_pair(cdadr(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, lst, cdadr_a_list_string));
  return(cddadr(lst));
}

static s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args)
{
  #define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)"
  #define Q_cddadr pl_p  
  return(g_cddadr_1(sc, car(args)));
}

PF_TO_PF(cddadr, g_cddadr_1)


/* -------- cdddar -------- */
static s7_pointer g_cdddar_1(s7_scheme *sc, s7_pointer lst)
{
  if (!is_pair(lst)) method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), T_PAIR, 0);
  if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, car_a_list_string));
  if (!is_pair(cdar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, cdar_a_list_string));
  if (!is_pair(cddar(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, lst, cddar_a_list_string));
  return(cdddar(lst));
}

static s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args)
{
  #define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)"
  #define Q_cdddar pl_p  

  return(g_cdddar_1(sc, car(args)));
}

PF_TO_PF(cdddar, g_cdddar_1)



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.
       *
       * if car(#<unspecified>) = #<unspecified> (initialization time), then cdr(nil)->unspec
       *   and subsequent caar(unspc)->unspec so we could forgo half the is_pair checks below.
       *   This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose.
       */
      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x));
      x = cdr(x);
      if (!is_pair(x)) return(sc->F);

      y = cdr(y);
      if (x == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static s7_pointer c_assq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_pair(y))
    {
      if (is_null(y)) return(sc->F);
      method_or_bust_with_type(sc, y, sc->assq_symbol, list_2(sc, x, y), an_association_list_string, 2);
    }
  /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc:
   *  (assq #f '(#f 2 . 3)) -> #f
   *  (assoc #f '(#f 2 . 3)) -> 'error 
   */
  return(s7_assq(sc, x, y));
}

static s7_pointer g_assq(s7_scheme *sc, s7_pointer args)
{
  #define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist"
  #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol)
  return(c_assq(sc, car(args), cadr(args)));
}

PF2_TO_PF(assq, c_assq)


static s7_pointer c_assv(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  s7_pointer z;
  if (!is_pair(y))
    {
      if (is_null(y)) return(sc->F);
      method_or_bust_with_type(sc, y, sc->assv_symbol, list_2(sc, x, y), an_association_list_string, 2);
    }

  if (is_simple(x))
    return(s7_assq(sc, x, y));

  z = y;
  while (true)
    {
      /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */
      if ((is_pair(car(y))) && (s7_is_eqv(x, caar(y)))) return(car(y));
      y = cdr(y);
      if (!is_pair(y)) return(sc->F);

      if ((is_pair(car(y))) && (s7_is_eqv(x, caar(y)))) return(car(y));
      y = cdr(y);
      if (!is_pair(y)) return(sc->F);

      z = cdr(z);
      if (z == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static s7_pointer g_assv(s7_scheme *sc, s7_pointer args)        /* g_assv is called by g_assoc below */
{ 
  #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist"
  #define Q_assv Q_assq
  return(c_assv(sc, car(args), cadr(args)));
}

PF2_TO_PF(assv, c_assv)

static s7_pointer all_x_c_ss(s7_scheme *sc, s7_pointer arg);
static s7_pointer all_x_c_uu(s7_scheme *sc, s7_pointer arg);
static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args);
static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args);

static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args)
{
  #define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\
If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
  #define Q_assoc s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)

  s7_pointer x, y, obj, eq_func = NULL;

  x = cadr(args);
  if (!is_null(x))
    {
      if (!is_pair(x))
	method_or_bust_with_type(sc, x, sc->assoc_symbol, args, an_association_list_string, 2);

      if ((is_pair(x)) && (!is_pair(car(x))))
	return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, x, an_association_list_string)); /* we're assuming caar below so it better exist */
    }

  if (is_not_null(cddr(args)))
    {
      /* check third arg before second (trailing arg error check) */
      eq_func = caddr(args);

      if (type(eq_func) < T_GOTO)
	method_or_bust_with_type(sc, eq_func, sc->assoc_symbol, args, a_procedure_string, 0);

      if (!s7_is_aritable(sc, eq_func, 2))
	return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string));
    }
  if (is_null(x)) return(sc->F);

  if (eq_func)
    {
      /* 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);
	      if (func == g_is_eq) return(s7_assq(sc, car(args), x));
	      if (func == g_is_eqv) return(g_assv(sc, args));
	      set_car(sc->t2_1, car(args));

	      for (; is_pair(x); x = cdr(x))
		{
		  if (is_pair(car(x)))
		    {
		      set_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_symbol, 2, cadr(args), an_association_list_string));
		}
	      return(sc->F);
	    }

	  /* lg auto? */
	  if ((is_closure(eq_func)) &&
	      (is_pair(closure_args(eq_func))) &&
	      (is_pair(cdr(closure_args(eq_func))))) /* not dotted arg list */
	    {
	      s7_pointer body;
	      body = closure_body(eq_func);
	      if ((is_optimized(car(body))) &&
		  (is_null(cdr(body))) &&
		  (is_all_x_safe(sc, car(body))))
		{
		  s7_function func;
		  s7_pointer b;

		  new_frame_with_two_slots(sc, sc->envir, sc->envir, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F);
		  func = all_x_eval(sc, car(body), sc->envir, let_symbol_is_safe); /* safe since local */
		  b = next_slot(let_slots(sc->envir));

		  for (; is_pair(x); x = cdr(x))
		    {
		      slot_set_value(b, caar(x));
		      if (is_true(sc, func(sc, car(body))))
			return(car(x));
		    }
		  return(sc->F);
		}
	    }
	}

      /* sc->value = sc->F; */
      y = cons(sc, args, sc->nil);
      set_opt_fast(y, x);
      set_opt_slow(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);
  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 */
}

static s7_pointer c_assoc(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_assoc(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(assoc, c_assoc)


/* ---------------- 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 c_memq(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  if (!is_pair(y))
    {
      if (is_null(y)) return(sc->F);
      method_or_bust_with_type(sc, y, sc->memq_symbol, list_2(sc, x, y), a_list_string, 2);
    }
  return(s7_memq(sc, x, y));
}

static s7_pointer g_memq(s7_scheme *sc, s7_pointer args)
{
  #define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?"
  #define Q_memq pl_tl
  return(c_memq(sc, car(args), cadr(args)));
}

PF2_TO_PF(memq, c_memq)

/* 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 = find_symbol_checked(sc, cadar(args));
  if (!is_pair(obj))
    {
      s7_pointer func;
      if ((has_methods(obj)) &&
	  ((func = find_method(sc, find_let(sc, obj), sc->car_symbol)) != sc->undefined))
	obj = s7_apply_function(sc, func, list_1(sc, obj));
      if (!is_pair(obj))
	return(simple_wrong_type_argument(sc, sc->car_symbol, 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_symbol) &&
      (is_pair(cadr(caddr(expr)))))
    {
      int len;

      if ((is_h_safe_c_s(cadr(expr))) &&
	  (c_callee(cadr(expr)) == g_car))
	{
	  set_optimize_op(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 c_memv(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  s7_pointer z;

  if (!is_pair(y))
    {
      if (is_null(y)) return(sc->F);
      method_or_bust_with_type(sc, y, sc->memv_symbol, list_2(sc, x, y), a_list_string, 2);
    }

  if (is_simple(x)) return(s7_memq(sc, x, y));
  if (s7_is_number(x)) return(memv_number(sc, x, y));

  z = y;
  while (true)
    {
      if (s7_is_eqv(x, car(y))) return(y);
      y = cdr(y);
      if (!is_pair(y)) return(sc->F);

      if (s7_is_eqv(x, car(y))) return(y);
      y = cdr(y);
      if (!is_pair(y)) return(sc->F);

      z = cdr(z);
      if (z == y) return(sc->F);
    }
  return(sc->F); /* not reached */
}

static s7_pointer g_memv(s7_scheme *sc, s7_pointer args)
{
  #define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?"
  #define Q_memv pl_tl

  return(c_memv(sc, car(args), cadr(args)));
}

PF2_TO_PF(memv, c_memv)


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?"
  #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)

  /* this could be extended to accept sequences:
   *    (member #\a "123123abnfc" char=?) -> "abnfc"
   *    (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication
   *    (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table?
   * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t)
   * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil
   *
   * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so.
   */

  s7_pointer x, y, obj, eq_func = NULL;
  x = cadr(args);

  if ((!is_pair(x)) && (!is_null(x)))
    method_or_bust_with_type(sc, x, sc->member_symbol, args, a_list_string, 2);

  if (is_not_null(cddr(args)))
    {
      /* check third arg before second (trailing arg error check) */
      eq_func = caddr(args);

      if (type(eq_func) < T_GOTO)
	method_or_bust_with_type(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3);

      if (!s7_is_aritable(sc, eq_func, 2))
	return(wrong_type_argument_with_type(sc, sc->member_symbol, 3, eq_func, an_eq_func_string));
    }

  if (is_null(x)) return(sc->F);
  if (eq_func)
    {
      /* 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);
	      if (func == g_is_eq) return(s7_memq(sc, car(args), x));
	      if (func == g_is_eqv) return(g_memv(sc, args));
	      set_car(sc->t2_1, car(args));

	      for (; is_pair(x); x = cdr(x))
		{
		  set_car(sc->t2_2, car(x));
		  if (is_true(sc, func(sc, sc->t2_1)))
		    return(x);
		}
	      return(sc->F);
	    }

	  if ((is_closure(eq_func)) &&
	      (is_pair(closure_args(eq_func))) &&
	      (is_pair(cdr(closure_args(eq_func))))) /* not dotted arg list */
	    {
	      s7_pointer body;
	      body = closure_body(eq_func);
	      if ((is_optimized(car(body))) &&
		  (is_null(cdr(body))) &&
		  (is_all_x_safe(sc, car(body))))
		{
		  s7_function func;
		  func = all_x_eval(sc, car(body), closure_args(eq_func), pair_symbol_is_safe);

		  /* tmap, lg falls through*/
		  if (((func == all_x_c_ss) || (func == all_x_c_uu)) &&
		      (cadar(body) == car(closure_args(eq_func))) &&
		      (caddar(body) == cadr(closure_args(eq_func))))
		    {
		      set_car(sc->t2_1, car(args));
		      func = c_callee(car(body));
		      for (; is_pair(x); x = cdr(x))
			{
			  set_car(sc->t2_2, car(x));
			  if (is_true(sc, func(sc, sc->t2_1)))
			    return(x);
			}
		    }
		  else
		    {
		      s7_pointer b;
		      new_frame_with_two_slots(sc, sc->envir, sc->envir, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F);
		      b = next_slot(let_slots(sc->envir));

		      for (; is_pair(x); x = cdr(x))
			{
			  slot_set_value(b, car(x));
			  if (is_true(sc, func(sc, car(body))))
			    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_opt_fast(y, x);
      set_opt_slow(y, x);
      push_stack(sc, OP_MEMBER_IF, y, eq_func);
      set_car(sc->t2_1, car(args));
      set_car(sc->t2_2, car(x));
      push_stack(sc, OP_APPLY, sc->t2_1, eq_func);
      return(sc->unspecified);
    }

  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 c_member(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_member(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(member, c_member)

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 = find_symbol_checked(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_num_s;
static s7_pointer g_member_num_s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer lst;

  lst = find_symbol_checked(sc, cadr(args));
  if (!is_pair(lst))
    {
      if (is_null(lst)) return(sc->F);
      method_or_bust_with_type(sc, lst, sc->member_symbol, list_2(sc, car(args), lst), a_list_string, 2);
    }
  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 = find_symbol_checked(sc, car(args));
  x = find_symbol_checked(sc, cadr(args));
  if (!is_pair(x))
    {
      if (is_null(x)) return(sc->F);
      method_or_bust_with_type(sc, x, sc->member_symbol, list_2(sc, obj, x), a_list_string, 2);
    }

  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 (s7_is_number(cadr(expr)))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(member_num_s);                 /* (member 4 lst) */
	    }

	  if (is_symbol(cadr(expr)))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(member_ss);                    /* (member obj lst) */
	    }
	}
      else
	{
	  if ((is_symbol(cadr(expr))) &&
	      (is_pair(caddr(expr))) &&
	      (car(caddr(expr)) == sc->quote_symbol) &&
	      (is_pair(cadr(caddr(expr)))))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(member_sq);                    /* (member q '(quote lambda case)) */
	    }
	}
    }

  if ((args == 3) &&
      (is_symbol(cadddr(expr))) &&
      (cadddr(expr) == sc->is_eq_symbol))
    return(memq_chooser(sc, f, 2, expr));

  return(f);
}


static bool is_memq(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 c_is_provided(s7_scheme *sc, s7_pointer sym)
{
  s7_pointer topf, x;

  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->is_provided_symbol, list_1(sc, sym), T_SYMBOL, 0);

  /* here the *features* list is spread out (or can be anyway) along the curlet chain,
   *   so we need to travel back all the way to the top level checking each *features* list in turn.
   *   Since *features* grows via cons (newest first), we can stop the scan if we hit the shared
   *   top-level at least.
   */
  topf = slot_value(global_slot(sc->features_symbol));
  if (is_memq(sym, topf))
    return(sc->T);

  if (is_global(sc->features_symbol))
    return(sc->F);
  for (x = sc->envir; symbol_id(sc->features_symbol) < let_id(x); x = outlet(x));
  for (; is_let(x); x = outlet(x))
    {
      s7_pointer y;
      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == sc->features_symbol)
	  {
	    if ((slot_value(y) != topf) &&
		(is_memq(sym, slot_value(y))))
	      return(sc->T);
	  }
    }
  return(sc->F);
}

static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args)
{
  #define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list"
  #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol)

  return(c_is_provided(sc, car(args)));
}

bool s7_is_provided(s7_scheme *sc, const char *feature)
{
  return(is_memq(s7_make_symbol(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */
}

PF_TO_PF(is_provided, c_is_provided)


static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym)
{
  /* this has to be relative to the curlet: (load file env)
   *   the things loaded are only present in env, and go away with it, so should not be in the global *features* list
   */
  s7_pointer p, lst;
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->provide_symbol, list_1(sc, sym), T_SYMBOL, 0);

  p = find_local_symbol(sc, sc->features_symbol, sc->envir); /* if sc->envir is nil, this returns the global slot, else local slot */
  lst = slot_value(find_symbol(sc, sc->features_symbol));    /* in either case, we want the current *features* list */

  if (p == sc->undefined)
    make_slot_1(sc, sc->envir, sc->features_symbol, cons(sc, sym, lst));
  else
    {
      if (!is_memq(sym, lst))
	slot_set_value(p, cons(sc, sym, lst));
    }

  if (!is_slot(find_symbol(sc, sym))) /* *features* name might be the same as an existing function */
    s7_define(sc, sc->envir, sym, sym);
  return(sym);
}

static s7_pointer g_provide(s7_scheme *sc, s7_pointer args)
{
  #define H_provide "(provide symbol) adds symbol to the *features* list"
  #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol)
  return(c_provide(sc, car(args)));
}

void s7_provide(s7_scheme *sc, const char *feature)
{
  c_provide(sc, s7_make_symbol(sc, feature));
}

PF_TO_PF(provide, c_provide)


static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args)
{
  /* symbol_access for set/let of *features* which can only be changed via provide */
  if (s7_is_list(sc, cadr(args)))
    return(cadr(args));
  return(sc->error_symbol);
}


static s7_pointer g_list(s7_scheme *sc, s7_pointer args)
{
  #define H_list "(list ...) returns its arguments in a list"
  #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T)
  return(copy_list(sc, args));
}

static s7_pointer c_list_1(s7_scheme *sc, s7_pointer x) {return(cons(sc, x, sc->nil));}  
PF_TO_PF(list, c_list_1)

static s7_pointer list_0, list_1, list_2;
static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args)
{
  return(sc->nil);
}

static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args)
{
  return(cons(sc, car(args), sc->nil));
}

static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args)
{
  return(cons_unchecked(sc, car(args), cons(sc, cadr(args), sc->nil)));
}

static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  switch (args)
    {
    case 0: return(list_0);
    case 1: return(list_1);
    case 2: return(list_2);
    }
  return(f);
}


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_int sequence_length(s7_scheme *sc, s7_pointer lst);

static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer y, tp, np = NULL, pp;

  /* we know here that args is a pair and cdr(args) is a pair */
  tp = sc->nil;
  for (y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */
    {
      s7_pointer p;
      p = car(y);

      check_method(sc, p, sc->append_symbol, (is_null(tp)) ? args : cons(sc, tp, y));

      if (is_null(cdr(y)))
	{
	  if (is_null(tp))
	    return(p);
	  if ((s7_is_list(sc, p)) ||
	      (!is_sequence(p)))
	    set_cdr(np, p);
	  else 
	    {
	      s7_int len;
	      len = sequence_length(sc, p);
	      if (len > 0)
		set_cdr(np, s7_copy(sc, set_plist_2(sc, p, make_list(sc, len, sc->F))));
	      else 
		{
		  if (len < 0)
		    set_cdr(np, p);
		}
	    }
	  sc->y = sc->nil;
	  return(tp);
	}

      if (!is_sequence(p))
	return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string));

      if (!is_null(p))
	{
	  if (is_pair(p))
	    {
	      if (!is_proper_list(sc, p))
		{
		  sc->y = sc->nil;
		  return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string));
		}
	      /* is this error correct?
	       *     (append '(3) '(1 . 2)) -> '(3 1 . 2) ; (old) guile also returns this
	       * but (append '(1 . 2) '(3)) -> this error
	       */
	      
	      if (is_null(tp))
		{
		  tp = cons(sc, car(p), sc->nil);
		  np = tp;
		  sc->y = tp; /* GC protect? */
		  pp = cdr(p);
		}
	      else pp = p;
	      for (; is_pair(pp); pp = cdr(pp), np = cdr(np))
		set_cdr(np, cons(sc, car(pp), sc->nil));
	    }
	  else
	    {
	      s7_int len;
	      len = sequence_length(sc, p);
	      if (len > 0)
		{
		  if (is_null(tp))
		    {
		      tp = s7_copy(sc, set_plist_2(sc, p, make_list(sc, len, sc->F)));
		      np = tp;
		      sc->y = tp;
		    }
		  else set_cdr(np, s7_copy(sc, set_plist_2(sc, p, make_list(sc, len, sc->F))));
		  for (; is_pair(cdr(np)); np = cdr(np));
		}
	      else 
		{
		  if (len < 0)
		    return(wrong_type_argument_with_type(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string));
		}
	    }
	}
    }
  return(tp);
}


static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
  /* tack b onto the end of a without copying either -- 'a' is changed! */
  s7_pointer p;
  if (is_null(a))
    return(b);
  p = a;
  while (is_not_null(cdr(p))) p = cdr(p);
  set_cdr(p, b);
  return(a);
}


/* -------------------------------- vectors -------------------------------- */

bool s7_is_vector(s7_pointer p)
{
  return(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)
{
  if (!s7_is_integer(val)) 
    s7_wrong_type_arg_error(sc, "int_vector_set!", 3, val, "an integer");
  int_vector_element(vec, loc) = s7_integer(val);
  return(val);
}

static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc)
{
  return(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) = real_to_double(sc, val, "float-vector-set!");
  return(val);
}

static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc)
{
  return(make_real(sc, float_vector_element(vec, loc)));
}


static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, unsigned int typ)
{
  s7_pointer x;
  if (len < 0)
    return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, make_integer(sc, len), a_non_negative_integer_string));
  if (len > sc->max_vector_length)
    return(out_of_range(sc, sc->make_vector_symbol, small_int(1), make_integer(sc, len), its_too_large_string));

  /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */
  new_cell(sc, x, typ | T_SAFE_PROCEDURE); /* (v 0) as vector-ref is safe */
  vector_length(x) = 0;
  vector_elements(x) = NULL;
  vector_dimension_info(x) = NULL;

  if (len > 0)
    {
      vector_length(x) = len;
      if (typ == T_VECTOR)
	{
	  vector_elements(x) = (s7_pointer *)malloc(len * sizeof(s7_pointer));
	  if (!vector_elements(x))
	    return(s7_error(sc, make_symbol(sc, "out-of-memory"), set_elist_1(sc, make_string_wrapper(sc, "make-vector allocation failed!"))));
	  vector_getter(x) = default_vector_getter;
	  vector_setter(x) = default_vector_setter;
	  if (filled) s7_vector_fill(sc, x, sc->nil);  /* make_hash_table assumes nil as the default value */
	}
      else
	{
	  if (typ == T_FLOAT_VECTOR)
	    {
	      if (filled)
		float_vector_elements(x) = (s7_double *)calloc(len, sizeof(s7_double));
	      else float_vector_elements(x) = (s7_double *)malloc(len * sizeof(s7_double));
	      if (!float_vector_elements(x))
		return(s7_error(sc, make_symbol(sc, "out-of-memory"), set_elist_1(sc, make_string_wrapper(sc, "make-float-vector allocation failed!"))));
	      vector_getter(x) = float_vector_getter;
	      vector_setter(x) = float_vector_setter;
	    }
	  else
	    {
	      if (filled)
		int_vector_elements(x) = (s7_int *)calloc(len, sizeof(s7_int));
	      else int_vector_elements(x) = (s7_int *)malloc(len * sizeof(s7_int));
	      if (!int_vector_elements(x))
		return(s7_error(sc, make_symbol(sc, "out-of-memory"), set_elist_1(sc, make_string_wrapper(sc, "make-int-vector allocation failed!"))));
	      vector_getter(x) = int_vector_getter;
	      vector_setter(x) = int_vector_setter;
	    }
	}
    }

  Add_Vector(x);
  return(x);
}


s7_pointer s7_make_vector(s7_scheme *sc, s7_int len)
{
  return(make_vector_1(sc, len, FILLED, T_VECTOR));
}

static vdims_t *make_wrap_only(s7_scheme *sc)
{
  vdims_t *v;
  v = (vdims_t *)malloc(sizeof(vdims_t));
  v->original = sc->F;
  v->elements_allocated = false;
  v->ndims = 1;
  v->dimensions_allocated = false;
  v->dims = NULL;
  v->offsets = NULL;
  return(v);
}

#define make_vdims(Sc, Alloc, Dims, Info) ((((Dims) == 1) && (!(Alloc))) ? sc->wrap_only : make_vdims_1(Sc, Alloc, Dims, Info))

static vdims_t *make_vdims_1(s7_scheme *sc, bool elements_allocated, int dims, s7_int *dim_info)
{
  vdims_t *v;

  v = (vdims_t *)malloc(sizeof(vdims_t));
  v->original = sc->F;
  v->elements_allocated = elements_allocated;
  v->ndims = dims;
  if (dims > 1)
    {
      int i;
      s7_int offset = 1;
      v->dimensions_allocated = true;
      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];
	}
    }
  else
    {
      v->dimensions_allocated = false;
      v->dims = NULL;
      v->offsets = NULL;
    }
  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, bool free_data)
{
  /* this wraps up a C-allocated/freed double array as an s7 vector.
   */
  s7_pointer x;

  new_cell(sc, 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)
    {
      if (!free_data)    /* here we need the dim info to tell the GC to leave the data alone */
	{
	  s7_int di[1];
	  di[0] = len;
	  vector_dimension_info(x) = make_vdims(sc, free_data, 1, di);
	}
      else vector_dimension_info(x) = NULL;
    }
  else vector_dimension_info(x) = make_vdims(sc, free_data, dims, dim_info);
  Add_Vector(x);
  return(x);
}


s7_int s7_vector_length(s7_pointer vec)
{
  return(vector_length(vec));
}


s7_int s7_print_length(s7_scheme *sc) {return(sc->print_length);}
s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len)
{
  s7_int old_len;
  old_len = sc->print_length;
  sc->print_length = new_len;
 return(old_len);
}


#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;

  switch (type(vec))
    {
    case T_FLOAT_VECTOR:
      if (!s7_is_real(obj))
	s7_wrong_type_arg_error(sc, "(float) vector-fill!", 2, obj, "a real");
      else
	{
	  s7_double x;
	  x = real_to_double(sc, obj, "vector-fill!");
	  if (x == 0.0)
	    memclr((void *)float_vector_elements(vec), 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;
	    }
	}
      break;

    case T_INT_VECTOR:
      if (!s7_is_integer(obj)) /* possibly a bignum */
	s7_wrong_type_arg_error(sc, "(int) vector-fill!", 2, obj, "an integer");
      else
	{
	  s7_int k;
	  k = s7_integer(obj);
	  if (k == 0)
	    memclr((void *)int_vector_elements(vec), 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;
	    }
	}
      break;

    default:
      {
	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"
  #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol)

  s7_pointer x, fill;
  s7_int start = 0, end;

  x = car(args);
  if (!s7_is_vector(x))
    {
      check_method(sc, x, sc->vector_fill_symbol, args);
      /* not two_methods (and fill!) here else we get stuff like:
       *   (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa"
       */
      return(wrong_type_argument(sc, sc->vector_fill_symbol, 1, x, T_VECTOR));
    }

  fill = cadr(args);
  if (is_float_vector(x))
    {
      if (!s7_is_real(fill)) /* possibly a bignum */
	{
	  check_two_methods(sc, fill, sc->vector_fill_symbol, sc->fill_symbol, args);
	  s7_wrong_type_arg_error(sc, "(float) vector-fill!", 2, fill, "a real");
	}
    }
  else
    {
      if (is_int_vector(x))
	{
	  if (!s7_is_integer(fill))
	    {
	      check_two_methods(sc, fill, sc->vector_fill_symbol, sc->fill_symbol, args);
	      s7_wrong_type_arg_error(sc, "(int) vector-fill!", 2, fill, "an integer");
	    }
	}
    }

  end = vector_length(x);
  if (!is_null(cddr(args)))
    {
      s7_pointer p;
      p = start_and_end(sc, sc->vector_fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
      if (p != sc->gc_nil) return(p);
      if (start == end) return(fill);
    }
  if (end == 0) return(fill);

  if ((start == 0) && (end == vector_length(x)))
    s7_vector_fill(sc, x, fill);
  else
    {
      s7_int i;
      if (is_normal_vector(x))
	{
	  for (i = start; i < end; i++)
	    vector_element(x, i) = fill;
	}
      else
	{
	  if (is_int_vector(x))
	    {
	      s7_int k;
	      k = s7_integer(fill);
	      if (k == 0)
		memclr((void *)(int_vector_elements(x) + start), (end - start) * sizeof(s7_int));
	      else
		{
		  for (i = start; i < end; i++)
		    int_vector_element(x, i) = k;
		}
	    }
	  else
	    {
	      if (is_float_vector(x))
		{
		  s7_double y;
		  y = real_to_double(sc, fill, "vector-fill!");
		  if (y == 0.0)
		    memclr((void *)(float_vector_elements(x) + start), (end - start) * sizeof(s7_double));
		  else
		    {
		      s7_double *orig;
		      s7_int left;
		      orig = float_vector_elements(x);
		      left = end - 8;
		      i = start;
		      while (i <= left)
			{
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			  orig[i++] = y;
			}
		      for (; i < end; i++)
			orig[i] = y;
		    }
		}
	    }
	}
    }
  return(fill);
}

#if (!WITH_PURE_S7)
static s7_pointer c_vector_fill(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_vector_fill(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(vector_fill, c_vector_fill)
#endif

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_symbol, small_int(2), make_integer(sc, index), its_too_large_string));

  return(vector_getter(vec)(sc, vec, index));
}


s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a)
{
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), its_too_large_string));

  vector_setter(vec)(sc, vec, index, _NFre(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);
}


#if (!WITH_PURE_S7)
static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, int typ);

static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
{
  /* returns a one-dimensional vector.  To handle multidimensional vectors, we'd need to
   *   ensure all the dimensional data matches (rank, size of each dimension except the last etc),
   *   which is too much trouble.
   */
  #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments."
  #define Q_vector_append pcl_v

  s7_pointer p;
  int i;

  if (is_null(args))
    return(make_vector_1(sc, 0, NOT_FILLED, T_VECTOR));

  for (i = 0, p = args; is_pair(p); p = cdr(p), i++)
    {
      s7_pointer x;
      x = car(p);
      if (!s7_is_vector(x))
	{
	  if (has_methods(x))
	    {
	      s7_pointer func;
	      func = find_method(sc, find_let(sc, x), sc->vector_append_symbol);
	      if (func != sc->undefined)
		{
		  int k;
		  s7_pointer v, y;
		  if (i == 0)
		    return(s7_apply_function(sc, func, args));
		  /* we have to copy the arglist here */
		  sc->temp9 = make_list(sc, i, sc->F);
		  for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v))
		    set_car(v, car(y));
		  v = g_vector_append(sc, sc->temp9);
		  y = s7_apply_function(sc, func, cons(sc, v, p));
		  sc->temp9 = sc->nil;
		  return(y);
		}
	    }
	  return(wrong_type_argument(sc, sc->vector_append_symbol, i, x, T_VECTOR));
	}
    }
  return(vector_append(sc, args, type(car(args))));
}
#endif

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(out_of_range(sc, sc->vector_ref_symbol, small_int(i), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string));
		}
	      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), "should be a valid index"));
		}
	      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 result;

  len = vector_length(vect);
  if (len == 0) 
    return(sc->nil);
  if (len >= (sc->free_heap_top - sc->free_heap))
    {
      gc(sc);
      while (len >= (sc->free_heap_top - sc->free_heap))
	resize_heap(sc);
    }

  sc->v = sc->nil;
  for (i = len - 1; i >= 0; i--)
    sc->v = cons_unchecked(sc, vector_getter(vect)(sc, vect, i), sc->v);
  result = sc->v;
  sc->v = sc->nil;
  return(result);
}

#if (!WITH_PURE_S7)
static s7_pointer c_vector_to_list(s7_scheme *sc, s7_pointer vec)
{
  sc->temp3 = vec;
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_to_list_symbol, list_1(sc, vec), T_VECTOR, 0);
  return(s7_vector_to_list(sc, vec));
}

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)"
  #define Q_vector_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol)

  vec = car(args);
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_to_list_symbol, args, T_VECTOR, 0);

  end = vector_length(vec);
  if (!is_null(cdr(args)))
    {
      p = start_and_end(sc, sc->vector_to_list_symbol, NULL, cdr(args), args, 2, &start, &end);
      if (p != sc->gc_nil) return(p);
      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);
}

PF_TO_PF(vector_to_list, c_vector_to_list)
#endif

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"
  #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T)

  s7_int len;
  s7_pointer vec;

  len = s7_list_length(sc, args);
  vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
  if (len > 0)
    {
      s7_int i;
      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 c_vector_1(s7_scheme *sc, s7_pointer x) {return(g_vector(sc, set_plist_1(sc, x)));}
PF_TO_PF(vector, c_vector_1)


static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector"
  #define Q_is_float_vector pl_bt
  check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args);
}

static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments"
  #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol)

  s7_int len;
  s7_pointer vec;

  len = s7_list_length(sc, args);
  vec = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); /* dangerous: assumes real_to_double won't trigger GC even if bignums */
  if (len > 0)
    {
      s7_int i;
      s7_pointer x;
      for (x = args, i = 0; is_pair(x); x = cdr(x), i++)
	{
	  if (s7_is_real(car(x))) /* bignum is ok here */
	    float_vector_element(vec, i) = real_to_double(sc, car(x), "float-vector");
	  else return(simple_wrong_type_argument(sc, sc->float_vector_symbol, car(x), T_REAL));
	}
    }
  return(vec);
}

static s7_pointer c_float_vector_1(s7_scheme *sc, s7_pointer x) {return(g_float_vector(sc, set_plist_1(sc, x)));}
PF_TO_PF(float_vector, c_float_vector_1)


static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous int vector"
  #define Q_is_int_vector pl_bt
  check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args);
}

static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector "(int-vector ...) returns an homogeneous int vector whose elements are the arguments"
  #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol)

  s7_int len;
  s7_pointer vec;

  len = s7_list_length(sc, args);
  vec = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
  if (len > 0)
    {
      s7_int i;
      s7_pointer x;
      for (x = args, i = 0; is_pair(x); x = cdr(x), i++)
	{
	  if (is_integer(car(x)))
	    int_vector_element(vec, i) = integer(car(x));
	  else return(simple_wrong_type_argument(sc, sc->int_vector_symbol, car(x), T_INTEGER));
	}
    }
  return(vec);
}

static s7_pointer c_int_vector_1(s7_scheme *sc, s7_pointer x) {return(g_int_vector(sc, set_plist_1(sc, x)));}
PF_TO_PF(int_vector, c_int_vector_1)


#if (!WITH_PURE_S7)
static s7_pointer c_list_to_vector(s7_scheme *sc, s7_pointer p)
{
  sc->temp3 = p;
  if (is_null(p))
    return(s7_make_vector(sc, 0));

  if (!is_proper_list(sc, p))
    method_or_bust_with_type(sc, p, sc->list_to_vector_symbol, list_1(sc, p), a_proper_list_string, 0);

  return(g_vector(sc, p));
}

static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)"
  #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol)
  return(c_list_to_vector(sc, car(args)));
}

PF_TO_PF(list_to_vector, c_list_to_vector)


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"
  #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)

  vec = car(args);
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_length_symbol, args, T_VECTOR, 0);

  return(make_integer(sc, vector_length(vec)));
}

static s7_int c_vector_length(s7_scheme *sc, s7_pointer vec)
{
  if (!s7_is_vector(vec))
    int_method_or_bust(sc, vec, sc->vector_length_symbol, set_plist_1(sc, vec), T_VECTOR, 0);
  return(vector_length(vec));
}

PF_TO_IF(vector_length, c_vector_length)
#endif

static s7_pointer make_shared_vector(s7_scheme *sc, s7_pointer vect, int skip_dims, s7_int index)
{
  s7_pointer x;
  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, typeflag(vect) | T_SAFE_PROCEDURE);
  vector_length(x) = 0;
  vector_elements(x) = NULL;
  vector_getter(x) = vector_getter(vect);
  vector_setter(x) = vector_setter(vect);

  v = (vdims_t *)malloc(sizeof(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; /* shared_vector */
  if (type(vect) == T_VECTOR) 
    mark_function[T_VECTOR] = mark_vector_possibly_shared; 
  else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared; 
  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 (offset 0)) returns \
a vector that points to the same elements as the original-vector but with different dimensional info."
  #define Q_make_shared_vector s7_make_signature(sc, 4, sc->is_vector_symbol, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_integer_symbol), sc->is_integer_symbol)

  /* (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.
   */
  s7_pointer orig, dims, y, x;
  vdims_t *v;
  int i;
  s7_int new_len = 1, orig_len, offset = 0;

  orig = car(args);
  if (!s7_is_vector(orig))
    method_or_bust(sc, orig, sc->make_shared_vector_symbol, args, T_VECTOR, 1);

  orig_len = vector_length(orig);

  if (!is_null(cddr(args)))
    {
      s7_pointer off;
      off = caddr(args);
      if (s7_is_integer(off))
	{
	  offset = s7_integer(off);
	  if ((offset < 0) ||
	      (offset >= orig_len))  /* we need this if, for example, offset == 9223372036854775807 */
	    return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(3), off, (offset < 0) ? its_negative_string : its_too_large_string));
	}
      else method_or_bust(sc, off, sc->make_shared_vector_symbol, args, T_INTEGER, 3);
    }

  dims = cadr(args);
  if (is_integer(dims))
    {
      if ((s7_integer(dims) < 0) ||
	  (s7_integer(dims) >= orig_len))
	return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(2), dims, (s7_integer(dims) < 0) ? its_negative_string : its_too_large_string));
      dims = list_1(sc, dims);
    }
  else
    {
      if ((is_null(dims)) ||
	  (!is_proper_list(sc, dims)))
	method_or_bust(sc, dims, sc->make_shared_vector_symbol, args, T_PAIR, 2);

      for (y = dims; is_pair(y); y = cdr(y))
	if ((!s7_is_integer(car(y)))        ||       /* (make-shared-vector v '((1 2) (3 4))) */
	    (s7_integer(car(y)) > orig_len) ||
	    (s7_integer(car(y)) < 0))
	  return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_1(sc, make_string_wrapper(sc, "a list of integers that fits the original vector"))));
    }

  v = (vdims_t *)malloc(sizeof(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; /* shared_vector */
  if (type(orig) == T_VECTOR) 
    mark_function[T_VECTOR] = mark_vector_possibly_shared; 
  else mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; 

  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] = new_len;
      new_len *= v->dims[i];
    }

  if ((new_len < 0) || ((new_len + offset) > vector_length(orig)))
    {
      free(v->dims);
      free(v->offsets);
      free(v);
      return(out_of_range(sc, sc->make_shared_vector_symbol, small_int(2), dims, make_string_wrapper(sc, "a shared vector has to fit in the original vector")));
    }

  new_cell(sc, x, typeflag(orig) | T_SAFE_PROCEDURE);
  vector_dimension_info(x) = v;
  vector_length(x) = new_len;                 /* 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) = (s7_int *)(int_vector_elements(orig) + offset);
  else
    {
      if (is_float_vector(orig))
	float_vector_elements(x) = (s7_double *)(float_vector_elements(orig) + offset);
      else vector_elements(x) = (s7_pointer *)(vector_elements(orig) + offset);
    }

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

static s7_pointer c_make_shared_vector_ppi(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int z) 
{
  return(g_make_shared_vector(sc, set_plist_3(sc, x, y, make_integer(sc, z))));
}

static s7_pointer c_make_shared_vector_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) 
{
  return(g_make_shared_vector(sc, set_plist_2(sc, x, y)));
}

PPIF_TO_PF(make_shared_vector, c_make_shared_vector_pp, c_make_shared_vector_ppi)


static s7_pointer make_vector_wrapper(s7_scheme *sc, s7_int size, s7_pointer *elements)
{
  s7_pointer x;
  new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE);
  vector_length(x) = size;
  vector_elements(x) = elements;
  vector_getter(x) = default_vector_getter;
  vector_setter(x) = default_vector_setter;
  vector_dimension_info(x) = NULL;
  /* don't add_vector -- no need for sweep to see this */
  return(x);
}

static s7_pointer make_subvector(s7_scheme *sc, s7_pointer v)
{
  s7_pointer x;
  new_cell(sc, x, type(v));
  vector_length(x) = vector_length(v);
  if (is_normal_vector(v))
    vector_elements(x) = vector_elements(v);
  else
    {
      if (is_float_vector(v))
	float_vector_elements(x) = float_vector_elements(v);
      else int_vector_elements(x) = int_vector_elements(v);
    }
  vector_getter(x) = vector_getter(v);
  vector_setter(x) = vector_setter(v);
  vector_dimension_info(x) = NULL;
  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_symbol, small_int(1), vect, its_too_large_string));

  if (vector_rank(vect) > 1)
    {
      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;
	  s7_pointer p, p1;
	  p = car(x);
	  if (!s7_is_integer(p))
	    {
	      if (!s7_is_integer(p1 = check_values(sc, p, x)))
		method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, i + 2);
	      p = p1;
	    }
	  n = s7_integer(p);
	  if ((n < 0) ||
	      (n >= vector_dimension(vect, i)))
	    return(out_of_range(sc, sc->vector_ref_symbol, make_integer(sc, i + 2), p, (n < 0) ? its_negative_string : its_too_large_string));

	  index += n * vector_offset(vect, i);
	}
      if (is_not_null(x))
	{
	  if (type(vect) != T_VECTOR)
	    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), indices, too_many_indices_string));
	  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
    {
      s7_pointer p, p1;
      /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */
      p = car(indices);

      if (!s7_is_integer(p))
	{
	  if (!s7_is_integer(p1 = check_values(sc, p, indices)))
	    method_or_bust(sc, p, sc->vector_ref_symbol, cons(sc, vect, indices), T_INTEGER, 2);
	  p = p1;
	}
      index = s7_integer(p);
      if ((index < 0) ||
	  (index >= vector_length(vect)))
	return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string));

      if (is_not_null(cdr(indices)))                /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */
	{
	  if (type(vect) != T_VECTOR)
	    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), indices, too_many_indices_string));
	  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."
  #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol)

  s7_pointer vec;

  vec = car(args);
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1);
  return(vector_ref_1(sc, vec, cdr(args)));
}

static s7_pointer g_vector_ref_ic_n(s7_scheme *sc, s7_pointer args, s7_int index)
{
  s7_pointer vec;
  vec = find_symbol_checked(sc, car(args));
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, cadr(args)), T_VECTOR, 1);

  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
  if (vector_rank(vec) > 1)
    {
      if (index >= vector_dimension(vec, 0))
	return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
      return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
    }
  return(vector_getter(vec)(sc,vec, index));
}

/* (vector-ref fv i) -> allocates real, so it's not a pf case */
static s7_pointer vector_ref_pf_slot(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x, y;
  x = (**p); (*p)++;
  y = slot_value(**p); (*p)++;
  return(vector_elements(x)[s7_integer(y)]);
}

static s7_pointer vector_ref_pf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t xf;
  s7_pointer x;
  s7_int y;
  x = (**p); (*p)++;
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  return(vector_elements(x)[y]);
}

static s7_pointer vector_ref_pf_i(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t xf;
  s7_pointer x;
  s7_int y;
  x = slot_value(**p); (*p)++;
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  return(vector_elements(x)[y]);
}

static int c_vector_tester(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer a1;
  a1 = cadr(expr);
  if (is_symbol(a1))
    {
      s7_pointer table;
      table = s7_slot(sc, a1);
      if ((is_slot(table)) && ((is_immutable_symbol(a1)) || (!is_stepper(table))))
	{
	  table = slot_value(table);
	  if ((type(table) == T_VECTOR) && (vector_rank(table) == 1))
	    {
	      s7_pointer a2;
	      s7_xf_store(sc, table);
	      a2 = caddr(expr);
	      if (is_symbol(a2))
		{
		  s7_pointer slot;
		  slot = s7_slot(sc, a2);
		  if ((is_slot(slot)) && 
		      (is_integer(slot_value(slot))))
		    {
		      s7_xf_store(sc, slot);
		      return(TEST_SS);
		    }
		}
	      else
		{
		  if (s7_arg_to_if(sc, a2))
		    return(TEST_SI);
		}
	      return(TEST_SQ);
	    }
	}
    }
  return(TEST_NO_S);
}

static s7_pf_t vector_ref_pf(s7_scheme *sc, s7_pointer expr)
{	
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      int choice;
      choice = (c_vector_tester(sc, expr));
      if (choice == TEST_SS)
	return(vector_ref_pf_slot);
      if (choice == TEST_SI)
	return(vector_ref_pf_s);
    }
  return(NULL);
}

static s7_pointer vector_ref_ic;
static s7_pointer g_vector_ref_ic(s7_scheme *sc, s7_pointer args) {return(g_vector_ref_ic_n(sc, args, s7_integer(cadr(args))));}
static s7_pointer vector_ref_ic_0;
static s7_pointer g_vector_ref_ic_0(s7_scheme *sc, s7_pointer args) {return(g_vector_ref_ic_n(sc, args, 0));}
static s7_pointer vector_ref_ic_1;
static s7_pointer g_vector_ref_ic_1(s7_scheme *sc, s7_pointer args) {return(g_vector_ref_ic_n(sc, args, 1));}
static s7_pointer vector_ref_ic_2;
static s7_pointer g_vector_ref_ic_2(s7_scheme *sc, s7_pointer args) {return(g_vector_ref_ic_n(sc, args, 2));}
static s7_pointer vector_ref_ic_3;
static s7_pointer g_vector_ref_ic_3(s7_scheme *sc, s7_pointer args) {return(g_vector_ref_ic_n(sc, args, 3));}

static s7_pointer vector_ref_gs;
static s7_pointer g_vector_ref_gs(s7_scheme *sc, s7_pointer args)
{
  /* global vector ref: (vector-ref global_vector i) */
  s7_pointer x, vec;
  s7_int index;

  vec = find_global_symbol_checked(sc, car(args));
  x = find_symbol_checked(sc, cadr(args));

  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, x), T_VECTOR, 1);
  if (!s7_is_integer(x))
    method_or_bust(sc, x, sc->vector_ref_symbol, list_2(sc, vec, x), T_INTEGER, 2);

  index = s7_integer(x);
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));

  if (vector_rank(vec) > 1)
    {
      if (index >= vector_dimension(vec, 0))
	return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
      return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
    }
  return(vector_getter(vec)(sc, vec, index));
}

static s7_pointer vector_ref_add1;
static s7_pointer g_vector_ref_add1(s7_scheme *sc, s7_pointer args)
{
  /* (vector-ref v (+ s 1)) I think */
  s7_pointer vec, x;
  s7_int index;

  vec = find_symbol_checked(sc, car(args));
  x = find_symbol_checked(sc, cadr(cadr(args)));

  if (!s7_is_integer(x))
    method_or_bust(sc, x, sc->vector_ref_symbol, list_2(sc, vec, x), T_INTEGER, 2);
  index = s7_integer(x) + 1;

  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_ref_symbol, list_2(sc, vec, s7_make_integer(sc, index)), T_VECTOR, 1);

  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));

  if (vector_rank(vec) > 1)
    {
      if (index >= vector_dimension(vec, 0))
	return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), its_too_large_string));
      return(make_shared_vector(sc, vec, 1, index * vector_offset(vec, 0)));
    }
  return(vector_getter(vec)(sc, vec, index));
}


static s7_pointer vector_ref_2, constant_vector_ref_gs;
static s7_pointer g_constant_vector_ref_gs(s7_scheme *sc, s7_pointer args)
{
  s7_pointer x, vec;
  s7_int index;
  vec = opt_vector(args);
  x = find_symbol_checked(sc, cadr(args));
  if (!s7_is_integer(x))
    return(g_vector_ref_gs(sc, args));
  index = s7_integer(x);
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));
  return(vector_element(vec, index));
}

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))
    method_or_bust(sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1);       /* should be ok because we go to g_vector_ref below */

  if (vector_rank(vec) > 1)
    return(g_vector_ref(sc, args));

  ind = cadr(args);
  if (!s7_is_integer(ind))
    method_or_bust(sc, ind, sc->vector_ref_symbol, args, T_INTEGER, 2);

  index = s7_integer(ind);
  if ((index < 0) || (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string));

  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."
  #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)

  s7_pointer vec, val;
  s7_int index;

  vec = car(args);
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_set_symbol, args, T_VECTOR, 1);

  if (vector_length(_TSet(vec)) == 0)
    return(out_of_range(sc, sc->vector_set_symbol, small_int(1), vec, its_too_large_string));

  if (vector_rank(vec) > 1)
    {
      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;
	  s7_pointer p, p1;
	  p = car(x);
	  if (!s7_is_integer(p))
	    {
	      if (!s7_is_integer(p1 = check_values(sc, p, x)))
		method_or_bust(sc, p, sc->vector_set_symbol, args, T_INTEGER, i + 2);
	      p = p1;
	    }
	  n = s7_integer(p);
	  if ((n < 0) ||
	      (n >= vector_dimension(vec, i)))
	    return(out_of_range(sc, sc->vector_set_symbol, make_integer(sc, i + 2), p, (n < 0) ? its_negative_string : its_too_large_string));

	  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
    {
      s7_pointer p, p1;
      p = cadr(args);
      if (!s7_is_integer(p))
	{
	  if (!s7_is_integer(p1 = check_values(sc, p, cdr(args))))
	    method_or_bust(sc, p, sc->vector_set_symbol, args, T_INTEGER, 2);
	  p = p1;
	}
      index = s7_integer(p);
      if ((index < 0) ||
	  (index >= vector_length(vec)))
	return(out_of_range(sc, sc->vector_set_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string));

      if (is_not_null(cdddr(args)))
	{
	  set_car(sc->temp_cell_2, vector_getter(vec)(sc, vec, index));
	  set_cdr(sc->temp_cell_2, cddr(args));
	  return(g_vector_set(sc, sc->temp_cell_2));
	}
      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)
{
  /* (vector-set! vec 0 x) */
  s7_pointer vec, val;
  s7_int index;

  vec = find_symbol_checked(sc, car(args));
  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_set_symbol, list_3(sc, vec, cadr(args), find_symbol_checked(sc, caddr(args))), T_VECTOR, 1);
  /* the list_3 happens only if we find the method */

  if (vector_rank(vec) > 1)
    return(g_vector_set(sc, set_plist_3(sc, vec, cadr(args), find_symbol_checked(sc, caddr(args)))));

  index = s7_integer(cadr(args));
  if (index >= vector_length(vec))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), cadr(args), its_too_large_string));

  val = find_symbol_checked(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)
{
  /* (vector-set! vec i (vector-ref vec j)) -- checked that the vector is the same */
  s7_pointer vec, val1, val2;
  s7_int index1, index2;

  vec = find_symbol_checked(sc, car(args));
  val1 = find_symbol_checked(sc, cadr(args));
  val2 = find_symbol_checked(sc, caddr(caddr(args)));

  if ((!s7_is_vector(vec)) ||
      (vector_rank(vec) > 1) ||
      (!s7_is_integer(val1)) ||
      (!s7_is_integer(val2)))
    return(g_vector_set(sc, set_plist_3(sc, vec, val1, g_vector_ref(sc, set_plist_2(sc, vec, val2)))));

  index1 = s7_integer(val1);
  if (index1 >= vector_length(vec))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), val1, its_too_large_string));

  index2 = s7_integer(val2);
  if (index2 >= vector_length(vec))
    return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), val2, its_too_large_string));

  vector_setter(vec)(sc, vec, index1, val1 = vector_getter(vec)(sc, vec, index2));
  return(val1);
}


static s7_pointer vector_set_vector_ref;
static s7_pointer g_vector_set_vector_ref(s7_scheme *sc, s7_pointer args)
{
  /* (vector-set! data i|j (+|- (vector-ref data i) tc)) */
  s7_pointer vec, val, val2, tc, arg3;
  s7_int index1, index2;

  vec = find_symbol_checked(sc, car(args));
  val = find_symbol_checked(sc, cadr(args));

  arg3 = caddr(args);
  tc = find_symbol_checked(sc, caddr(arg3));
  val2 = caddr(cadr(arg3));

  if ((!s7_is_vector(vec)) ||
      (vector_rank(vec) > 1) ||
      (!s7_is_integer(val)))
    return(g_vector_set(sc, set_plist_3(sc, vec, val, c_call(arg3)(sc, list_2(sc, g_vector_ref(sc, set_plist_2(sc, vec, find_symbol_checked(sc, val2))), tc)))));

  index1 = s7_integer(val);
  if (index1 >= vector_length(vec))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), val, its_too_large_string));

  if (val2 != cadr(args))
    {
      val2 = find_symbol_checked(sc, val2);
      if (!s7_is_integer(val2))
	{
	  s7_pointer p;
	  if (!s7_is_integer(p = check_values(sc, val2, list_1(sc, val2))))
	    return(wrong_type_argument(sc, sc->vector_ref_symbol, 2, val2, T_INTEGER));
	  else val2 = p;
	}
      index2 = s7_integer(val2);
      if (index2 >= vector_length(vec))
	return(out_of_range(sc, sc->vector_ref_symbol, small_int(2), val, its_too_large_string));
    }
  else index2 = index1;

  set_car(sc->z2_1, vector_getter(vec)(sc, vec, index2));
  set_car(sc->z2_2, tc);
  vector_setter(vec)(sc, vec, index1, tc = c_call(arg3)(sc, sc->z2_1));
  return(tc);
}

static s7_pointer c_vector_set_3(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
  /* (vector-set! vec ind val) where are all predigested */

  if (!s7_is_vector(vec))
    method_or_bust(sc, vec, sc->vector_set_symbol, list_3(sc, vec, make_integer(sc, index), val), T_VECTOR, 1);

  if (vector_rank(vec) > 1)
    return(g_vector_set(sc, list_3(sc, vec, make_integer(sc, index), val)));

  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));

  vector_setter(vec)(sc, vec, index, val);
  return(val);
}

static s7_pointer c_vector_set_s(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer val)
{
  /* (vector-set! vec ind val) where are all predigested, vector is prechecked */
  if ((index < 0) ||
      (index >= vector_length(vec)))
    return(out_of_range(sc, sc->vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string));

  vector_elements(vec)[index] = val;
  return(val);
}

static s7_pointer vector_set_3;
static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args)
{
  s7_pointer ind;
  ind = cadr(args);
  if (!s7_is_integer(ind))
    {
      s7_pointer p;
      if (!s7_is_integer(p = check_values(sc, ind, cdr(args))))
	return(wrong_type_argument(sc, sc->vector_set_symbol, 2, ind, T_INTEGER));
      else ind = p;
    }
  return(c_vector_set_3(sc, car(args), s7_integer(ind), caddr(args)));
}

PIPF_TO_PF(vector_set, c_vector_set_s, c_vector_set_3, c_vector_tester)


static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_vector "(make-vector len (value #<unspecified>)) 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."
  #define Q_make_vector s7_make_signature(sc, 3, sc->is_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T)

  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_symbol, 1, x, a_non_negative_integer_string));
    }
  else
    {
      if (!(is_pair(x)))
	method_or_bust_with_type(sc, x, sc->make_vector_symbol, args, make_string_wrapper(sc, "an integer or a list of integers"), 1);

      if (!s7_is_integer(car(x)))
	return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, 1, car(x),
					     make_string_wrapper(sc, "each dimension should be an integer")));
      if (is_null(cdr(x)))
	len = s7_integer(car(x));
      else
	{
	  int dims;
	  s7_pointer y;

	  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_symbol, 1, x, a_proper_list_string));
	  if (dims > sc->max_vector_dimensions)
	    return(out_of_range(sc, sc->make_vector_symbol, small_int(1), x, its_too_large_string));

	  for (len = 1, y = x; is_not_null(y); y = cdr(y))
	    {
	      if (!s7_is_integer(car(y)))
		return(wrong_type_argument(sc, sc->make_vector_symbol, position_of(y, x), car(y), T_INTEGER));
	      len *= s7_integer(car(y));
	      if (len < 0)
		return(wrong_type_argument_with_type(sc, sc->make_vector_symbol, position_of(y, x), car(y), a_non_negative_integer_string));
	    }
	}
    }

  if (is_not_null(cdr(args)))
    {
      fill = cadr(args);
      if (is_not_null(cddr(args)))
	{
	  if (caddr(args) == sc->T)
	    {
	      /* here bignums can cause confusion, so use is_integer not s7_is_integer etc */
	      if (is_integer(fill))
		result_type = T_INT_VECTOR;
	      else
		{
		  if (s7_is_real(fill)) /* might be gmp with big_real by accident (? see above) */
		    result_type = T_FLOAT_VECTOR;
		  else method_or_bust_with_type(sc, fill, sc->make_vector_symbol, args, make_string_wrapper(sc, "an integer or a real since 'homogeneous' is #t"), 2);
		}
	    }
	  else
	    {
	      if (caddr(args) != sc->F)
		method_or_bust_with_type(sc, caddr(args), sc->make_vector_symbol, args, a_boolean_string, 3);
	    }
	}
    }

  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;
      vdims_t *v;

      v = (vdims_t *)malloc(sizeof(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);
}

IF_TO_PF(make_vector, s7_make_vector)


static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector."
  #define Q_make_float_vector s7_make_signature(sc, 3, sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol)
  s7_int len;
  s7_pointer x, p;
  s7_double *arr;

  p = car(args);
  if ((is_pair(cdr(args))) ||
      (!is_integer(p)))
    {
      s7_pointer init;
      if (is_pair(cdr(args)))
	{
	  init = cadr(args);
	  if (!s7_is_real(init))
	    method_or_bust(sc, init, sc->make_float_vector_symbol, args, T_REAL, 2);
#if WITH_GMP
	  if (s7_is_bignum(init))
	    return(g_make_vector(sc, set_plist_3(sc, p, make_real(sc, real_to_double(sc, init, "make-float-vector")), sc->T)));
#endif
	  if (is_rational(init))
	    return(g_make_vector(sc, set_plist_3(sc, p, make_real(sc, rational_to_double(sc, init)), sc->T)));
	}
      else init = real_zero;
      return(g_make_vector(sc, set_plist_3(sc, p, init, sc->T)));
    }

  len = s7_integer(p);
  if (len < 0)
    return(wrong_type_argument_with_type(sc, sc->make_float_vector_symbol, 1, p, a_non_negative_integer_string));
  if (len > sc->max_vector_length)
    return(out_of_range(sc, sc->make_float_vector_symbol, small_int(1), p, its_too_large_string));

  if (len > 0)
    arr = (s7_double *)calloc(len, sizeof(s7_double));
  else arr = NULL;

  new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
  vector_length(x) = len;
  float_vector_elements(x) = arr;
  vector_dimension_info(x) = NULL;
  vector_getter(x) = float_vector_getter;
  vector_setter(x) = float_vector_setter;

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

static s7_pointer c_make_float_vector(s7_scheme *sc, s7_int len) {return(s7_make_float_vector(sc, len, 1, NULL));}
IF_TO_PF(make_float_vector, c_make_float_vector)


static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_make_int_vector "(make-int-vector len (init 0.0)) returns an int-vector."
  #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol)

  s7_int len;
  s7_pointer x, p;
  s7_int *arr;

  p = car(args);
  if ((is_pair(cdr(args))) ||
      (!is_integer(p)))
    {
      s7_pointer init;
      if (is_pair(cdr(args)))
	{
	  init = cadr(args);
	  if (!is_integer(init))
	    method_or_bust(sc, init, sc->make_int_vector_symbol, args, T_INTEGER, 2);
	}
      else init = small_int(0);
      return(g_make_vector(sc, set_plist_3(sc, p, init, sc->T)));
    }

  len = s7_integer(p);
  if (len < 0)
    return(wrong_type_argument_with_type(sc, sc->make_int_vector_symbol, 1, p, a_non_negative_integer_string));
  if (len > sc->max_vector_length)
    return(out_of_range(sc, sc->make_int_vector_symbol, small_int(1), p, its_too_large_string));

  if (len > 0)
    arr = (s7_int *)calloc(len, sizeof(s7_int));
  else arr = NULL;

  new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE);
  vector_length(x) = len;
  int_vector_elements(x) = arr;
  vector_dimension_info(x) = NULL;
  vector_getter(x) = int_vector_getter;
  vector_setter(x) = int_vector_setter;

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

static s7_pointer c_make_int_vector(s7_scheme *sc, s7_int len) {return(s7_make_int_vector(sc, len, 1, NULL));}
IF_TO_PF(make_int_vector, c_make_int_vector)


static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args)
{
  #define H_is_vector "(vector? obj) returns #t if obj is a vector"
  #define Q_is_vector pl_bt
  check_boolean_method(sc, s7_is_vector, sc->is_vector_symbol, 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)))"
  #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol)

  s7_pointer x;
  x = car(args);
  if (!s7_is_vector(x))
    method_or_bust(sc, x, sc->vector_dimensions_symbol, args, T_VECTOR, 0);

  if (vector_rank(x) > 1)
    {
      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))));
}

static s7_pointer c_vector_dimensions(s7_scheme *sc, s7_pointer x) {return(g_vector_dimensions(sc, set_plist_1(sc, x)));}
PF_TO_PF(vector_dimensions, c_vector_dimensions)


#define MULTIVECTOR_TOO_MANY_ELEMENTS -1
#define MULTIVECTOR_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(MULTIVECTOR_NOT_ENOUGH_ELEMENTS);

      if (dimension == (dimensions - 1))
	vector_setter(vec)(sc, vec, flat_ref++, car(x));
      else
	{
	  flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x));
	  if (flat_ref < 0) return(flat_ref);
	}
    }
  if (is_not_null(x))
    return(MULTIVECTOR_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_symbol, 
		  set_elist_3(sc, make_string_wrapper(sc, "reading constant vector, ~A: ~A"), make_string_wrapper(sc, message), data)));
}


static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
{
  /* get the dimension bounds from data, make the new vector, fill it from data
   *
   * dims needs to be s7_int so we can at least give correct error messages.
   * 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"));
  if (dims > sc->max_vector_dimensions)
    return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, make_integer(sc, dims), "must be < 512")); /* sc->max_vector_dimensions=512 currently */

  sc->w = sc->nil;
  if (is_null(data))  /* dims are already 0 (calloc above) */
    return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, 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, set_plist_1(sc, sc->w = 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 == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data));

  return(vec);
}


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_float_vector(old_vect))
    {
      if (vector_rank(old_vect) > 1)
	new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), real_zero, sc->T));
      else new_vect = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR);
      if (len > 0) 
	memcpy((void *)(float_vector_elements(new_vect)), (void *)(float_vector_elements(old_vect)), len * sizeof(s7_double));
    }
  else
    {
      if (is_int_vector(old_vect))
	{
	  if (vector_rank(old_vect) > 1)
	    new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), small_int(0), sc->T));
	  else new_vect = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
	  if (len > 0) 
	    memcpy((void *)(int_vector_elements(new_vect)), (void *)(int_vector_elements(old_vect)), len * sizeof(s7_int));
	}
      else
	{
	  if (vector_rank(old_vect) > 1)
	    new_vect = g_make_vector(sc, set_plist_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) */
	  if (len > 0) 
	    memcpy((void *)(vector_elements(new_vect)), (void *)(vector_elements(old_vect)), len * sizeof(s7_pointer));
	}
    }
  return(new_vect);
}


static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, bool flt)
{
  s7_pointer v, caller;
  s7_int ind;
  int typ;

  caller = (flt) ? sc->float_vector_ref_symbol : sc->int_vector_ref_symbol;
  typ = (flt) ? T_FLOAT_VECTOR : T_INT_VECTOR;

  v = car(args);
  if (type(v) != typ)
    method_or_bust(sc, v, caller, args, typ, 1);

  if (vector_rank(v) == 1)
    {
      s7_pointer index;
      index = cadr(args);
      if (!s7_is_integer(index))
	{
	  s7_pointer p;
	  if (!s7_is_integer(p = check_values(sc, index, cdr(args))))
	    return(wrong_type_argument(sc, caller, 2, index, T_INTEGER));
	  else index = p;
	}
      ind = s7_integer(index);
      if ((ind < 0) || (ind >= vector_length(v)))
	return(simple_out_of_range(sc, caller, index, (ind < 0) ? its_negative_string : its_too_large_string));
      if (!is_null(cddr(args)))
	return(out_of_range(sc, caller, small_int(2), cdr(args), too_many_indices_string));
    }
  else
    {
      unsigned int i;
      s7_pointer x;
      ind = 0;
      for (x = cdr(args), i = 0; (is_not_null(x)) && (i < vector_ndims(v)); x = cdr(x), i++)
	{
	  s7_int n;
	  if (!s7_is_integer(car(x)))
	    {
	      s7_pointer p;
	      if (!s7_is_integer(p = check_values(sc, car(x), x)))
		return(wrong_type_argument(sc, caller, i + 2, car(x), T_INTEGER));
	      n = s7_integer(p);
	    }
	  else n = s7_integer(car(x));
	  if ((n < 0) ||
	      (n >= vector_dimension(v, i)))
	    return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? its_negative_string : its_too_large_string));

	  ind += n * vector_offset(v, i);
	}
      if (is_not_null(x))
	return(out_of_range(sc, caller, small_int(2), cdr(args), too_many_indices_string));

      /* if not enough indices, return a shared vector covering whatever is left */
      if (i < vector_ndims(v))
	return(make_shared_vector(sc, v, i, ind));
    }
  if (flt)
    return(make_real(sc, float_vector_element(v, ind)));
  return(make_integer(sc, int_vector_element(v, ind)));
}


static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, bool flt)
{
  s7_pointer vec, val, caller;
  s7_int index;
  int typ;

  caller = (flt) ? sc->float_vector_set_symbol : sc->int_vector_set_symbol;
  typ = (flt) ? T_FLOAT_VECTOR : T_INT_VECTOR;

  vec = car(args);
  if (type(vec) != typ)
    method_or_bust(sc, vec, caller, args, typ, 1);

  if (vector_rank(vec) > 1)
    {
      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)))
	    {
	      s7_pointer p;
	      if (!s7_is_integer(p = check_values(sc, car(x), x)))
		method_or_bust(sc, car(x), caller, args, T_INTEGER, i + 2);
	      n = s7_integer(p);
	    }
	  else n = s7_integer(car(x));
	  if ((n < 0) ||
	      (n >= vector_dimension(vec, i)))
	    return(out_of_range(sc, caller, make_integer(sc, i + 2), car(x), (n < 0) ? its_negative_string : its_too_large_string));

	  index += n * vector_offset(vec, i);
	}

      if (is_not_null(cdr(x)))
	return(s7_wrong_number_of_args_error(sc, "too many args: ~S", args));
      if (i != vector_ndims(vec))
	return(s7_wrong_number_of_args_error(sc, "not enough args: ~S", args));

      val = car(x);
    }
  else
    {
      if (!s7_is_integer(cadr(args)))
	{
	  s7_pointer p;
	  if (!s7_is_integer(p = check_values(sc, cadr(args), cdr(args))))
	    method_or_bust(sc, cadr(args), caller, args, T_INTEGER, 2);
	  index = s7_integer(p);
	}
      else index = s7_integer(cadr(args));
      if ((index < 0) ||
	  (index >= vector_length(vec)))
	return(out_of_range(sc, caller, small_int(2), cadr(args), (index < 0) ? its_negative_string : its_too_large_string));

      if (is_not_null(cdddr(args)))
	return(s7_wrong_number_of_args_error(sc, "too many args: ~S", args));
      val = caddr(args);
    }

  if (flt)
    {
      if (!s7_is_real(val))
	method_or_bust(sc, val, caller, args, T_REAL, 3);
      float_vector_element(vec, index) = real_to_double(sc, val, "float-vector-set!");
      /* currently this accepts a complex value and assigns real_part(val) to the float-vector -- maybe an error instead? */
    }
  else
    {
      if (!s7_is_integer(val))
	method_or_bust(sc, val, caller, args, T_INTEGER, 3);
      int_vector_element(vec, index) = s7_integer(val);
    }
  return(val);
}


static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v."
  #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, true));
}


static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value."
  #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol)
  return(univect_set(sc, args, true));
}

static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v."
  #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
  return(univect_ref(sc, args, false));
}

static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args)
{
  #define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value."
  #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
  return(univect_set(sc, args, false));
}


/* int-vector-ref|set optimizers */

static s7_int int_vector_ref_if_a(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t xf;
  s7_pointer x;
  s7_int y;
  x = (**p); (*p)++;
  if (!is_int_vector(x))
    wrong_type_argument(sc, sc->int_vector_ref_symbol, 1, x, T_INT_VECTOR);
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  if ((y < 0) || (y >= vector_length(x)))
    out_of_range(sc, sc->int_vector_ref_symbol, small_int(2), make_integer(sc, y), (y < 0) ? its_negative_string : its_too_large_string);
  return(int_vector_elements(x)[y]);
}

static s7_if_t int_vector_ref_if_expanded(s7_scheme *sc, s7_pointer iv, s7_pointer ind_expr)
{
  s7_xf_store(sc, iv);
  if (s7_arg_to_if(sc, ind_expr))
    return(int_vector_ref_if_a);
  return(NULL);
}

static s7_if_t int_vector_ref_if(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      s7_pointer iv;
      iv = cadr(expr);
      if (!is_symbol(iv)) return(NULL);
      iv = s7_slot(sc, iv);
      if (!is_slot(iv)) return(NULL);
      if (!is_int_vector(slot_value(iv))) return(NULL);
      return(int_vector_ref_if_expanded(sc, slot_value(iv), caddr(expr)));
    }
  return(NULL);				
}

static s7_if_t implicit_int_vector_ref(s7_scheme *sc, s7_pointer expr)
{
  if ((is_null(cdr(expr))) || (!is_null(cddr(expr)))) return(NULL);
  return(int_vector_ref_if_expanded(sc, s7_symbol_value(sc, car(expr)), cadr(expr)));
}

static s7_int int_vector_set_if_a(s7_scheme *sc, s7_pointer **p)
{
  s7_if_t xf;
  s7_pointer x;
  s7_int y, z;
  x = (**p); (*p)++;
  if (!is_int_vector(x))
    wrong_type_argument(sc, sc->int_vector_set_symbol, 1, x, T_INT_VECTOR);
  xf = (s7_if_t)(**p); (*p)++;
  y = xf(sc, p);
  if ((y < 0) || (y >= vector_length(x)))
    out_of_range(sc, sc->int_vector_set_symbol, small_int(2), make_integer(sc, y), (y < 0) ? its_negative_string : its_too_large_string);
  xf = (s7_if_t)(**p); (*p)++;
  z = xf(sc, p);
  int_vector_elements(x)[y] = z;
  return(z);
}

static s7_if_t int_vector_set_if_expanded(s7_scheme *sc, s7_pointer iv, s7_pointer ind_sym, s7_pointer val_expr)
{
  s7_xf_store(sc, iv);
  if ((s7_arg_to_if(sc, ind_sym)) &&
      (s7_arg_to_if(sc, val_expr)))
    return(int_vector_set_if_a);			
  return(NULL);
}

static s7_if_t int_vector_set_if(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_pair(cdddr(expr))) && (is_null(cddddr(expr))))
    {
      s7_pointer iv;
      iv = cadr(expr);
      if (!is_symbol(iv)) return(NULL);
      iv = s7_slot(sc, iv);
      if (!is_slot(iv)) return(NULL);
      if (!is_int_vector(slot_value(iv))) return(NULL);
      return(int_vector_set_if_expanded(sc, slot_value(iv), caddr(expr), cadddr(expr)));
    }
  return(NULL);
}



/* float-vector-ref|set optimizers */
static s7_double fv_set_rf_checked(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer fv, ind;
  s7_double val;
  s7_int index;
  s7_rf_t rf;
  fv = **p; (*p)++;
  ind = slot_value(**p); (*p)++;
  if (!is_integer(ind))
    wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
  index = integer(ind);
  if ((index < 0) || (index >= vector_length(fv)))
    out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
  rf = (s7_rf_t)(**p); (*p)++;
  val = rf(sc, p);
  float_vector_element(fv, index) = val;
  return(val);
}

static s7_double fv_set_rf_r(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer fv, ind, x;
  s7_double val;
  s7_int index;
  fv = **p; (*p)++;
  ind = slot_value(**p); (*p)++;
  if (!is_integer(ind))
    wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
  index = integer(ind);
  if ((index < 0) || (index >= vector_length(fv)))
    out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
  x = **p; (*p)++;
  val = real_to_double(sc, x, "float-vector-set!");
  float_vector_element(fv, index) = val;
  return(val);
}

static s7_double fv_set_rf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer fv, ind, x;
  s7_double val;
  s7_int index;
  fv = **p; (*p)++;
  ind = slot_value(**p); (*p)++;
  if (!is_integer(ind))
    wrong_type_argument(sc, sc->float_vector_set_symbol, 2, ind, T_INTEGER);
  index = integer(ind);
  if ((index < 0) || (index >= vector_length(fv)))
    out_of_range(sc, sc->float_vector_set_symbol, small_int(2), ind, (index < 0) ? its_negative_string : its_too_large_string);
  x = slot_value(**p); (*p)++;
  val = real_to_double(sc, x, "float-vector-set!");
  float_vector_element(fv, index) = val;
  return(val);
}


static s7_double fv_set_rf_six(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer fv, ind;
  s7_double val;
  s7_int index;
  s7_rf_t rf;
  fv = **p; (*p)++;
  ind = **p; (*p)++;
  index = integer(ind);
  rf = (s7_rf_t)(**p); (*p)++;
  val = rf(sc, p);
  float_vector_element(fv, index) = val;
  return(val);
}

static s7_double fv_set_rf_if(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer fv;
  s7_double val;
  s7_int index;
  s7_rf_t rf;
  s7_if_t xf;
  fv = **p; (*p)++;
  xf = (s7_if_t)(**p); (*p)++;
  index = xf(sc, p);
  if ((index < 0) || (index >= vector_length(fv)))
    out_of_range(sc, sc->float_vector_set_symbol, small_int(2), make_integer(sc, index), (index < 0) ? its_negative_string : its_too_large_string);
  rf = (s7_rf_t)(**p); (*p)++;
  val = rf(sc, p);
  float_vector_element(fv, index) = val;
  return(val);
}

static s7_rf_t float_vector_set_rf_expanded(s7_scheme *sc, s7_pointer fv, s7_pointer ind_sym, s7_pointer val_expr)
{
  xf_t *rc;
  xf_init(3);
  xf_store(fv);
  if (is_symbol(ind_sym))
    {
      s7_pointer ind, ind_slot;

      ind_slot = s7_slot(sc, ind_sym);
      if (!is_slot(ind_slot)) return(NULL);
      ind = slot_value(ind_slot);
      if (!is_integer(ind)) return(NULL);
      if (numerator(ind) < 0) return(NULL);
      xf_store(ind_slot);
      if (is_real(val_expr)) 
	{
	  xf_store(val_expr);
	  return(fv_set_rf_r);
	}
      if (is_symbol(val_expr)) 
	{
	  s7_pointer slot, val;
	  slot = s7_slot(sc, val_expr);
	  if (!is_slot(slot)) return(NULL);
	  val = slot_value(slot);
	  if (!is_real(val)) return(NULL);
	  xf_store(slot);
	  return(fv_set_rf_s);
	}
      if (!is_pair(val_expr)) return(NULL);
      return(pair_to_rf(sc, val_expr, fv_set_rf_checked));
    }
  if (is_pair(ind_sym))
    {
      s7_ip_t ip;
      s7_if_t xf;
      s7_int loc;
      if (!is_pair(val_expr)) return(NULL);
      xf_save_loc(loc);
      ip = pair_to_ip(sc, ind_sym);
      if (!ip) return(NULL);
      xf = ip(sc, ind_sym);
      if (!xf) return(NULL);
      xf_store_at(loc, (s7_pointer)xf);
      return(pair_to_rf(sc, val_expr, fv_set_rf_if));
    }
  if ((is_integer(ind_sym)) &&
      (is_pair(val_expr)))
    {
      s7_int index;
      index = integer(ind_sym);
      if ((index < 0) || (index >= vector_length(fv))) return(NULL);
      xf_store(ind_sym);
      return(pair_to_rf(sc, val_expr, fv_set_rf_six));
    }
  return(NULL);
}

static s7_rf_t float_vector_set_rf(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer fv;
  fv = cadr(expr);
  if (!is_symbol(fv)) return(NULL);
  fv = s7_slot(sc, fv);
  if (!is_slot(fv)) return(NULL);
  if (!is_float_vector(slot_value(fv))) return(NULL);
  return(float_vector_set_rf_expanded(sc, slot_value(fv), caddr(expr), cadddr(expr)));
}


static s7_double fv_ref_rf_ss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_int ind;
  s1 = slot_value(**p); (*p)++;
  s2 = slot_value(**p); (*p)++;
  ind = s7_integer(s2);
  if ((ind < 0) || (ind >= vector_length(s1)))
    out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), s2, (ind < 0) ? its_negative_string : its_too_large_string);    
  return(float_vector_elements(s1)[ind]);
}

static s7_double fv_ref_rf_si(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1, s2;
  s7_int ind;
  s1 = slot_value(**p); (*p)++;
  s2 = (**p); (*p)++;
  ind = s7_integer(s2);
  if ((ind < 0) || (ind >= vector_length(s1)))
    out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), s2, (ind < 0) ? its_negative_string : its_too_large_string);    
  return(float_vector_elements(s1)[ind]);
}

static s7_double fv_ref_rf_sx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_if_t i1;
  s7_int ind;
  s1 = slot_value(**p); (*p)++;
  i1 = (s7_if_t)(**p); (*p)++;
  ind = i1(sc, p);
  if ((ind < 0) || (ind >= vector_length(s1)))
    out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string);    
  return(float_vector_elements(s1)[ind]);
}

static s7_double fv_ref_rf_pf(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer s1;
  s7_pf_t fv;
  s7_if_t i1;
  s7_int ind;
  fv = (s7_pf_t)(**p); (*p)++;
  s1 = fv(sc, p);
  if (!is_float_vector(s1))
    wrong_type_argument(sc, sc->float_vector_ref_symbol, 1, s1, T_FLOAT_VECTOR);    
  i1 = (s7_if_t)(**p); (*p)++;
  ind = i1(sc, p);
  if ((ind < 0) || (ind >= vector_length(s1)))
    out_of_range(sc, sc->float_vector_ref_symbol, small_int(2), make_integer(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string);    
  return(float_vector_elements(s1)[ind]);
}

static s7_rf_t float_vector_ref_rf_expanded(s7_scheme *sc, s7_pointer a1, s7_pointer a2)
{
  if ((is_symbol(a1)) &&
      (is_float_vector(s7_symbol_value(sc, a1))))
    {
      xf_t *rc;
      xf_init(2);
      xf_store(s7_slot(sc, a1));
      if (is_integer(a2))
	{
	  xf_store(a2);
	  return(fv_ref_rf_si);
	}
      if (is_symbol(a2))
	{
	  a2 = s7_slot(sc, a2);
	  if ((!is_slot(a2)) || (is_t_complex(slot_value(a2)))) return(NULL);
	  xf_store(a2);
	  return(fv_ref_rf_ss);
	}
      if (is_pair(a2))
	return(pair_to_rf_via_if(sc, a2, fv_ref_rf_sx));
    }
  if ((is_pair(a1)) &&
      (s7_arg_to_pf(sc, a1)) &&
      (s7_arg_to_if(sc, a2)))
    return(fv_ref_rf_pf);
  return(NULL);
}

static s7_rf_t float_vector_ref_rf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_null(cdr(expr))) || (is_null(cddr(expr))) || (!is_null(cdddr(expr)))) return(NULL);
  return(float_vector_ref_rf_expanded(sc, cadr(expr), caddr(expr)));
}

static s7_rf_t implicit_float_vector_ref(s7_scheme *sc, s7_pointer expr)
{
  if ((is_null(cdr(expr))) || (!is_null(cddr(expr)))) return(NULL);
  return(float_vector_ref_rf_expanded(sc, car(expr), cadr(expr)));
}


static s7_pointer hash_table_ref_pf_i(s7_scheme *sc, s7_pointer **p);
static s7_pointer hash_table_set_pf_sxx(s7_scheme *sc, s7_pointer **p);

static s7_pf_t implicit_pf_sequence_ref(s7_scheme *sc, s7_pointer expr) 
{
  s7_pointer seq, ind;
  if ((is_null(cdr(expr))) || (!is_null(cddr(expr)))) return(NULL);
  seq = car(expr);
  ind = cadr(expr);
  if (!is_symbol(seq)) return(NULL);
  seq = s7_slot(sc, seq);
  if (!is_slot(seq)) return(NULL);
  s7_xf_store(sc, seq);
  switch (type(slot_value(seq)))
    {
    case T_STRING:
      if (s7_arg_to_if(sc, ind))
	return(string_ref_pf_si);
      break;
      
    case T_PAIR:
      if (s7_arg_to_if(sc, ind))
	return(list_ref_pf_si);
      break;
      
    case T_VECTOR:
      if (s7_arg_to_if(sc, ind))
	return(vector_ref_pf_i);  /* TODO: these vref funcs don't check bounds */
      break;
      
    case T_HASH_TABLE:
      if (s7_arg_to_pf(sc, ind))
	return(hash_table_ref_pf_i);
      break;
      
    case T_LET:
      if (s7_arg_to_pf(sc, ind))
	return(let_ref_pf_p2_sp);
      break;
    }
  return(NULL);
}

static s7_pf_t implicit_gf_sequence_ref(s7_scheme *sc, s7_pointer expr) 
{
  /* only difference from pf case: int|float-vectors return s7_pointer values */
  return(implicit_pf_sequence_ref(sc, expr));
}

#if WITH_OPTIMIZATION
static s7_pf_t implicit_pf_sequence_set(s7_scheme *sc, s7_pointer seq, s7_pointer ind, s7_pointer val)
{
  /* seq is the slot */
  s7_xf_store(sc, seq);
  switch (type(slot_value(seq)))
    {
    case T_STRING:
      if ((s7_arg_to_if(sc, ind)) &&
	  (s7_arg_to_pf(sc, val)))
	return(string_set_pf_seq);
      break;
      
    case T_PAIR:
      if ((s7_arg_to_if(sc, ind)) &&
	  (s7_arg_to_pf(sc, val)))
	return(list_set_pf_seq);
      break;
      
    case T_VECTOR:
      if ((s7_arg_to_if(sc, ind)) &&
	  (s7_arg_to_pf(sc, val)))
	return(vector_set_pf_seq);
      break;
      
    case T_HASH_TABLE:
      if ((s7_arg_to_pf(sc, ind)) &&
	  (s7_arg_to_pf(sc, val)))
	return(hash_table_set_pf_sxx);
      break;
      
    case T_LET:
      if ((s7_arg_to_pf(sc, ind)) &&
	  (s7_arg_to_pf(sc, val)))
	return(let_set_pf_p3_s);
      break;
    }
  return(NULL);
}

static s7_pf_t implicit_gf_sequence_set(s7_scheme *sc, s7_pointer v, s7_pointer ind, s7_pointer val) 
{
  return(implicit_pf_sequence_set(sc, v, ind, val));
}
#endif



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

static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
{
  /* macro version of this (below) is much slower! */
  s7_pointer p;

  p = car(x);
  if (is_global(p)) p = slot_value(global_slot(p)); else p = find_symbol_unchecked(sc, p);
  /* this is nearly always global and p == opt_cfunc(x) 
   * p can be null if we evaluate some code, optimizing it, then eval it again in a context
   *   where the incoming p was undefined(!) -- explicit use of eval and so on.
   *   I guess ideally eval would ignore optimization info -- copy :readable or something.
   */
  return((p == opt_any1(x)) ||
	 ((is_any_c_function(p)) && /* (opt_cfunc(x)) && */
	  (c_function_class(p) == c_function_class(opt_cfunc(x)))));
}

static bool arglist_has_rest(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    if (car(p) == sc->key_rest_symbol)
      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);
}


/* -------- sort! -------- */

#if (!WITH_GMP)
static int dbl_less(const void *f1, const void *f2)
{
  if ((*((s7_double *)f1)) < (*((s7_double *)f2))) return(-1);
  if ((*((s7_double *)f1)) > (*((s7_double *)f2))) return(1);
  return(0);
}

static int int_less(const void *f1, const void *f2)
{
  if ((*((s7_int *)f1)) < (*((s7_int *)f2))) return(-1);
  if ((*((s7_int *)f1)) > (*((s7_int *)f2))) return(1);
  return(0);
}

static int dbl_greater(const void *f1, const void *f2) {return(-dbl_less(f1, f2));}
static int int_greater(const void *f1, const void *f2) {return(-int_less(f1, f2));}

static int byte_less(const void *f1, const void *f2)
{
  if ((*((unsigned char *)f1)) < (*((unsigned char *)f2))) return(-1);
  if ((*((unsigned char *)f1)) > (*((unsigned char *)f2))) return(1);
  return(0);
}

static int byte_greater(const void *f1, const void *f2) {return(-byte_less(f1, f2));}

static int dbl_less_2(const void *f1, const void *f2)
{
  s7_pointer p1, p2;
  p1 = (*((s7_pointer *)f1));
  p2 = (*((s7_pointer *)f2));
  if (real(p1) < real(p2)) return(-1);
  if (real(p1) > real(p2)) return(1);
  return(0);
}

static int int_less_2(const void *f1, const void *f2)
{
  s7_pointer p1, p2;
  p1 = (*((s7_pointer *)f1));
  p2 = (*((s7_pointer *)f2));
  if (integer(p1) < integer(p2)) return(-1);
  if (integer(p1) > integer(p2)) return(1);
  return(0);
}

static int dbl_greater_2(const void *f1, const void *f2) {return(-dbl_less_2(f1, f2));}
static int int_greater_2(const void *f1, const void *f2) {return(-int_less_2(f1, f2));}
#endif

static s7_scheme *compare_sc;
static s7_function compare_func;
static s7_pointer compare_args, compare_begin, compare_v1, compare_v2;
static opcode_t compare_op;
static s7_pf_t compare_pf;

static int vector_compare(const void *v1, const void *v2)
{
  set_car(compare_args, (*(s7_pointer *)v1));
  set_cadr(compare_args, (*(s7_pointer *)v2));
  return(((*(compare_func))(compare_sc, compare_args) != compare_sc->F) ? -1 : 1);
}

static int pf_compare(const void *v1, const void *v2)
{
  s7_pointer *top;
  s7_pointer **rp;
  slot_set_value(compare_v1, (*(s7_pointer *)v1));
  slot_set_value(compare_v2, (*(s7_pointer *)v2));
  top = compare_sc->cur_rf->data;
  rp = &top; (*rp)++;
  if (is_true(compare_sc, compare_pf(compare_sc, rp)))
    return(-1);
  return(1);
}

static int closure_compare(const void *v1, const void *v2)
{
  slot_set_value(compare_v1, (*(s7_pointer *)v1));
  slot_set_value(compare_v2, (*(s7_pointer *)v2));
  push_stack(compare_sc, OP_EVAL_DONE, compare_sc->args, compare_sc->code);
  compare_sc->code = compare_args; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */
  eval(compare_sc, compare_op);
  return((compare_sc->value != compare_sc->F) ? -1 : 1);
}

static int closure_compare_begin(const void *v1, const void *v2)
{
  slot_set_value(compare_v1, (*(s7_pointer *)v1));
  slot_set_value(compare_v2, (*(s7_pointer *)v2));
  push_stack(compare_sc, OP_EVAL_DONE, compare_sc->args, compare_sc->code);
  push_stack_no_args(compare_sc, OP_BEGIN1, compare_begin);
  compare_sc->code = compare_args;
  eval(compare_sc, compare_op);
  return((compare_sc->value != compare_sc->F) ? -1 : 1);
}

static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
{
  #define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements."
  #define Q_sort s7_make_signature(sc, 3, sc->T, sc->is_sequence_symbol, sc->is_procedure_symbol)

  s7_pointer data, lessp, lx;
  s7_int len = 0, n, k;
  int (*sort_func)(const void *v1, const void *v2);
  s7_pointer *elements;
  int gc_loc = -1;

  /* both the intermediate vector (if any) and the current args pointer need GC protection,
   *   but it is a real bother to unprotect args at every return statement, so I'll use temp3
   */
  sc->temp3 = args; /* this is needed! */
  data = car(args);
  if (is_null(data))
    {
      /* (apply sort! () #f) should be an error I think */
      lessp = cadr(args);
      if (type(lessp) < T_GOTO)
	method_or_bust_with_type(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2);
      if (!s7_is_aritable(sc, lessp, 2))
	return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, an_eq_func_string));
      return(sc->nil);
    }

  lessp = cadr(args);
  if (type(lessp) < T_GOTO)
    method_or_bust_with_type(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2);
  if (!s7_is_aritable(sc, lessp, 2))
    return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, an_eq_func_string));

  if ((is_continuation(lessp)) || is_goto(lessp))
    return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, a_normal_procedure_string));

  sort_func = vector_compare;
  compare_func = NULL;
  compare_args = sc->t2_1;
  compare_sc = sc;
  
  if ((is_safe_procedure(lessp)) &&     /* (sort! a <) */
      (is_c_function(lessp)))
    {
      s7_pointer sig;
      sig = c_function_signature(lessp);
      if ((sig) &&
	  (is_pair(sig)) &&
	  (car(sig) != sc->is_boolean_symbol))
	return(wrong_type_argument_with_type(sc, sc->sort_symbol, 2, lessp, make_string_wrapper(sc, "sort! function should return a boolean")));
      compare_func = c_function_call(lessp);
    }
  else
    {
      if (is_closure(lessp))
	{
	  s7_pointer expr, largs;
	  expr = car(closure_body(lessp));
	  largs = closure_args(lessp);

	  if ((is_null(cdr(closure_body(lessp)))) &&
	      (is_optimized(expr)))
	    {
	      /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in
	       *   optimize in this case, for some arcane reason), the optimized expression won't be hop_safe,
	       *   but that is irrelevant at this point -- if c_function_is_ok, we're good to go.
	       */
	      if ((is_pair(largs)) &&
		  (!arglist_has_rest(sc, largs)) &&
		  (((optimize_op(expr) & 1) != 0) ||
		   (c_function_is_ok(sc, expr))))
		{
		  int orig_data;
		  orig_data = optimize_op(expr);
		  set_optimize_op(expr, optimize_op(expr) | 1);
		  if ((optimize_op(expr) == HOP_SAFE_C_SS) &&
		      (car(largs) == cadr(expr)) &&
		      (cadr(largs) == caddr(expr)))
		    {
		      lessp = find_symbol_unchecked(sc, car(expr));
		      compare_func = c_function_call(lessp);
		    }
		  else
		    {
		      if (!is_unsafe_sort(expr))
			{
			  new_frame_with_two_slots(sc, closure_let(lessp), sc->envir, car(largs), sc->F, cadr(largs), sc->F);
			  set_stepper(let_slots(sc->envir));
			  set_stepper(next_slot(let_slots(sc->envir)));
			  s7_xf_new(sc, sc->envir);
			  compare_pf = xf_opt(sc, expr);
			  if (compare_pf)
			    {
			      sort_func = pf_compare;
			      compare_func = g_sort; /* whatever...(just a flag) */
			      compare_v1 = let_slots(sc->envir);
			      compare_v2 = next_slot(let_slots(sc->envir));
			    }
			  else
			    {
			      set_unsafe_sort(expr);
			      s7_xf_free(sc);
			    }
			}
		    }
		  set_optimize_op(expr, orig_data);
		}
	    }

	  if ((!compare_func) &&
	      (is_pair(largs)) &&       /* closure args not a symbol, etc */
	      (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */
	    {
	      new_frame_with_two_slots(sc, closure_let(lessp), sc->envir, car(largs), sc->F, cadr(largs), sc->F);
	      compare_func = (s7_function)lessp;       /* not used -- just a flag */
	      compare_args = car(closure_body(lessp));
	      compare_begin = cdr(closure_body(lessp));
	      if (is_null(compare_begin))
		sort_func = closure_compare;
	      else sort_func = closure_compare_begin;
	      if (typesflag(compare_args) == SYNTACTIC_PAIR)
		{
		  compare_op = (opcode_t)pair_syntax_op(compare_args);
		  compare_args = cdr(compare_args);
		}
	      else compare_op = OP_EVAL;
	      compare_v1 = let_slots(sc->envir);
	      compare_v2 = next_slot(let_slots(sc->envir));
	    }
	}
    }

#if (!WITH_GMP)
  if (compare_func == g_less)
    compare_func = g_less_2;
  else
    {
      if (compare_func == g_greater)
	compare_func = g_greater_2;
    }
#endif

  switch (type(data))
    {
    case T_PAIR:
      len = s7_list_length(sc, data);            /* 0 here == infinite */
      if (len <= 0)
	{
	  if (sort_func == pf_compare) s7_xf_free(sc);
	  return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "sort! argument 1 should be a proper list: ~S"), data)));
	}
      if (len < 2)
	{
	  if (sort_func == pf_compare) s7_xf_free(sc);
	  return(data);
	}
      if (compare_func)
	{
	  int i;
	  s7_pointer vec, p;

	  vec = g_vector(sc, data);
	  gc_loc = s7_gc_protect(sc, vec);
	  elements = s7_vector_elements(vec);

	  sc->v = vec;
	  qsort((void *)elements, len, sizeof(s7_pointer), sort_func);
	  for (p = data, i = 0; i < len; i++, p = cdr(p))
	    set_car(p, elements[i]);

	  s7_gc_unprotect_at(sc, gc_loc);
	  if (sort_func == pf_compare) s7_xf_free(sc);
	  return(data);
	}

      push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */
      set_car(args, g_vector(sc, data));
      break;

    case T_STRING:
      {
	/* byte-vectors here also, so this isn't completely silly */
	int i;
	s7_pointer vec;
	unsigned char *chrs;

	len = string_length(data);
	if (len < 2) 
	  {
	    if (sort_func == pf_compare) s7_xf_free(sc);
	    return(data);
	  }

#if (!WITH_GMP)
	if (is_c_function(lessp))
	  {
	    if (((!is_byte_vector(data)) && (compare_func == g_chars_are_less)) ||
		((is_byte_vector(data)) && (compare_func == g_less_2)))
	      {
		qsort((void *)vector_elements(data), len, sizeof(unsigned char), byte_less);
		return(data);
	      }
	    if (((!is_byte_vector(data)) && (compare_func == g_chars_are_greater)) ||
		((is_byte_vector(data)) && (compare_func == g_greater_2)))
	      {
		qsort((void *)vector_elements(data), len, sizeof(unsigned char), byte_greater);
		return(data);
	      }
	  }
#endif

	vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
	gc_loc = s7_gc_protect(sc, vec);
	elements = s7_vector_elements(vec);
	chrs = (unsigned char *)string_value(data);

	if (is_byte_vector(data))
	  {
	    for (i = 0; i < len; i++)
	      elements[i] = small_int(chrs[i]);
	  }
	else
	  {
	    for (i = 0; i < len; i++)
	      elements[i] = chars[chrs[i]];
	  }

	if (compare_func)
	  {
	    sc->v = vec;
	    qsort((void *)elements, len, sizeof(s7_pointer), sort_func);

	    if (is_byte_vector(data))
	      {
		for (i = 0; i < len; i++)
		  chrs[i] = (char)integer(elements[i]);
	      }
	    else
	      {
		for (i = 0; i < len; i++)
		  chrs[i] = character(elements[i]);
	      }
	    s7_gc_unprotect_at(sc, gc_loc);
	    if (sort_func == pf_compare) s7_xf_free(sc);
	    return(data);
	  }

	push_stack(sc, OP_SORT_STRING_END, cons(sc, data, lessp), sc->code);
	set_car(args, vec);
	s7_gc_unprotect_at(sc, gc_loc);
      }
      break;

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
      {
	int i;
	s7_pointer vec;

	len = vector_length(data);
	if (len < 2) 
	  {
	    if (sort_func == pf_compare) s7_xf_free(sc);
	    return(data);
	  }
#if (!WITH_GMP)
	if (is_c_function(lessp))
	  {
	    if (compare_func == g_less_2)
	      {
		if (type(data) == T_FLOAT_VECTOR)
		  qsort((void *)vector_elements(data), len, sizeof(s7_double), dbl_less);
		else qsort((void *)vector_elements(data), len, sizeof(s7_int), int_less);
		return(data);
	      }
	    if (compare_func == g_greater_2)
	      {
		if (type(data) == T_FLOAT_VECTOR)
		  qsort((void *)vector_elements(data), len, sizeof(s7_double), dbl_greater);
		else qsort((void *)vector_elements(data), len, sizeof(s7_int), int_greater);
		return(data);
	      }
	  }
#endif

	/* currently we have to make the ordinary vector here even if not compare_func
	 *   because the sorter uses vector_element to access sort args (see SORT_DATA in eval).
	 *   This is probably better than passing down getter/setter (fewer allocations).
	 *   get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end)
	 */
	vec = make_vector_1(sc, len, FILLED, T_VECTOR);
	/* we need this vector prefilled because vector_getter below makes reals/int, causing possible GC
	 *   at any time during that loop, and the GC mark process expects the vector to have an s7_pointer
	 *   at every element.
	 */
	gc_loc = s7_gc_protect(sc, vec);
	elements = s7_vector_elements(vec);

	for (i = 0; i < len; i++)
	  elements[i] = vector_getter(data)(sc, data, i);

	if (compare_func)
	  {
	    sc->v = vec;
	    qsort((void *)elements, len, sizeof(s7_pointer), sort_func);

	    for (i = 0; i < len; i++)
	      vector_setter(data)(sc, data, i, elements[i]);

	    s7_gc_unprotect_at(sc, gc_loc);
	    if (sort_func == pf_compare) s7_xf_free(sc);
	    return(data);
	  }

	push_stack(sc, OP_SORT_VECTOR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original homogeneous vector and func */
	set_car(args, vec);
	s7_gc_unprotect_at(sc, gc_loc);
      }
      break;

    case T_VECTOR:
      len = vector_length(data);
      if (len < 2) 
	{
	  if (sort_func == pf_compare) s7_xf_free(sc);
	  return(data);
	}
      if (compare_func)
	{
	  /* here if, for example, compare_func == string<?, we could precheck for strings,
	   *   then qsort without the type checks.  Also common is (lambda (a b) (f (car a) (car b))).
	   */
#if (!WITH_GMP)
	  if ((compare_func == g_less_2) || (compare_func == g_greater_2))
	    {
	      int i, typ;
	      s7_pointer *els;
	      els = s7_vector_elements(data);
	      typ = type(els[0]);
	      if ((typ == T_INTEGER) || (typ == T_REAL))
		for (i = 1; i < len; i++)
		  if (type(els[i]) != typ)
		    {
		      typ = T_FREE;
		      break;
		    }
	      if (typ == T_INTEGER)
		{
		  qsort((void *)els, len, sizeof(s7_pointer), ((compare_func == g_less_2) ? int_less_2 : int_greater_2));
		  return(data);
		}
	      if (typ == T_REAL)
		{
		  qsort((void *)els, len, sizeof(s7_pointer), ((compare_func == g_less_2) ? dbl_less_2 : dbl_greater_2));
		  return(data);
		}
	    }
#endif
	  qsort((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func);
	  if (sort_func == pf_compare) s7_xf_free(sc);
	  return(data);
	}
      break;

    default:
      method_or_bust_with_type(sc, data, sc->sort_symbol, args, a_sequence_string, 1);
    }
  if (sort_func == pf_compare) s7_xf_free(sc);

  n = len - 1;
  k = ((int)(n / 2)) + 1;

  lx = s7_make_vector(sc, (sc->safety == 0) ? 4 : 6);
  gc_loc = s7_gc_protect(sc, lx);
  sc->v = lx;

  vector_element(lx, 0) = make_mutable_integer(sc, n);
  vector_element(lx, 1) = make_mutable_integer(sc, k);
  vector_element(lx, 2) = make_mutable_integer(sc, 0);
  vector_element(lx, 3) = make_mutable_integer(sc, 0);
  if (sc->safety != 0)
    {
      vector_element(lx, 4) = make_mutable_integer(sc, 0);
      vector_element(lx, 5) = make_integer(sc, n * n);
    }
  push_stack(sc, OP_SORT, args, lx);
  s7_gc_unprotect_at(sc, gc_loc);

  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.
   */
}

static s7_pointer c_sort_p(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(g_sort(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(sort, c_sort_p)


/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */
static s7_pointer vector_into_list(s7_pointer vect, s7_pointer lst)
{
  s7_pointer p;
  s7_pointer *elements;
  int i, len;

  elements = s7_vector_elements(vect);
  len = vector_length(vect);
  for (i = 0, p = lst; i < len; i++, p = cdr(p))
    set_car(p, elements[i]);
  return(lst);
}

static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest)
{
  s7_pointer *elements;
  int i, len;

  elements = s7_vector_elements(source);
  len = vector_length(source);
  
  if (is_float_vector(dest))
    {
      s7_double *flts;
      flts = float_vector_elements(dest);
      for (i = 0; i < len; i++)
	flts[i] = real(elements[i]);
    }
  else
    {
      s7_int *ints;
      ints = int_vector_elements(dest);
      for (i = 0; i < len; i++)
	ints[i] = integer(elements[i]);
    }
  return(dest);
}

static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest)
{
  s7_pointer *elements;
  int i, len;
  unsigned char *str;

  elements = s7_vector_elements(vect);
  len = vector_length(vect);
  str = (unsigned char *)string_value(dest);
  
  if (is_byte_vector(dest))
    {
      for (i = 0; i < len; i++)
	str[i] = (unsigned char)integer(elements[i]);
    }
  else
    {
      for (i = 0; i < len; i++)
	str[i] = character(elements[i]);
    }
  return(dest);
}



/* -------- hash tables -------- */

static hash_entry_t *hash_free_list = NULL;

static void free_hash_table(s7_pointer table)
{
  hash_entry_t **entries;
  entries = hash_table_elements(table);

  if (hash_table_entries(table) > 0)
    {
      unsigned int i, len;
      len = hash_table_mask(table) + 1;
      for (i = 0; i < len; i++)
	{
	  hash_entry_t *p, *n;
	  for (p = entries[i++]; p; p = n)
	    {
	      n = p->next;
	      p->next = hash_free_list;
	      hash_free_list = p;
	    }
	  for (p = entries[i]; p; p = n)
	    {
	      n = p->next;
	      p->next = hash_free_list;
	      hash_free_list = p;
	    }
	}
    }
  free(entries);
}

static hash_entry_t *make_hash_entry(s7_pointer key, s7_pointer value, unsigned int raw_hash)
{
  hash_entry_t *p;
  if (hash_free_list)
    {
      p = hash_free_list;
      hash_free_list = p->next;
    }
  else p = (hash_entry_t *)malloc(sizeof(hash_entry_t));
  p->key = key;
  p->value = value;
  p->raw_hash = raw_hash;
  return(p);
}


/* -------------------------------- hash-table? -------------------------------- */
bool s7_is_hash_table(s7_pointer p)
{
  return(is_hash_table(p));
}

static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table"
  #define Q_is_hash_table pl_bt
  check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args);
}


/* -------------------------------- hash-table-entries -------------------------------- */
static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj"
  #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol)

  if (!is_hash_table(car(args)))
    method_or_bust(sc, car(args), sc->hash_table_entries_symbol, args, T_HASH_TABLE, 0);
  return(make_integer(sc, hash_table_entries(car(args))));
}

static s7_int c_hash_table_entries(s7_scheme *sc, s7_pointer p)
{
  if (!is_hash_table(p))
    int_method_or_bust(sc, p, sc->hash_table_entries_symbol, set_plist_1(sc, p), T_HASH_TABLE, 0);
  return(hash_table_entries(p));
}

PF_TO_IF(hash_table_entries, c_hash_table_entries)


/* ---------------- mappers ---------------- */
static unsigned int hash_float_location(s7_double x)
{
  int loc;
#if defined(__clang__)
  if ((is_inf(x)) || (is_NaN(x))) return(0);
#endif
  x = fabs(x);
  if (x < 100.0)
    loc = 1000.0 * x;     /* this means hash_table_float_epsilon only works if it is less than about .001 */
  else loc = x;

  if (loc < 0)
    return(0);
  return(loc);
}

/* built in hash loc tables for eq? eqv? equal? morally-equal? = string=? string-ci=? char=? char-ci=? (default=equal?) */

#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key)

static hash_map_t *eq_hash_map, *eqv_hash_map, *string_eq_hash_map, *number_eq_hash_map, *char_eq_hash_map, *closure_hash_map;
static hash_map_t *morally_equal_hash_map, *c_function_hash_map;
#if (!WITH_PURE_S7)
static hash_map_t *string_ci_eq_hash_map, *char_ci_eq_hash_map;
#endif

static unsigned int hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key)     {return(type(key));}
static unsigned int hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key)     {return((unsigned int)(s7_int_abs(integer(key))));}
static unsigned int hash_map_char(s7_scheme *sc, s7_pointer table, s7_pointer key)    {return(character(key));}
static unsigned int hash_map_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)   {return((unsigned int)denominator(key));} /* overflow possible as elsewhere */
static unsigned int hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(hash_float_location(real_part(key)));}
static unsigned int hash_map_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key)  {return(symbol_hmap(key));}
static unsigned int hash_map_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key)  {return(symbol_hmap(syntax_symbol(key)));}

#if WITH_GMP
static unsigned int hash_map_big_int(s7_scheme *sc, s7_pointer table, s7_pointer key)     
{
  return((unsigned int)(big_integer_to_s7_int(big_integer(key))));
}

static unsigned int hash_map_big_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)   
{
  return((unsigned int)(big_integer_to_s7_int(mpq_denref(big_ratio(key)))));
}

static unsigned int hash_map_big_real(s7_scheme *sc, s7_pointer table, s7_pointer key)    
{
  return((unsigned int)mpfr_get_d(big_real(key), GMP_RNDN));
}

static unsigned int hash_map_big_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) 
{
  return((unsigned int)mpfr_get_d(mpc_realref(big_complex(key)), GMP_RNDN));
}
#endif

static unsigned int hash_map_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (string_hash(key) == 0)
    string_hash(key) = raw_string_hash((const unsigned char *)string_value(key), string_length(key));
  return(string_hash(key));
}

#if (!WITH_PURE_S7)
static unsigned int hash_map_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(upper_character(key));}

static unsigned int hash_map_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  int len;
  len = string_length(key);
  if (len == 0) return(0);
  return(len + (uppers[(int)(string_value(key)[0])] << 4));
}
#endif

static unsigned int hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  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
   */
}

static unsigned int hash_map_real_eq(s7_scheme *sc, s7_pointer table, s7_pointer x)
{
  if (real(x) < 0.0)
    return((unsigned int)(s7_round(-real(x))));
  return((unsigned int)s7_round(real(x)));
}

static unsigned int hash_map_ratio_eq(s7_scheme *sc, s7_pointer table, s7_pointer y)
{
  s7_double x;
  x = fraction(y);
  if (x < 0.0)
    return((unsigned int)s7_round(-x));
  return((unsigned int)s7_round(x));
}

static unsigned int hash_map_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* hash-tables are equal if key/values match independent of table size and entry order.
   * if not using morally-equal?, hash_table_checker|mapper must also be the same.
   * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself.
   */
  return(hash_table_entries(key));
}

static unsigned int hash_map_int_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (vector_length(key) == 0)
    return(0);
  if (vector_length(key) == 1)
    return((unsigned int)(s7_int_abs(int_vector_element(key, 0))));
  return((unsigned int)(vector_length(key) + s7_int_abs(int_vector_element(key, 0)) + s7_int_abs(int_vector_element(key, 1))));
}

static unsigned int hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (vector_length(key) == 0)
    return(0);
  if (vector_length(key) == 1)
    return(hash_float_location(float_vector_element(key, 0)));
  return((unsigned int)(vector_length(key) + hash_float_location(float_vector_element(key, 0)) + hash_float_location(float_vector_element(key, 1))));
}

static unsigned int hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if ((vector_length(key) == 0) ||
      (is_sequence(vector_element(key, 0))))
    return(vector_length(key));
  if ((vector_length(key) == 1) ||
      (is_sequence(vector_element(key, 1))))
    return(hash_loc(sc, table, vector_element(key, 0)));
  return(vector_length(key) + hash_loc(sc, table, vector_element(key, 0)) + hash_loc(sc, table, vector_element(key, 1)));
}

static unsigned int hash_map_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  int x;
  x = heap_location(key);
  if (x < 0) return(-x);
  return(x);
}

static unsigned int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_pointer f, old_e, args, body;

  f = hash_table_procedures_mapper(table);
  old_e = sc->envir;
  args = closure_args(f);
  body = closure_body(f);
  new_frame_with_slot(sc, closure_let(f), sc->envir, (is_symbol(car(args))) ? car(args) : caar(args), key);
  push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
  if (is_pair(cdr(body)))
    push_stack_no_args(sc, OP_BEGIN1, cdr(body));
  sc->code = car(body);
  eval(sc, OP_EVAL);
  sc->envir = old_e;
  return(integer(sc->value));
}

static unsigned int hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  s7_function f;
  f = c_function_call(hash_table_procedures_mapper(table));
  set_car(sc->t1_1, key);
  return(integer(f(sc, sc->t1_1)));
}

static unsigned int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing
   *   (length (inlet 'a 1 'a 2)) = 2
   * but this counts as just one entry from equal?'s point of view, so if more than one entry, we have a problem.
   *   (equal? (inlet 'a 1) (inlet 'a 3 'a 2 'a 1)) = #t
   * also currently equal? follows outlet, but that is ridiculous here, so in this case hash equal?
   *   is not the same as equal?  Surely anyone using lets as keys wants eq?
   */
  s7_pointer slot;
  int slots;

  if ((key == sc->rootlet) ||
      (!is_slot(let_slots(key))))
    return(0);
  slot = let_slots(key);
  if (!is_slot(next_slot(slot)))
    {
      if (is_sequence(slot_value(slot))) /* avoid loop if cycles */
	return(symbol_hmap(slot_symbol(slot)));
      return(symbol_hmap(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot)));
    }
  slots = 0;
  for (; is_slot(slot); slot = next_slot(slot))
    if (!is_matched_symbol(slot_symbol(slot)))
      {
	set_match_symbol(slot_symbol(slot));
	slots++;
      }
  for (slot = let_slots(key); is_slot(slot); slot = next_slot(slot))
    clear_match_symbol(slot_symbol(slot));

  if (slots == 1)
    {
      slot = let_slots(key);
      if (is_sequence(slot_value(slot))) /* avoid loop if cycles */
	return(symbol_hmap(slot_symbol(slot)));
      return(symbol_hmap(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot)));
    }
  
  return(slots);
}

static unsigned int hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location,
   *   so at least we need to take cadr into account if possible.  Better would combine the list_length(max 5 == safe_strlen5?) call
   *   with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs.
   */
  s7_pointer p1;
  unsigned int loc = 0;

  if (!is_sequence(car(key)))
    loc = hash_loc(sc, table, car(key)) + 1;
  else 
    {
      if ((is_pair(car(key))) &&
	  (!is_sequence(caar(key))))
	loc = hash_loc(sc, table, caar(key)) + 1;
    }
  p1 = cdr(key);
  if (is_pair(p1))
    {
      if (!is_sequence(car(p1)))
	loc += hash_loc(sc, table, car(p1)) + 1;
      else
	{
	  if ((is_pair(car(p1))) &&
	      (!is_sequence(caar(p1))))
	    loc += hash_loc(sc, table, caar(p1)) + 1;
	}
    }
  return(loc);
}


/* ---------------- checkers ---------------- */
static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(NULL);
}


static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_integer(key))
    {
      s7_int keyval;
      hash_entry_t *x;
      unsigned int loc, hash_len;

      hash_len = hash_table_mask(table);
      keyval = integer(key);
      if (keyval < 0)
	loc = (unsigned int)((-keyval) & hash_len);
      else loc = (unsigned int)(keyval & hash_len); 
      /* I think this assumes hash_map_int is using s7_int_abs (and high order bits are ignored) */

      for (x = hash_table_element(table, loc); x; x = x->next)
	if (integer(x->key) == keyval)
	  return(x);
    }
  return(NULL);
}


static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_string(key))
    {
      hash_entry_t *x;
      unsigned int hash_len, key_len;
      unsigned long long int hash;
      const char *key_str;

      key_len = string_length(key);
      key_str = string_value(key);

      hash_len = hash_table_mask(table);
      if (string_hash(key) == 0)
	string_hash(key) = raw_string_hash((const unsigned char *)string_value(key), string_length(key));
      hash = string_hash(key);

      if (key_len <= 8)
	{
	  for (x = hash_table_element(table, hash & hash_len); x; x = x->next)
	    if ((hash == string_hash(x->key)) &&
		(key_len == string_length(x->key)))
	      return(x);
	}
      else
	{
	  for (x = hash_table_element(table, hash & hash_len); x; x = x->next)
	    if ((hash == string_hash(x->key)) &&
		(key_len == string_length(x->key)) &&        /* these are scheme strings, so we can't assume 0=end of string */
		(strings_are_equal_with_length(key_str, string_value(x->key), key_len)))
	      return(x);
	}
    }
  return(NULL);
}

#if (!WITH_PURE_S7)
static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_string(key))
    {
      hash_entry_t *x;
      unsigned int hash, hash_len;

      hash_len = hash_table_mask(table);
      hash = hash_map_ci_string(sc, table, key);

      for (x = hash_table_element(table, hash & hash_len); x; x = x->next)
	if (scheme_strequal_ci(key, x->key))
	  return(x);
    }
  return(NULL);
}

static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (s7_is_character(key))
    {
      hash_entry_t *x;
      unsigned int hash_len, loc;

      hash_len = hash_table_mask(table);
      loc = hash_loc(sc, table, key) & hash_len;

      for (x = hash_table_element(table, loc); x; x = x->next)
	if (upper_character(key) == upper_character(x->key))
	  return(x);
    }
  return(NULL);
}
#endif

static hash_entry_t *hash_float_1(s7_scheme *sc, s7_pointer table, unsigned int loc, s7_double keyval)
{
  hash_entry_t *x;
  bool look_for_nan;
  look_for_nan = is_NaN(keyval);

  for (x = hash_table_element(table, loc); x; x = x->next)
    {
      if (is_t_real(x->key)) /* we're possibly called from hash_equal, so keys might not be T_REAL */
	{
	  s7_double val;
	  val = real(x->key);
	  if (look_for_nan)
	    {
	      if (is_NaN(val))
		return(x);
	    }
	  else
	    {
	      if ((val == keyval) ||   /* inf case */
		  (fabs(val - keyval) < sc->hash_table_float_epsilon))
		return(x);
	    }
	}
    }
  return(NULL);
}


static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* give the equality check some room. also inf == inf and nan == nan
   */
  if (type(key) == T_REAL)
    {
      s7_double keyval;
      unsigned int hash_len, loc;
      
      hash_len = hash_table_mask(table);
      keyval = real(key);
      loc = hash_float_location(keyval) & hash_len;
      
      return(hash_float_1(sc, table, loc, keyval));
    }
  return(NULL);
}


static hash_entry_t *hash_complex_1(s7_scheme *sc, s7_pointer table, unsigned int loc, s7_pointer key)
{
  hash_entry_t *x;
  for (x = hash_table_element(table, loc); x; x = x->next)
    if ((is_t_complex(x->key)) &&
	(s7_is_morally_equal(sc, x->key, key)))
      return(x);
  return(NULL);
}


static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(hash_float_1(sc, table, hash_loc(sc, table, key) & hash_table_mask(table), real(key)));
}


static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return(hash_complex_1(sc, table, hash_loc(sc, table, key) & hash_table_mask(table), key));
}


static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int loc;
  loc = hash_loc(sc, table, key) & hash_table_mask(table);
  for (x = hash_table_element(table, loc); x; x = x->next)
    if ((is_syntax(x->key)) &&
	(syntax_symbol(x->key) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */
      return(x);
  return(NULL);
}


static hash_entry_t *hash_equal_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int loc;
  loc = hash_loc(sc, table, key) & hash_table_mask(table);
  for (x = hash_table_element(table, loc); x; x = x->next)
    if (x->key == key)
      return(x);
  return(NULL);
}


static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int loc;
  loc = hash_loc(sc, table, key) & hash_table_mask(table);

  /* 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.
   */
  /* hope for an easy case... */

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (x->key == key)
      return(x);

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (s7_is_equal(sc, x->key, key))
      return(x);
  return(NULL);
}


static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key);
static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key);
static hash_entry_t *(*morally_equal_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key);

static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  return((*(equal_hash_checks[type(key)]))(sc, table, key));
}

static hash_entry_t *hash_morally_equal(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int loc;
  loc = hash_loc(sc, table, key) & hash_table_mask(table);

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (x->key == key)
      return(x);

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (s7_is_morally_equal(sc, x->key, key))
      return(x);
  return(NULL);
}

static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int hash_len, loc;
  s7_function f;

  f = c_function_call(hash_table_procedures_checker(table));
  hash_len = hash_table_mask(table);
  loc = hash_loc(sc, table, key) & hash_len;
  
  set_car(sc->t2_1, key);
  for (x = hash_table_element(table, loc); x; x = x->next)
    {
      set_car(sc->t2_2, x->key);
      if (is_true(sc, f(sc, sc->t2_1)))
	return(x);
    }
  return(NULL);
}


static hash_entry_t *hash_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  /* explicit eq? as hash equality func or (for example) symbols as keys */
  hash_entry_t *x;
  unsigned int hash_len, loc;

  hash_len = hash_table_mask(table);
  loc = hash_loc(sc, table, key) & hash_len;

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (key == x->key)
      return(x);

  return(NULL);
}

static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int hash_len, loc;

  hash_len = hash_table_mask(table);
  loc = hash_loc(sc, table, key) & hash_len;

  for (x = hash_table_element(table, loc); x; x = x->next)
    if (s7_is_eqv(key, x->key))
      return(x);

  return(NULL);
}


static hash_entry_t *hash_number(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_number(key))
    {
      hash_entry_t *x;
      unsigned int hash_len, loc;

      hash_len = hash_table_mask(table);
      loc = hash_loc(sc, table, key) & hash_len;

#if (!WITH_GMP)
      for (x = hash_table_element(table, loc); x; x = x->next)
	if ((is_number(x->key)) &&
	    (is_true(sc, c_equal_2_1(sc, key, x->key))))
	  return(x);
#else
      for (x = hash_table_element(table, loc); x; x = x->next)
	if ((is_number(x->key)) &&
	    (is_true(sc, big_equal(sc, set_plist_2(sc, key, x->key)))))
	  return(x);
#endif
    }
  return(NULL);
}

static hash_entry_t *hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (is_symbol(key))
    {
      hash_entry_t *x;
      for (x = hash_table_element(table, symbol_hmap(key) & hash_table_mask(table)); x; x = x->next)
	if (key == x->key)
	  return(x);
    }
  return(NULL);
}


static hash_entry_t *hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  if (s7_is_character(key))
    return(hash_eq(sc, table, key));
  return(NULL);
}

static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  unsigned int hash_len, loc;
  s7_pointer f, args, body, old_e;

  f = hash_table_procedures_checker(table);
  hash_len = hash_table_mask(table);
  loc = hash_loc(sc, table, key) & hash_len;

  old_e = sc->envir;
  args = closure_args(f);    /* in lambda* case, car/cadr(args) can be lists */
  body = closure_body(f);
  new_frame_with_two_slots(sc, closure_let(f), sc->envir,
			   (is_symbol(car(args))) ? car(args) : caar(args), key,
			   (is_symbol(cadr(args))) ? cadr(args) : caadr(args), sc->F);

  for (x = hash_table_element(table, loc); x; x = x->next)
    {
      slot_set_value(next_slot(let_slots(sc->envir)), x->key);
      push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
      if (is_pair(cdr(body)))
	push_stack_no_args(sc, OP_BEGIN1, cdr(body));
      sc->code = car(body);
      eval(sc, OP_EVAL);
      if (is_true(sc, sc->value))
	{
	  sc->envir = old_e;
	  return(x);
	}
    }
  sc->envir = old_e;
  return(NULL);
}


static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer key, hash_entry_t *p)
{
  hash_entry_t *x;
  unsigned int hash_len, loc;

  hash_len = hash_table_mask(table);
#if DEBUGGING
  if (p->raw_hash != hash_loc(sc, table, key)) 
    fprintf(stderr, "%s[%d]: %s raw: %u, loc: %u\n", __func__, __LINE__, DISPLAY(key), p->raw_hash, hash_loc(sc, table, key));
#endif
  loc = p->raw_hash & hash_len;


  x = hash_table_element(table, loc);
  if (x == p)
    hash_table_element(table, loc) = x->next;
  else
    {
      hash_entry_t *y;
      for (y = x, x = x->next; x; y = x, x = x->next)
	if (x == p)
	  {
	    y->next = x->next;
	    break;
	  }
    }
  hash_table_entries(table)--;
  if ((hash_table_entries(table) == 0) &&
      (!hash_table_checker_locked(table)))
    hash_table_checker(table) = hash_empty;
  x->next = hash_free_list;
  hash_free_list = x;
  return(sc->F);
}

/* -------------------------------- make-hash-table -------------------------------- */

s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size)
{
  s7_pointer table;
  hash_entry_t **els;
  /* size is rounded up to the next power of 2 */

  if ((size == 0) ||                     /* already 2^n ? */
      ((size & (size - 1)) != 0))
    {
      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++;
    }

  els = (hash_entry_t **)calloc(size, sizeof(hash_entry_t *));
  if (!els) return(s7_error(sc, make_symbol(sc, "out-of-memory"), set_elist_1(sc, make_string_wrapper(sc, "make-hash-table allocation failed!"))));

  new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE);
  hash_table_mask(table) = size - 1;
  hash_table_elements(table) = els;
  hash_table_checker(table) = hash_empty;
  hash_table_mapper(table) = default_hash_map;
  hash_table_entries(table) = 0;
  hash_table_set_procedures(table, sc->nil);
  add_hash_table(sc, table);

  return(table);
}

static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args);
static s7_pointer g_is_morally_equal(s7_scheme *sc, s7_pointer args);

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) returns a new hash table"
  #define Q_make_hash_table s7_make_signature(sc, 3, sc->is_hash_table_symbol, sc->is_integer_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_pair_symbol))

  s7_int size;
  size = sc->default_hash_table_length;

  if (is_not_null(args))
    {
      s7_pointer p;
      p = car(args);
      if (!s7_is_integer(p))
	{
	  s7_pointer p1;
	  if (!s7_is_integer(p1 = check_values(sc, p, args)))
	    method_or_bust(sc, p, sc->make_hash_table_symbol, args, T_INTEGER, 1);
	  p = p1;
	}
      size = s7_integer(p);
      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_symbol, p, make_string_wrapper(sc, "should be a positive integer")));
      if (size > sc->max_vector_length)
	return(simple_out_of_range(sc, sc->make_hash_table_symbol, p, its_too_large_string));

      if (is_not_null(cdr(args)))
	{
	  s7_pointer ht, proc;
	  proc = cadr(args);

	  if (is_c_function(proc))
	    {
	      if (!s7_is_aritable(sc, proc, 2))
		return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, an_eq_func_string));

	      ht = s7_make_hash_table(sc, size);
	      if (c_function_call(proc) == g_is_equal)
		return(ht);
	      if (c_function_call(proc) == g_is_eq)
		{
		  hash_table_checker(ht) = hash_eq;
		  hash_table_mapper(ht) = eq_hash_map;
		}
	      else
		{
		  if (c_function_call(proc) == g_strings_are_equal)
		    {
		      hash_table_checker(ht) = hash_string; 
		      hash_table_mapper(ht) = string_eq_hash_map;
		    }
		  else
		    {
#if (!WITH_PURE_S7)
		      if (c_function_call(proc) == g_strings_are_ci_equal)
			{
			  hash_table_checker(ht) = hash_ci_string; 
			  hash_table_mapper(ht) = string_ci_eq_hash_map;
			}
		      else
			{
			  if (c_function_call(proc) == g_chars_are_ci_equal)
			    {
			      hash_table_checker(ht) = hash_ci_char; 
			      hash_table_mapper(ht) = char_ci_eq_hash_map;
			    }
			  else	
			    {
#endif
			      if (c_function_call(proc) == g_chars_are_equal)
				{
				  hash_table_checker(ht) = hash_char; 
				  hash_table_mapper(ht) = char_eq_hash_map;
				}
			      else
				{
#if (!WITH_GMP)
				  if (c_function_call(proc) == g_equal)
#else
				    if ((c_function_call(proc) == g_equal) ||
					(c_function_call(proc) == big_equal))
#endif
				      {
					hash_table_checker(ht) = hash_number; 
					hash_table_mapper(ht) = number_eq_hash_map;
				      }
				    else
				      {				  
					if (c_function_call(proc) == g_is_eqv)
					  {
					    hash_table_checker(ht) = hash_eqv; 
					    hash_table_mapper(ht) = eqv_hash_map;
					  }
					else
					  {
					    if (c_function_call(proc) == g_is_morally_equal)
					      {
						hash_table_checker(ht) = hash_morally_equal;
						hash_table_mapper(ht) = morally_equal_hash_map;
					      }
					    else return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, 
										      make_string_wrapper(sc, "a hash function")));
				      }}}}}
#if (!WITH_PURE_S7)
		    }}
#endif
	      return(ht);
	    }
	  /* proc not c_function */
	  else
	    {
	      if (is_pair(proc))
		{
		  s7_pointer checker, mapper;
		  checker = car(proc);
		  mapper = cdr(proc);

		  if (((is_any_c_function(checker)) || (is_any_closure(checker))) &&
		      ((is_any_c_function(mapper)) || (is_any_closure(mapper))) &&
		      (s7_is_aritable(sc, checker, 2)) &&
		      (s7_is_aritable(sc, mapper, 1)))
		    {
		      s7_pointer sig;
		      ht = s7_make_hash_table(sc, size);
		      if (is_any_c_function(checker))
			{
			  sig = c_function_signature(checker);
			  if ((sig) &&
			      (is_pair(sig)) &&
			      (car(sig) != sc->is_boolean_symbol))
			    return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, 
								 make_string_wrapper(sc, "equality function should return a boolean")));
			  hash_table_checker(ht) = hash_c_function;
			}
		      else hash_table_checker(ht) = hash_closure;
		      if (is_any_c_function(mapper))
			{
			  sig = c_function_signature(mapper);
			  if ((sig) &&
			      (is_pair(sig)) &&
			      (car(sig) != sc->is_integer_symbol))
			    return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, 
								 make_string_wrapper(sc, "mapping function should return an integer")));
			  hash_table_mapper(ht) = c_function_hash_map;
			}
		      else hash_table_mapper(ht) = closure_hash_map;
		      hash_table_set_procedures(ht, proc);
		      return(ht);
		    }
		}
	      return(wrong_type_argument_with_type(sc, sc->make_hash_table_symbol, 3, proc, 
						   make_string_wrapper(sc, "a cons of two functions")));
	    }
	}
    }
  return(s7_make_hash_table(sc, size));
}


void init_hash_maps(void)
{
  int i;
  
  default_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  eqv_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  string_eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  number_eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  char_eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
#if (!WITH_PURE_S7)
  string_ci_eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  char_ci_eq_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
#endif
  closure_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  c_function_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));
  morally_equal_hash_map = (hash_map_t *)malloc(NUM_TYPES * sizeof(hash_map_t));

  for (i = 0; i < NUM_TYPES; i++) 
    {
      default_hash_map[i] = hash_map_nil;
      string_eq_hash_map[i] = hash_map_nil;
      char_eq_hash_map[i] = hash_map_nil;
#if (!WITH_PURE_S7)
      string_ci_eq_hash_map[i] = hash_map_nil;
      char_ci_eq_hash_map[i] = hash_map_nil;
#endif
      number_eq_hash_map[i] = hash_map_nil;
      closure_hash_map[i] = hash_map_closure;
      c_function_hash_map[i] = hash_map_c_function;
      eq_hash_map[i] = hash_map_eq;
      eqv_hash_map[i] = hash_map_eq;

      equal_hash_checks[i] = hash_equal_any;
      morally_equal_hash_checks[i] = hash_equal_any;
      default_hash_checks[i] = hash_equal;
    }
  default_hash_map[T_INTEGER] =      hash_map_int;
  default_hash_map[T_RATIO] =        hash_map_ratio;
  default_hash_map[T_REAL] =         hash_map_real;
  default_hash_map[T_COMPLEX] =      hash_map_complex;
  default_hash_map[T_CHARACTER] =    hash_map_char;
  default_hash_map[T_SYMBOL] =       hash_map_symbol;
  default_hash_map[T_SYNTAX] =       hash_map_syntax;
  default_hash_map[T_STRING] =       hash_map_string;
  default_hash_map[T_HASH_TABLE] =   hash_map_hash_table;
  default_hash_map[T_VECTOR] =       hash_map_vector;
  default_hash_map[T_INT_VECTOR] =   hash_map_int_vector;
  default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector;
  default_hash_map[T_LET] =          hash_map_let;
  default_hash_map[T_PAIR] =         hash_map_pair;
#if WITH_GMP
  default_hash_map[T_BIG_INTEGER] =  hash_map_big_int;
  default_hash_map[T_BIG_RATIO] =    hash_map_big_ratio;
  default_hash_map[T_BIG_REAL] =     hash_map_big_real;
  default_hash_map[T_BIG_COMPLEX] =  hash_map_big_complex;
#endif
  
  for (i = 0; i < NUM_TYPES; i++) morally_equal_hash_map[i] = default_hash_map[i];

  string_eq_hash_map[T_STRING] =     hash_map_string;
  char_eq_hash_map[T_CHARACTER] =    hash_map_char;
#if (!WITH_PURE_S7)
  string_ci_eq_hash_map[T_STRING] =  hash_map_ci_string;
  char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char;
#endif

  number_eq_hash_map[T_INTEGER] =    hash_map_int;
  number_eq_hash_map[T_RATIO] =      hash_map_ratio_eq;
  number_eq_hash_map[T_REAL] =       hash_map_real_eq;
  number_eq_hash_map[T_COMPLEX] =    hash_map_complex;
#if (WITH_GMP)
  number_eq_hash_map[T_BIG_INTEGER] =  hash_map_big_int;
  number_eq_hash_map[T_BIG_RATIO] =    hash_map_big_ratio;
  number_eq_hash_map[T_BIG_REAL] =     hash_map_big_real;
  number_eq_hash_map[T_BIG_COMPLEX] =  hash_map_big_complex;
#endif

  eqv_hash_map[T_INTEGER] =          hash_map_int;
  eqv_hash_map[T_RATIO] =            hash_map_ratio_eq;
  eqv_hash_map[T_REAL] =             hash_map_real_eq;
  eqv_hash_map[T_COMPLEX] =          hash_map_complex;

  morally_equal_hash_map[T_INTEGER] = hash_map_int;
  morally_equal_hash_map[T_RATIO] =   hash_map_ratio_eq;
  morally_equal_hash_map[T_REAL] =    hash_map_real_eq;
  morally_equal_hash_map[T_COMPLEX] = hash_map_complex;

  equal_hash_checks[T_REAL] =             hash_equal_real;
  equal_hash_checks[T_COMPLEX] =          hash_equal_complex;
  equal_hash_checks[T_SYNTAX] =           hash_equal_syntax;
  equal_hash_checks[T_SYMBOL] =           hash_equal_eq;
  equal_hash_checks[T_CHARACTER] =        hash_equal_eq;

  default_hash_checks[T_STRING] =    hash_string;
  default_hash_checks[T_INTEGER] =   hash_int;
  default_hash_checks[T_REAL] =      hash_float;
  default_hash_checks[T_SYMBOL] =    hash_symbol;
  default_hash_checks[T_CHARACTER] = hash_char;
}


static unsigned int resize_hash_table(s7_scheme *sc, s7_pointer table)
{
  /* resize the table */
  unsigned int hash_len, loc;
  int i, old_size, new_size;
  hash_entry_t **new_els, **old_els;
  
  old_size = hash_table_mask(table) + 1;
  new_size = old_size * 4;
  hash_len = new_size - 1;
  new_els = (hash_entry_t **)calloc(new_size, sizeof(hash_entry_t *));
  old_els = hash_table_elements(table);
  
  for (i = 0; i < old_size; i++)
    {
      hash_entry_t *x, *n;
      for (x = old_els[i]; x; x = n)
	{
	  n = x->next;
	  loc = x->raw_hash & hash_len;
	  x->next = new_els[loc];
	  new_els[loc] = x;
	}
    }
  hash_table_elements(table) = new_els;
  free(old_els);
  hash_table_mask(table) = new_size - 1;
  return(hash_len);
}


/* -------------------------------- hash-table-ref -------------------------------- */

s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key)
{
  hash_entry_t *x;
  x = (*hash_table_checker(table))(sc, table, key);
  if (x) return(x->value);
  return(sc->F);
}


static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
  #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T)

  s7_pointer table;
  table = car(args);
  if (!is_hash_table(table))
    method_or_bust(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, 1);
  /*
    (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 table;
  hash_entry_t *x;

  table = car(args);
  if (!is_hash_table(table))
    method_or_bust(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, 1);

  x = (*hash_table_checker(table))(sc, table, cadr(args));
  if (x) return(x->value);
  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 table;
  hash_entry_t *x;

  table = find_symbol_checked(sc, car(args));
  if (!is_hash_table(table))
    method_or_bust(sc, table, sc->hash_table_ref_symbol, list_2(sc, table, find_symbol_checked(sc, cadr(args))), T_HASH_TABLE, 1);
  
  x = (*hash_table_checker(table))(sc, table, find_symbol_checked(sc, cadr(args)));
  if (x) return(x->value);
  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 y, table;
  hash_entry_t *x;

  table = find_symbol_checked(sc, car(args));
  if (!is_hash_table(table))
    method_or_bust(sc, table, sc->hash_table_ref_symbol, list_2(sc, table, car(find_symbol_checked(sc, cadadr(args)))), T_HASH_TABLE, 1);

  y = find_symbol_checked(sc, cadadr(args));
  if (!is_pair(y))
    return(simple_wrong_type_argument(sc, sc->car_symbol, y, T_PAIR));

  x = (*hash_table_checker(table))(sc, table, car(y));
  if (x) return(x->value);
  return(sc->F);
}

static s7_pointer hash_table_ref_pf_a(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x, y;
  f = (s7_pf_t)(**p); (*p)++;
  x = f(sc, p);
  f = (s7_pf_t)(**p); (*p)++;
  y = f(sc, p);
  return(s7_hash_table_ref(sc, x, y));
}

static s7_pointer hash_table_ref_pf_i(s7_scheme *sc, s7_pointer **p) /* i=implicit I think */
{
  s7_pf_t f;
  s7_pointer x, y;
  x = slot_value(**p); (*p)++;
  f = (s7_pf_t)(**p); (*p)++;
  y = f(sc, p);
  return(s7_hash_table_ref(sc, x, y));
}

static s7_pointer hash_table_ref_pf_s(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t f;
  s7_pointer x, y;
  hash_entry_t *h;
  x = (**p); (*p)++;
  f = (s7_pf_t)(**p); (*p)++;
  y = f(sc, p);
  h = (*hash_table_checker(x))(sc, x, y);
  if (h) return(h->value);
  return(sc->F);
}

static s7_pointer hash_table_ref_pf_ps(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer x, y;
  x = (**p); (*p) += 2;
  y = slot_value(**p); (*p)++;
  return(s7_hash_table_ref(sc, x, y));
}

static s7_pointer hash_table_ref_pf_r(s7_scheme *sc, s7_pointer **p)
{
  s7_rf_t f;
  s7_pointer x;
  s7_double y;
  int hash_len;
  hash_entry_t *h;
  x = (**p); (*p)++;
  f = (s7_rf_t)(**p); (*p)++;
  y = f(sc, p);
  hash_len = hash_table_mask(x);
  h = hash_float_1(sc, x, hash_float_location(y) & hash_len, y);
  if (h) return(h->value);
  return(sc->F);
}

static s7_pf_t hash_table_ref_pf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_null(cdddr(expr))))
    {
      s7_pointer a1;
      a1 = cadr(expr);
      if (is_symbol(a1))
	{
	  s7_pointer table;
	  table = s7_slot(sc, a1);
	  if ((is_slot(table)) && (!is_stepper(table)) && (is_hash_table(slot_value(table))))
	    {
	      ptr_int loc;
	      s7_pointer a2;
	      a2 = caddr(expr);
	      s7_xf_store(sc, slot_value(table));
	      loc = rc_loc(sc);
	      if (s7_arg_to_pf(sc, a2))
		return((is_symbol(a2)) ? hash_table_ref_pf_ps : hash_table_ref_pf_s);
	      sc->cur_rf->cur = rc_go(sc, loc);
	      if (s7_arg_to_gf(sc, a2))
		return((is_symbol(a2)) ? hash_table_ref_pf_ps : hash_table_ref_pf_s);
	      sc->cur_rf->cur = rc_go(sc, loc);
	      if (s7_arg_to_rf(sc, a2))
		return(hash_table_ref_pf_r);
	      return(NULL);
	    }
	}
      if ((s7_arg_to_pf(sc, cadr(expr))) &&
	  (s7_arg_to_pf(sc, caddr(expr))))
	return(hash_table_ref_pf_a);
    }
  return(NULL); 
}


/* -------------------------------- hash-table-set! -------------------------------- */

static void hash_table_set_function(s7_pointer table, int typ)
{
  if ((hash_table_checker(table) != hash_equal) &&
      (hash_table_checker(table) != default_hash_checks[typ]))
    {
      if (hash_table_checker(table) == hash_empty)
	hash_table_checker(table) = default_hash_checks[typ];
      else hash_table_checker(table) = hash_equal;
    }
}


s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
{
  hash_entry_t *x;
  x = (*hash_table_checker(table))(sc, table, key);

  if (x)
    {
      if (value == sc->F)
	return(remove_from_hash_table(sc, table, key, x));
      x->value = _NFre(value);
    }
  else 
    {
      unsigned int hash_len, raw_hash, loc;
      hash_entry_t *p;
      if (value == sc->F) return(sc->F);
      
      if (!hash_table_checker_locked(table))
	hash_table_set_function(table, type(key));

      hash_len = hash_table_mask(table);
      if (hash_table_entries(table) > hash_len)
	hash_len = resize_hash_table(sc, table);
      raw_hash = hash_loc(sc, table, key);

      if (!hash_free_list)
	{
	  int i;
	  hash_free_list = (hash_entry_t *)malloc(16 * sizeof(hash_entry_t));
	  for (p = hash_free_list, i = 0; i < 15; i++) {p->next = p + 1; p++;}
	  p->next = NULL;
	}

      p = hash_free_list;
      hash_free_list = p->next;
      p->key = key;
      p->value = _NFre(value);
      p->raw_hash = raw_hash;

      loc = raw_hash & hash_len;
      p->next = hash_table_element(table, loc);
      hash_table_element(table, loc) = p;
      hash_table_entries(table)++;
    }
  return(value);
}

static s7_pointer hash_table_set_pf_sxs(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer key, table, value;
  s7_pf_t pf;
  table = slot_value(**p); (*p)++;
  pf = (s7_pf_t)(**p); (*p)++;
  key = pf(sc, p);
  value = slot_value(**p); (*p)++;
  return(s7_hash_table_set(sc, table, key, value));
}

static s7_pointer hash_table_set_pf_sxx(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer key, table, value;
  s7_pf_t pf;
  table = slot_value(**p); (*p)++;
  pf = (s7_pf_t)(**p); (*p)++;
  key = pf(sc, p);
  pf = (s7_pf_t)(**p); (*p)++;
  value = pf(sc, p);
  return(s7_hash_table_set(sc, table, key, value));
}

static s7_pointer hash_table_set_pf_sss(s7_scheme *sc, s7_pointer **p)
{
  s7_pointer key, table, value;
  table = slot_value(**p); (*p)++;
  key = slot_value(**p); (*p)++;
  value = slot_value(**p); (*p)++;
  return(s7_hash_table_set(sc, table, key, value));
}

static s7_pointer hash_table_set_pf_ssx(s7_scheme *sc, s7_pointer **p)
{
  s7_pf_t pf;
  s7_pointer key, table, value;
  table = slot_value(**p); (*p)++;
  key = slot_value(**p); (*p)++;
  pf = (s7_pf_t)(**p); (*p)++;
  value = pf(sc, p);
  return(s7_hash_table_set(sc, table, key, value));
}

static s7_pf_t hash_table_set_pf(s7_scheme *sc, s7_pointer expr)
{
  if ((is_pair(cdr(expr))) && (is_pair(cddr(expr))) && (is_pair(cdddr(expr))) && (is_null(cddddr(expr))))
    {
      s7_pointer a1, a2, a3;
      a1 = cadr(expr);
      a2 = caddr(expr);
      a3 = cadddr(expr);
      if (is_symbol(a1))
	{
	  xf_t *rc;
	  a1 = s7_slot(sc, a1);
	  if ((!is_slot(a1)) || (!is_hash_table(slot_value(a1))) || (is_stepper(a1))) return(NULL);
	  xf_init(3);
	  xf_store(a1);
	  if (is_symbol(a2))
	    {
	      a2 = s7_slot(sc, a2);
	      if (!is_slot(a2)) return(NULL);
	      xf_store(a2);
	    }
	  else
	    {
	      ptr_int loc;
	      loc = rc_loc(sc);
	      if (!s7_arg_to_pf(sc, a2))
		{
		  sc->cur_rf->cur = rc_go(sc, loc);
		  if (!s7_arg_to_gf(sc, a2)) return(NULL);
		}
	    }
	  if (is_symbol(a3))
	    {
	      a3 = s7_slot(sc, a3);
	      if (!is_slot(a3)) return(NULL);
	      xf_store(a3);
	      return((is_slot(a2)) ? hash_table_set_pf_sss : hash_table_set_pf_sxs);
	    }
	  else
	    {
	      ptr_int loc;
	      loc = rc_loc(sc);
	      if (!s7_arg_to_pf(sc, a3))
		{
		  sc->cur_rf->cur = rc_go(sc, loc);
		  if (!s7_arg_to_gf(sc, a3)) return(NULL);
		}
	      return((is_slot(a2)) ? hash_table_set_pf_ssx : hash_table_set_pf_sxx);
	    }
	}
    }
  return(NULL);
}


static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value"
  #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T)

  s7_pointer table;
  table = car(args);
  if (!is_hash_table(table))
    method_or_bust(sc, table, sc->hash_table_set_symbol, args,T_HASH_TABLE, 1);
  return(s7_hash_table_set(sc, table, cadr(args), caddr(args)));
}


/* -------------------------------- hash-table -------------------------------- */
static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table "(hash-table ...) returns a hash-table containing the 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."
  #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->is_list_symbol)

  int len;
  s7_pointer x, ht;

  /* this accepts repeated keys: (hash-table '(a . 1) '(a . 1)) */
  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_symbol, position_of(x, args), car(x), T_PAIR));

  ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length);
  if (len > 0)
    {
      int ht_loc;
      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);
}


/* -------------------------------- hash-table* -------------------------------- */
static s7_pointer g_hash_table_star(s7_scheme *sc, s7_pointer args)
{
  #define H_hash_table_star "(hash-table* ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \
That is, (hash-table* 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled."
  #define Q_hash_table_star s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T)

  int len;
  s7_pointer ht;

  len = safe_list_length(sc, args);
  if (len & 1) 
    return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, make_string_wrapper(sc, "hash-table* got an odd number of arguments: ~S"), args)));
  len /= 2;

  ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length);
  if (len > 0)
    {
      int ht_loc;
      s7_pointer x, y;
      ht_loc = s7_gc_protect(sc, ht); /* hash_table_set can cons, so we need to protect this */

      for (x = args, y = cdr(args); is_pair(y); x = cddr(x), y = cddr(y))
	s7_hash_table_set(sc, ht, car(x), car(y));

      s7_gc_unprotect_at(sc, ht_loc);
    }
  return(ht);
}


static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, unsigned int start, unsigned int end)
{
  unsigned int i, old_len, new_len, count = 0;
  hash_entry_t **old_lists, **new_lists;
  hash_entry_t *x, *p;

  old_len = hash_table_mask(old_hash) + 1;
  new_len = hash_table_mask(new_hash);
  old_lists = hash_table_elements(old_hash);
  new_lists = hash_table_elements(new_hash);
  
  if (hash_table_entries(new_hash) == 0)
    {
      hash_table_checker(new_hash) = hash_table_checker(old_hash);
      for (i = 0; i < old_len; i++)
	for (x = old_lists[i]; x; x = x->next)
	  {
	    if (count >= end)
	      {
		hash_table_entries(new_hash) = end - start;
		return(new_hash);
	      }
	    if (count >= start)
	      {
		unsigned int loc;
		loc = x->raw_hash & new_len;
		p = make_hash_entry(x->key, x->value, x->raw_hash);
		p->next = new_lists[loc];
		new_lists[loc] = p;
	      }
	    count++;
	  }
      hash_table_entries(new_hash) = count - start;
      return(new_hash);
    }
      
  /* this can't be optimized much because we have to look for key matches */
  for (i = 0; i < old_len; i++)
    for (x = old_lists[i]; x; x = x->next)
      {
	if (count >= end)
	  return(new_hash);
	if (count >= start)
	  {
	    hash_entry_t *y;
	    y = (*hash_table_checker(new_hash))(sc, new_hash, x->key);
	    if (y)
	      y->value = x->value;
	    else
	      {
		unsigned int loc;
		loc = x->raw_hash & new_len;
		p = make_hash_entry(x->key, x->value, x->raw_hash);
		p->next = new_lists[loc];
		new_lists[loc] = p;
		hash_table_entries(new_hash)++;
		if (!hash_table_checker_locked(new_hash))
		  hash_table_set_function(new_hash, type(x->key));
	      }
	  }
	count++;
      }
  return(new_hash);
}

s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args)
{
  s7_pointer val, table;
  table = car(args);
  val = cadr(args);
  if (hash_table_entries(table) > 0)
    {
      int len;
      hash_entry_t **entries;
      entries = hash_table_elements(table);
      len = hash_table_mask(table) + 1;
      /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */
      if (val == sc->F)
	{
	  hash_entry_t **hp, **hn;
	  hash_entry_t *p;
	  hp = entries;
	  hn = (hash_entry_t **)(hp + len);
	  for (; hp < hn; hp++)
	    {
	      if (*hp)
		{
		  p = *hp;
		  while (p->next) p = p->next;
		  p->next = hash_free_list;
		  hash_free_list = *hp;
		}
	      hp++;
	      if (*hp)
		{
		  p = *hp;
		  while (p->next) p = p->next;
		  p->next = hash_free_list;
		  hash_free_list = *hp;
		}
	    }
	  memset(entries, 0, len * sizeof(hash_entry_t *));
	  if (!hash_table_checker_locked(table))
	    hash_table_checker(table) = hash_empty;
	  hash_table_entries(table) = 0;
	}
      else
	{
	  int i;
	  hash_entry_t *x;
	  for (i = 0; i < len; i++)
	    for (x = entries[i]; x; x = x->next)
	      x->value = val;
	  /* keys haven't changed, so no need to mess with hash_table_checker */
	}
    }
  return(val);
}


static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash)
{
  int i, len;
  s7_pointer new_hash;
  hash_entry_t **old_lists;
  int gc_loc;

  len = hash_table_mask(old_hash) + 1;
  new_hash = s7_make_hash_table(sc, len);
  gc_loc = s7_gc_protect(sc, new_hash);

  /* I don't think the original hash functions can make any sense in general, so ignore them */
  old_lists = hash_table_elements(old_hash);
  for (i = 0; i < len; i++)
    {
      hash_entry_t *x;
      for (x = old_lists[i]; x; x = x->next)
	s7_hash_table_set(sc, new_hash, x->value, x->key);
    }
  s7_gc_unprotect_at(sc, gc_loc);
  return(new_hash);
}



/* -------------------------------- functions -------------------------------- */

bool s7_is_function(s7_pointer p)
{
  return(is_c_function(p));
}


static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(f);
}

static void s7_function_set_class(s7_pointer f, s7_pointer base_f)
{
  c_function_class(f) = c_function_class(base_f);
  c_function_set_base(f, base_f);
}

static int c_functions = 0;

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;
  unsigned int ftype = T_C_FUNCTION;
  s7_pointer x;

  x = alloc_pointer();
  unheap(x);

  ptr = (c_proc_t *)malloc(sizeof(c_proc_t));
  c_functions++;
  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;
  /* f is _TApp but needs cast */
  c_function_set_base(x, x);
  c_function_set_setter(x, sc->F);
  c_function_name(x) = name;   /* (procedure-name proc) => (format #f "~A" proc) */
  c_function_name_length(x) = safe_strlen(name);
  if (doc)
    c_function_documentation(x) = make_permanent_string(doc);
  else c_function_documentation(x) = NULL;
  c_function_signature(x) = sc->F;

  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) = ++sc->f_class;
  c_function_chooser(x) = fallback_chooser;
  c_function_rp(x) = NULL;
  c_function_ip(x) = NULL;
  c_function_pp(x) = NULL;
  c_function_gp(x) = NULL;

  return(x);
}

s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function f, 
				 int required_args, int optional_args, bool rest_arg, const char *doc)
{
  s7_pointer p;
  p = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
  typeflag(p) |= T_SAFE_PROCEDURE;  /* not set_type(p, type(p) ...) because that accidentally clears the T_PROCEDURE bit */
  return(p);
}


s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, 
				  int required_args, int optional_args, bool rest_arg, const char *doc, s7_pointer signature)
{
  s7_pointer func;
  func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
  typeflag(func) |= T_SAFE_PROCEDURE;
  if (signature) c_function_signature(func) = signature;
  return(func);
}


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"
  #define Q_is_procedure pl_bt
  s7_pointer x;
  int typ;

  x = car(args);
  if ((!is_procedure(x)) || (is_c_object(x)))
    {
      check_method(sc, x, sc->is_procedure_symbol, 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_STAR) ||
		      (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_set_setter(s7_name_to_value(sc, getter), s7_name_to_value(sc, setter));
}


s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p)
{
  if (has_closure_let(p))
    return(closure_body(p));
  return(sc->nil);
}


s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p)
{
  if (has_closure_let(p))
    return(closure_let(p));
  return(sc->nil);
}


s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p)
{
  if (has_closure_let(p))
    return(closure_args(p));
  return(sc->nil);
}


static s7_pointer c_procedure_source(s7_scheme *sc, s7_pointer p)
{
  /* make it look like a scheme-level lambda */
  if (is_symbol(p))
    {
      p = s7_symbol_value(sc, p);
      if (p == sc->undefined)
	return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "procedure-source arg, '~S, is unbound"), p)));
    }

  if ((is_c_function(p)) || (is_c_macro(p)))
    return(sc->nil);

  check_method(sc, p, sc->procedure_source_symbol, list_1(sc, p));
  if (has_closure_let(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)) || 
					     (is_macro_star(p)) || 
					     (is_bacro_star(p))) ? sc->lambda_star_symbol : sc->lambda_symbol, 
					closure_args(p)), body));
    }

  if (!is_procedure(p))
    return(simple_wrong_type_argument_with_type(sc, sc->procedure_source_symbol, p, make_string_wrapper(sc, "a procedure or a macro")));
  return(sc->nil);
}

static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_source "(procedure-source func) tries to return the definition of func"
  #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_procedure_symbol)
  return(c_procedure_source(sc, car(args)));
}

PF_TO_PF(procedure_source, c_procedure_source)


s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p)
{
  if (has_closure_let(p))
    return(closure_let(p));
  return(sc->rootlet);
}


static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p, e;
  #define H_funclet "(funclet func) tries to return an object's environment"
  #define Q_funclet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_procedure_symbol)

  /* 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_symbol, set_elist_2(sc, make_string_wrapper(sc, "funclet arg, '~S, is unbound"), car(args)))); /* not p here */
    }
  check_method(sc, p, sc->funclet_symbol, args);

  if (!is_procedure_or_macro(p))
    return(simple_wrong_type_argument_with_type(sc, sc->funclet_symbol, p, make_string_wrapper(sc, "a procedure or a macro")));

  e = find_let(sc, p);
  if ((is_null(e)) &&
      (!is_c_object(p)))
    return(sc->rootlet);

  return(e);
}


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)
{
  /* returns (string->symbol name), not the c_proc_t func */
  s7_pointer func, sym;
  func = s7_make_safe_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_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
				    int required_args, int optional_args, bool rest_arg, 
				    const char *doc, s7_pointer signature)
{
  /* returns (string->symbol name), not the c_proc_t func */
  s7_pointer func, sym;
  func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature);
  sym = make_symbol(sc, name);
  s7_define(sc, sc->nil, sym, func);
  return(sym);
}


s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
					   int required_args, int optional_args, bool rest_arg, 
					   const char *doc, s7_pointer signature)
{
  /* returns (string->symbol name), not the c_proc_t func */
  s7_pointer func, sym;
  func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
  if (signature) c_function_signature(func) = signature;
  sym = make_symbol(sc, name);
  s7_define(sc, sc->nil, sym, func);
  return(sym);
}


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


bool s7_is_macro(s7_scheme *sc, s7_pointer x)
{
  return(is_any_macro(x));
}


static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args)
{
  #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro"
  #define Q_is_macro pl_bt
  check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args);
}


static void define_function_star_1(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, bool safe)
{
  s7_pointer func, sym, local_args, p;
  char *internal_arglist;
  int i, len, n_args, gc_loc;
  s7_pointer *names, *defaults;

  len = safe_strlen(arglist) + 8;
  tmpbuf_malloc(internal_arglist, len);
  snprintf(internal_arglist, len, "'(%s)", arglist);
  local_args = s7_eval_c_string(sc, internal_arglist);
  gc_loc = s7_gc_protect(sc, local_args);
  tmpbuf_free(internal_arglist, len);
  n_args = safe_list_length(sc, local_args);  /* currently rest arg not supported, and we don't notice :allow-other-keys etc */

  func = s7_make_function(sc, name, fnc, 0, n_args, false, doc);
  if (safe)
    set_type(func, T_C_FUNCTION_STAR | T_PROCEDURE | T_SAFE_PROCEDURE);
  else set_type(func, T_C_FUNCTION_STAR | T_PROCEDURE);

  c_function_call_args(func) = make_list(sc, n_args, sc->F);
  s7_remove_from_heap(sc, c_function_call_args(func));

  sym = make_symbol(sc, name);
  s7_define(sc, sc->nil, sym, func);

  names = (s7_pointer *)malloc(n_args * sizeof(s7_pointer));
  c_function_arg_names(func) = names;
  defaults = (s7_pointer *)malloc(n_args * sizeof(s7_pointer));
  c_function_arg_defaults(func) = defaults;
  set_simple_defaults(func);

  for (p = local_args, i = 0; i < n_args; p = cdr(p), i++)
    {
      s7_pointer arg;
      arg = car(p);
      if (is_pair(arg))
	{
	  names[i] = s7_make_keyword(sc, symbol_name(car(arg)));
	  defaults[i] = cadr(arg);
	  s7_remove_from_heap(sc, cadr(arg));
	  if ((is_symbol(defaults[i])) ||
	      (is_pair(defaults[i])))
	    {
	      clear_simple_defaults(func);
	      mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star;
	    }
	}
      else
	{
	  names[i] = s7_make_keyword(sc, symbol_name(arg));
	  defaults[i] = sc->F;
	}
    }
  s7_gc_unprotect_at(sc, gc_loc);
}

void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
{
  define_function_star_1(sc, name, fnc, arglist, doc, false);
}

void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
{
  define_function_star_1(sc, name, fnc, arglist, doc, true);
}


static s7_pointer set_c_function_call_args(s7_scheme *sc)
{
  int i, j, n_args;
  s7_pointer arg, par, call_args, func;
  s7_pointer *df;

  func = sc->code;
  n_args = c_function_all_args(func);
  call_args = c_function_call_args(func);

  df = c_function_arg_defaults(func);
  for (i = 0, par = call_args; is_pair(par); i++, par = cdr(par))
    {
      clear_checked(par);
      set_car(par, df[i]);
    }

  df = c_function_arg_names(func);
  for (i = 0, arg = sc->args, par = call_args; (i < n_args) && (is_pair(arg)); i++, arg = cdr(arg), par = cdr(par))
    {
      if (!is_keyword(car(arg)))
	{
	  if (is_checked(par))
	    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(par), sc->args)));
	  set_checked(par);
	  set_car(par, car(arg));
	}
      else
	{
	  s7_pointer p;
	  for (j = 0, p = call_args; j < n_args; j++, p = cdr(p))
	    if (df[j] == car(arg))
	      break;
	  if (j == n_args)
	    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "~A: not a parameter name?"), car(arg))));
	  if (is_checked(p))
	    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, make_string_wrapper(sc, "parameter set twice, ~S in ~S"), car(p), sc->args)));
	  set_checked(p);
	  arg = cdr(arg);
	  set_car(p, car(arg));
	}
    }

  if (!is_null(arg))
    return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, func, sc->args)));

  if (!has_simple_defaults(func))
    for (i = 0, par = call_args; i < n_args; i++, par = cdr(par))
      if (!is_checked(par))
	{
	  if (is_symbol(car(par)))
	    set_car(par, find_symbol_checked(sc, car(par)));
	  else
	    {
	      if (is_pair(car(par)))
		set_car(par, s7_eval(sc, car(par), sc->nil));
	    }
	}
  return(call_args);
}


/* -------------------------------- procedure-documentation -------------------------------- */
static s7_pointer get_doc(s7_scheme *sc, s7_pointer x)
{
  check_closure_for(sc, x, sc->documentation_symbol);
  return(NULL);
}

const char *s7_procedure_documentation(s7_scheme *sc, s7_pointer x)
{
  s7_pointer val;
  if (is_symbol(x))
    {
      if ((symbol_has_help(x)) &&
	  (is_global(x)))
	return(symbol_help(x));
      x = s7_symbol_value(sc, x); /* this is needed by Snd */
    }

  if ((is_any_c_function(x)) ||
      (is_c_macro(x)))
    return((char *)c_function_documentation(x));

  val = get_doc(sc, x);
  if ((val) && (is_string(val)))
    return(string_value(val));

  return(NULL);
}

static s7_pointer c_procedure_documentation(s7_scheme *sc, s7_pointer p)
{
  if (is_symbol(p))
    {
      if ((symbol_has_help(p)) &&
	  (is_global(p)))
	return(s7_make_string(sc, symbol_help(p)));
      p = s7_symbol_value(sc, p);
    }

  check_method(sc, p, sc->procedure_documentation_symbol, list_1(sc, p));
  if ((!is_procedure(p)) &&
      (!s7_is_macro(sc, p)))
    return(simple_wrong_type_argument_with_type(sc, sc->procedure_documentation_symbol, p, a_procedure_string));

  return(s7_make_string(sc, s7_procedure_documentation(sc, p)));
}

static s7_pointer g_procedure_documentation(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_documentation "(procedure-documentation func) returns func's documentation string"
  #define Q_procedure_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_procedure_symbol)
  return(c_procedure_documentation(sc, car(args)));
}

PF_TO_PF(procedure_documentation, c_procedure_documentation)


/* -------------------------------- help -------------------------------- */
const char *s7_help(s7_scheme *sc, s7_pointer obj)
{
  if (is_syntax(obj))
    return(string_value(syntax_documentation(obj)));

  if (is_symbol(obj))
    {
      /* here look for name */
      if (s7_symbol_documentation(sc, obj))
	return(s7_symbol_documentation(sc, obj));
      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) */
  return(NULL);
}


static s7_pointer g_help(s7_scheme *sc, s7_pointer args)
{
  #define H_help "(help obj) returns obj's documentation"
  #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
  const char *doc;

  check_method(sc, car(args), sc->help_symbol, args);
  doc = s7_help(sc, car(args));
  if (!doc)
    return(sc->F);
  return(s7_make_string(sc, doc));
}

static s7_pointer c_help(s7_scheme *sc, s7_pointer x) {return(g_help(sc, set_plist_1(sc, x)));}
PF_TO_PF(help, c_help)


/* -------------------------------- procedure-signature -------------------------------- */
static s7_pointer get_signature(s7_scheme *sc, s7_pointer x)
{
  check_closure_for(sc, x, sc->signature_symbol);
  return(sc->F);
}

static s7_pointer s7_procedure_signature(s7_scheme *sc, s7_pointer x)
{
  if ((is_any_c_function(x)) ||
      (is_c_macro(x)))
    return((s7_pointer)c_function_signature(x));
  return(get_signature(sc, x));
}

static s7_pointer c_procedure_signature(s7_scheme *sc, s7_pointer p)
{
  if (is_symbol(p)) 
    {
      p = s7_symbol_value(sc, p);
      if (p == sc->undefined)
	return(sc->F);
    }
  check_method(sc, p, sc->procedure_signature_symbol, list_1(sc, p));
  
  if (!is_procedure(p))
    return(sc->F);
  return(s7_procedure_signature(sc, p));
}

static s7_pointer g_procedure_signature(s7_scheme *sc, s7_pointer args)
{
  #define H_procedure_signature "(procedure-signature func) returns func's signature"
  #define Q_procedure_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T)

  return(c_procedure_signature(sc, car(args)));
}

PF_TO_PF(procedure_signature, c_procedure_signature)


/* -------------------------------- new types (c_objects) -------------------------------- */

static void fallback_free(void *value) {}
static void fallback_mark(void *value) {}

static char *fallback_print(s7_scheme *sc, void *val)
{
  return(copy_string("#<unprintable object>"));
}

static char *fallback_print_readably(s7_scheme *sc, void *val)
{
  return(copy_string("#<unprint-readable object>"));
}

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)
{
  eval_error(sc, "attempt to set ~S?", obj);
}

static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj)
{
  return(sc->F);
}


bool s7_is_object(s7_pointer p)
{
  return(is_c_object(p));
}

static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args)
{
  #define H_is_c_object "(c-object? obj) returns the object's type tag if obj is a C object, otherwise #f"
  #define Q_is_c_object pl_bt

  s7_pointer p;
  p = car(args);
  if (is_c_object(p)) 
    return(make_integer(sc, c_object_type(p))); /* this is the object_types table index = tag */
  check_method(sc, p, sc->is_c_object_symbol, args);
  return(sc->F);
  /* <1> (*s7* 'c-types)
     ("<random-number-generator>")
     <2> (c-object? (random-state 123))
     0
  */
}


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 (*gc_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))
{
  int tag;
  tag = num_object_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);
  object_types[tag]->scheme_name = s7_make_permanent_string(name);

  object_types[tag]->free = (gc_free) ? gc_free : fallback_free;
  object_types[tag]->print = (print) ? print : fallback_print;
  object_types[tag]->equal = (equal) ? equal : fallback_equal;
  object_types[tag]->gc_mark = (gc_mark) ? gc_mark : fallback_mark;
  object_types[tag]->ref = (ref) ? ref : fallback_ref;
  object_types[tag]->set = (set) ? set : fallback_set;

  if (object_types[tag]->ref != fallback_ref)
    object_types[tag]->outer_type = (T_C_OBJECT | T_PROCEDURE | T_SAFE_PROCEDURE);
  else object_types[tag]->outer_type = T_C_OBJECT;

  object_types[tag]->length = fallback_length;
  object_types[tag]->copy = NULL;
  object_types[tag]->reverse = NULL;
  object_types[tag]->fill = NULL;
  object_types[tag]->print_readably = fallback_print_readably;

  object_types[tag]->ip = NULL;
  object_types[tag]->rp = NULL;
  object_types[tag]->set_ip = NULL;
  object_types[tag]->set_rp = NULL;

  return(tag);
}


int s7_new_type_x(s7_scheme *sc,
		  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 args),
		  s7_pointer (*reverse)(s7_scheme *sc, s7_pointer args),
		  s7_pointer (*fill)(s7_scheme *sc, s7_pointer args))
{
  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)
{
  return((c_object_type(a) == c_object_type(b)) &&
	 ((*(c_object_eql(a)))(c_object_value(a), c_object_value(b))));
}


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_print_readably(int type, char *(*printer)(s7_scheme *sc, void *val))
{
  object_types[type]->print_readably = printer;
}


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, object_types[type]->outer_type);

  /* 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_set_let(x, sc->nil);
  add_c_object(sc, x);
  return(x);
}


s7_pointer s7_object_let(s7_pointer obj)
{
  return(c_object_let(obj));
}


s7_pointer s7_object_set_let(s7_pointer obj, s7_pointer e)
{
  c_object_set_let(obj, e);
  return(e);
}


void s7_object_type_set_xf(int tag, s7_ip_t ip, s7_ip_t set_ip, s7_rp_t rp, s7_rp_t set_rp)
{
  object_types[tag]->ip = ip;
  object_types[tag]->rp = rp;
  object_types[tag]->set_ip = set_ip;
  object_types[tag]->set_rp = set_rp;
}

void s7_object_type_set_direct(int tag, 
			       s7_pointer (*dref)(s7_scheme *sc, s7_pointer obj, s7_int index), 
			       s7_pointer (*dset)(s7_scheme *sc, s7_pointer obj, s7_int index, s7_pointer val))
{
  object_types[tag]->direct_ref = dref;
  object_types[tag]->direct_set = dset;
}

static s7_pointer object_length(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_length(obj))
    return((*(c_object_length(obj)))(sc, obj));
  eval_error(sc, "attempt to get length of ~S?", obj);
}


static s7_int object_length_to_int(s7_scheme *sc, s7_pointer obj)
{
  if (c_object_length(obj))
    {
      s7_pointer res;
      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 args)
{
  s7_pointer obj;
  obj = car(args);
  check_method(sc, obj, sc->copy_symbol, args);
  if (c_object_copy(obj))
    return((*(c_object_copy(obj)))(sc, args));
  eval_error(sc, "attempt to copy ~S?", obj);
}




/* -------- dilambda -------- */

s7_pointer s7_dilambda(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 *)malloc(len * sizeof(char));
  snprintf(internal_set_name, len, "[set-%s]", name);

  get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation);
  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);
  c_function_set_setter(get_func, set_func);

  return(get_func);
}

s7_pointer s7_typed_dilambda(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_sig, s7_pointer set_sig)
{
  s7_pointer get_func, set_func;
  get_func = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation);
  set_func = c_function_setter(get_func);
  if (get_sig) c_function_signature(get_func) = get_sig;
  if (set_sig) c_function_signature(set_func) = set_sig;
  return(get_func);
}


bool s7_is_dilambda(s7_pointer obj)
{
  return(((is_c_function(obj)) &&
	  (is_c_function(c_function_setter(obj)))) ||
	 ((is_any_closure(obj)) &&
	  (is_procedure(closure_setter(obj)))));
}

static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args)
{
  #define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter."
  #define Q_is_dilambda pl_bt
  check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args);
}

static s7_pointer c_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter)
{
  switch (type(p))
    {
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      closure_set_setter(p, setter);
      break;

    case T_C_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
      c_function_set_setter(p, setter);
      if (is_any_closure(setter))
	add_setter(sc, p, setter);
      break;

    case T_C_FUNCTION_STAR:
      c_function_set_setter(p, setter);
      if (is_any_closure(setter))
	add_setter(sc, p, setter);
      break;

    case T_C_MACRO:
      if (is_any_closure(setter))
	add_setter(sc, p, setter);
      c_macro_set_setter(p, setter);
      break;
    }
  return(setter);
}

static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args)
{
  #define H_dilambda "(dilambda getter setter) sets getter's procedure-setter to be setter."
  #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol)
  s7_pointer getter, setter;

  getter = car(args);
  if (!is_any_procedure(getter))
    return(wrong_type_argument_with_type(sc, sc->dilambda_symbol, 1, getter, make_string_wrapper(sc, "a procedure or macro")));

  setter = cadr(args);
  if (!is_any_procedure(setter))
    return(wrong_type_argument_with_type(sc, sc->dilambda_symbol, 2, setter, make_string_wrapper(sc, "a procedure or macro")));
  
  c_set_setter(sc, getter, setter);
  return(getter);
}


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

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"
  #define Q_procedure_setter s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol)
  s7_pointer p;

  p = car(args);
  switch (type(p))
    {
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      return(closure_setter(p));

    case T_C_FUNCTION:
    case T_C_FUNCTION_STAR:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_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);

    case T_LET:
    case T_C_OBJECT:
      check_method(sc, p, s7_make_symbol(sc, "procedure-setter"), args);
      break;

    case T_ITERATOR:
      if (is_any_closure(iterator_sequence(p)))
	return(closure_setter(iterator_sequence(p)));
      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_any_procedure(p))
    return(s7_wrong_type_arg_error(sc, "set! procedure-setter procedure", 1, p, "a procedure"));

  setter = cadr(args);
  if ((setter != sc->F) &&
      (!is_any_procedure(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?
   */
  return(c_set_setter(sc, p, 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_dilambda(sc, name, get_fnc, req_args, opt_args, set_fnc, req_args + 1, opt_args, doc);
}


/* -------------------------------- arity -------------------------------- */

static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
{
  /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition
   */
  int len;

  if (is_symbol(x_args))                    /* any number of args is ok */
    return(s7_cons(sc, small_int(0), max_arity));

  if (closure_arity_unknown(x))
    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), max_arity));
  return(s7_cons(sc, s7_make_integer(sc, len), s7_make_integer(sc, len)));
}

static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args)
{
  if (closure_arity_unknown(x))
    {
      if (is_null(args))
	closure_arity(x) = 0;
      else
	{
	  if (allows_other_keys(args))
	    closure_arity(x) = -1;
	  else
	    {
	      s7_pointer p;
	      int i;
	      for (i = 0, p = args; is_pair(p); p = cdr(p))
		{
		  s7_pointer arg;
		  arg = car(p);
		  if (arg == sc->key_rest_symbol)
		    break;
		  i++;
		}
	      if (is_null(p))
		closure_arity(x) = i;
	      else closure_arity(x) = -1; /* see below */
	    }
	}
    }
}

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), max_arity));

  closure_star_arity_1(sc, x, x_args);

  if (closure_arity(x) == -1)
    return(s7_cons(sc, small_int(0), 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_unknown(x))
    {
      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
	{
	  if (i == 0)
	    return(-1);
	  closure_arity(x) = -i;
	}
    }
  return(closure_arity(x));
}


static int closure_star_arity_to_int(s7_scheme *sc, s7_pointer x)
{
  /* not lambda here */
  closure_star_arity_1(sc, x, closure_args(x));
  return(closure_arity(x));
}


s7_pointer s7_arity(s7_scheme *sc, s7_pointer x)
{
  switch (type(x))
    {
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_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_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION_STAR:
      return(s7_cons(sc, small_int(0), s7_make_integer(sc, c_function_all_args(x)))); /* should this be *2? */

    case T_MACRO:
    case T_BACRO:
    case T_CLOSURE:
      return(closure_arity_to_cons(sc, x, closure_args(x)));

    case T_MACRO_STAR:
    case T_BACRO_STAR:
    case T_CLOSURE_STAR:
      return(closure_star_arity_to_cons(sc, x, closure_args(x)));

    case T_C_MACRO:
      return(s7_cons(sc, s7_make_integer(sc, c_macro_required_args(x)), s7_make_integer(sc, c_macro_all_args(x))));

    case T_GOTO:
    case T_CONTINUATION:
      return(s7_cons(sc, small_int(0), max_arity));

    case T_STRING:
      if (string_length(x) == 0)
	return(sc->F);

    case T_LET:
      /* check_method(sc, x, sc->arity_symbol, args); */
      return(s7_cons(sc, small_int(1), small_int(1)));

    case T_C_OBJECT:
      /* check_method(sc, x, sc->arity_symbol, args); */
      if (is_procedure(x))
	return(s7_cons(sc, small_int(0), max_arity));
      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), max_arity));

    case T_ITERATOR:
      return(s7_cons(sc, small_int(0), small_int(0)));

    case T_SYNTAX:
      return(s7_cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x))));
    }
  return(sc->F);
}


static s7_pointer g_arity(s7_scheme *sc, s7_pointer args)
{
  #define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f."
  #define Q_arity pcl_t
  /* check_method(sc, p, sc->arity_symbol, args); */
  return(s7_arity(sc, car(args)));
}

PF_TO_PF(arity, s7_arity)


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 (args == 0)
    return(!is_pair(x_args));

  if (is_symbol(x_args))                    /* any number of args is ok */
    return(true);

  len = closure_arity(x);
  if (len == CLOSURE_ARITY_NOT_SET)
    {
      len = s7_list_length(sc, x_args);
      closure_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);

  closure_star_arity_1(sc, x, x_args);
  return((closure_arity(x) == -1) ||
	 (args <= closure_arity(x)));
}


bool s7_is_aritable(s7_scheme *sc, s7_pointer x, int args)
{
  switch (type(x))
    {
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
    case T_C_FUNCTION:
      return(((int)c_function_required_args(x) <= args) &&
	     ((int)c_function_all_args(x) >= args));

    case T_C_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION_STAR:
      return((int)c_function_all_args(x) >= args);

    case T_MACRO:
    case T_BACRO:
    case T_CLOSURE:
      return(closure_is_aritable(sc, x, closure_args(x), args));

    case T_MACRO_STAR:
    case T_BACRO_STAR:
    case T_CLOSURE_STAR:
      return(closure_star_is_aritable(sc, x, closure_args(x), args));

    case T_C_MACRO:
      return(((int)c_macro_required_args(x) <= args) &&
	     ((int)c_macro_all_args(x) >= args));

    case T_GOTO:
    case T_CONTINUATION:
      return(true);

    case T_STRING:
      return((args == 1) &&
	     (string_length(x) > 0)); /* ("" 0) -> error */

    case T_C_OBJECT:
      /* check_method(sc, x, sc->is_aritable_symbol, list_2(sc, x, s7_make_integer(sc, args))); -- see below */
      return(is_procedure(x)); /* i.e. is_applicable */

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return((args > 0) &&
	     (vector_length(x) > 0) &&   /* (#() 0) -> error */
	     ((unsigned int)args <= vector_rank(x)));

    case T_LET:
      /* check_method(sc, x, sc->is_aritable_symbol, list_2(sc, x, s7_make_integer(sc, args))); */
      /* this slows us down a lot */
    case T_HASH_TABLE:
    case T_PAIR:
      return(args == 1);

    case T_ITERATOR:
      return(args == 0);

    case T_SYNTAX:
      return((args >= syntax_min_args(x)) && ((args <= syntax_max_args(x)) || (syntax_max_args(x) == -1)));
    }
  return(false);
}

static s7_pointer g_is_aritable(s7_scheme *sc, s7_pointer args)
{
  #define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments."
  #define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol)

  s7_pointer n;
  s7_int num;

  n = cadr(args);
  if (!s7_is_integer(n)) /* remember gmp case! */
    method_or_bust(sc, n, sc->is_aritable_symbol, args, T_INTEGER, 2);

  num = s7_integer(n);
  if (num < 0)
    return(out_of_range(sc, sc->is_aritable_symbol, small_int(2), n, its_negative_string));
  if (num > MAX_ARITY) num = MAX_ARITY;

  return(make_boolean(sc, s7_is_aritable(sc, car(args), (int)num)));
}

static s7_pointer c_is_aritable(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, s7_is_aritable(sc, x, y)));}
PIF_TO_PF(is_aritable, c_is_aritable)


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_pointer arg2;
      arg2 = caddr(expr);
      if ((s7_is_integer(arg2)) &&
	  (s7_integer(arg2) < MAX_ARITY) &&
	  (s7_integer(arg2) >= 0))
	return(is_aritable_ic);
    }
  return(f);
}


/* -------- sequence? -------- */
static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args)
{
  #define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)"
  #define Q_is_sequence pl_bt
  check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, args);
}



/* -------------------------------- symbol-access ------------------------------------------------ */

static unsigned int protect_accessor(s7_scheme *sc, s7_pointer acc)
{
  unsigned int loc;
  if (sc->protected_accessors_size == sc->protected_accessors_loc)
    {
      int i, new_size, size;
      size = sc->protected_accessors_size;
      new_size = 2 * size;
      vector_elements(sc->protected_accessors) = (s7_pointer *)realloc(vector_elements(sc->protected_accessors), new_size * sizeof(s7_pointer));
      vector_length(sc->protected_accessors) = new_size;
      for (i = size; i < new_size; i++)
	vector_element(sc->protected_accessors, i) = sc->gc_nil;
      sc->protected_accessors_size = new_size;
    }
  loc = sc->protected_accessors_loc++;
  vector_element(sc->protected_accessors, loc) = acc;
  return(loc);
}

s7_pointer s7_symbol_access(s7_scheme *sc, s7_pointer sym)
{
  /* these refer to the rootlet */
  if ((is_slot(global_slot(sym))) &&
      (slot_has_accessor(global_slot(sym))))
    /* return(s7_gc_protected_at(sc, symbol_global_accessor_index(sym))); */ /* 26-Feb-16 */
    return(vector_element(sc->protected_accessors, symbol_global_accessor_index(sym)));

  return(sc->F);
}


s7_pointer s7_symbol_set_access(s7_scheme *sc, s7_pointer symbol, s7_pointer func)
{
  if (slot_has_accessor(global_slot(symbol)))
    {
      unsigned int index;
      index = symbol_global_accessor_index(symbol);
      if (is_immutable(vector_element(sc->protected_accessors, index)))
	return(func);
      vector_element(sc->protected_accessors, index) = func;
    }
  else
    {
      if (func != sc->F)
	{
	  slot_set_has_accessor(global_slot(symbol));
	  symbol_set_has_accessor(symbol);
	  symbol_global_accessor_index(symbol) = protect_accessor(sc, func);  
	}
    }
  slot_set_accessor(global_slot(symbol), func);
  return(func);
}

/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (symbol-access 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix))
 *    so set symbol-access before use!
 */

static s7_pointer g_symbol_access(s7_scheme *sc, s7_pointer args)
{
  #define H_symbol_access "(symbol-access sym (env (curlet))) is the function called when the symbol is set!."
  #define Q_symbol_access s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
  s7_pointer sym, p, e;

  sym = car(args);
  if (!is_symbol(sym))
    method_or_bust(sc, sym, sc->symbol_access_symbol, args, T_SYMBOL, 0);
  if (is_keyword(sym))
    return(sc->F);

  if (is_pair(cdr(args)))
    {
      e = cadr(args);
      if (!is_let(e))
	return(wrong_type_argument(sc, sc->symbol_access_symbol, 2, e, T_LET));
    }
  else e = sc->envir;

  if ((e == sc->rootlet) ||
      (e == sc->nil))
    return(s7_symbol_access(sc, sym));

  if (is_null(cdr(args)))
    p = find_symbol(sc, sym);
  else p = find_local_symbol(sc, sym, e);

  if ((is_slot(p)) &&
      (slot_has_accessor(p)))
    return(slot_accessor(p));

  return(sc->F);
}


static s7_pointer g_symbol_set_access(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym, func, e, p;
  /* perhaps: check func */

  sym = car(args);
  if (!is_symbol(sym))                 /* no check method because no method name? */
    return(s7_wrong_type_arg_error(sc, "set! symbol-access", 1, sym, "a symbol"));
  if (is_keyword(sym))
    return(s7_wrong_type_arg_error(sc, "set! symbol-access", 1, sym, "a normal symbol (a keyword can't be set)"));

  /* (set! (symbol-access sym) f) or (set! (symbol-access sym env) f) */
  if (is_pair(cddr(args)))
    {
      e = cadr(args);
      if (!is_let(e))
	return(s7_wrong_type_arg_error(sc, "set! symbol-access", 2, e, "a let"));
      func = caddr(args);
    }
  else
    {
      e = sc->envir;
      func = cadr(args);
    }

  if ((!is_procedure_or_macro(func)) &&
      (func != sc->F))
    return(s7_wrong_type_arg_error(sc, "set! symbol-access", 3, func, "a function or #f"));

  if ((e == sc->rootlet) ||
      (e == sc->nil))
    {
      if (!is_slot(global_slot(sym)))
	return(sc->F);
      return(s7_symbol_set_access(sc, sym, func));
    }

  if (is_null(cddr(args)))
    p = find_symbol(sc, sym);
  else p = find_local_symbol(sc, sym, e);

  if (is_slot(p))
    {
      slot_set_accessor(p, func);
      if (func != sc->F)
	{
	  slot_set_has_accessor(p);
	  symbol_set_has_accessor(sym);
	}
      return(func);
    }
  return(sc->F);
}


static s7_pointer bind_accessed_symbol(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value)
{
  /* this refers to (define (sym ...)) and friends -- define cases
   *    see call_accessor for the set! cases
   */
  s7_pointer func;

  func = g_symbol_access(sc, set_plist_2(sc, symbol, sc->envir));
  if (is_procedure_or_macro(func))
    {
      if (is_c_function(func))
	{
	  s7_pointer old_value;
	  old_value = new_value;
	  set_car(sc->t2_1, symbol);
	  set_car(sc->t2_2, new_value);
	  new_value = c_function_call(func)(sc, sc->t2_1);
	  if (new_value == sc->error_symbol)
	    return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(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); /* this means the accessor in set! needs to goto APPLY to get the new value */
	}
    }
  return(new_value);
}



/* -------------------------------- hooks -------------------------------- */

s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook)
{
  return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook)));
}


s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions)
{
  if (s7_is_list(sc, functions))
    s7_let_set(sc, closure_let(hook), sc->body_symbol, 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? */
}


static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args)
{
  #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2"
  #define Q_is_eq pcl_bt
  return(make_boolean(sc, ((car(args) == cadr(args)) ||
			   ((is_unspecified(car(args))) && (is_unspecified(cadr(args)))))));
  /* (eq? (apply apply apply values '(())) #<unspecified>) should return #t
   */
}


bool s7_is_eqv(s7_pointer a, s7_pointer b)
{
  if ((a == b) && (!is_number(a)))
    return(true);

#if WITH_GMP
  if ((is_big_number(a)) || (is_big_number(b)))
    return(big_numbers_are_eqv(a, b));
#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 (is_unspecified(a))                             /* types are the same so we know b is also unspecified */
    return(true);

  return(false);
}


static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args)
{
  #define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2"
  #define Q_is_eqv pcl_bt
  return(make_boolean(sc, s7_is_eqv(car(args), cadr(args))));
}



static bool floats_are_morally_equal(s7_scheme *sc, s7_double x, s7_double y)
{
  if (x == y) return(true);

  if ((is_NaN(x)) || (is_NaN(y)))
    return((is_NaN(x)) && (is_NaN(y)));

  return(fabs(x - y) <= sc->morally_equal_float_epsilon);
}

static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return(x == y);
}

static bool symbol_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  if (x == y) return(true);
  if (!is_symbol(y)) return(false);                   /* (morally-equal? ''(1) '(1)) */
  if (!morally) return(false);
  return((is_slot(global_slot(x))) &&                 /* the optimizer can replace the original symbol with its own */
	 (is_syntax(slot_value(global_slot(x)))) &&
	 (is_slot(global_slot(y))) &&
	 (is_syntax(slot_value(global_slot(y)))) &&
	 (syntax_symbol(slot_value(global_slot(x))) == syntax_symbol(slot_value(global_slot(y)))));
}

static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return(is_unspecified(y));
}

static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return((s7_is_c_pointer(y)) && (raw_pointer(x) == raw_pointer(y)));
}

static bool string_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return((is_string(y)) && (scheme_strings_are_equal(x, y)));
}

static bool syntax_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y)));
}

static bool c_object_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return((is_c_object(y)) && (objects_are_equal(sc, x, y)));
}

static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  if (x == y) return(true);
  if ((!morally) || (type(x) != type(y)) || (port_type(x) != port_type(y))) return(false);
  if ((port_is_closed(x)) && (port_is_closed(y))) return(true);
  return((is_string_port(x)) &&
	 (port_position(x) == port_position(y)) &&
	 (port_data_size(x) == port_data_size(y)) &&
	 (local_strncmp((const char *)port_data(x), (const char *)port_data(y), (is_input_port(x)) ? port_data_size(x) : port_position(x))));
}

static int equal_ref(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) ? 1 : 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
    {
      if (ref_y != 0)
	add_shared_ref(ci, x, ref_y);
      else add_equal_ref(ci, x, y);
    }
  return(-1);
}

static bool s7_is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally);

static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  hash_entry_t **lists;
  int i, len;
  shared_info *nci = ci;

  if (x == y)
    return(true);
  if (!is_hash_table(y))
    {
      if ((morally) && (has_methods(y)))
	{
	  s7_pointer equal_func;
	  equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
	  if (equal_func != sc->undefined)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
	}
      return(false);
    }
  if (ci)
    {
      i = equal_ref(sc, x, y, ci);
      if (i == 0) return(false);
      if (i == 1) return(true);
    }

  if (hash_table_entries(x) != hash_table_entries(y))
    return(false);
  if (hash_table_entries(x) == 0)
    return(true);
  if ((!morally) &&
      ((hash_table_checker_locked(x)) || (hash_table_checker_locked(y))))
    {
      if (hash_table_checker(x) != hash_table_checker(y))
	return(false);
      if (hash_table_mapper(x) != hash_table_mapper(y))
	return(false);
    }

  len = hash_table_mask(x) + 1;
  lists = hash_table_elements(x);
  if (!nci) nci = new_shared_info(sc);

  for (i = 0; i < len; i++)
    {
      hash_entry_t *p;
      for (p = lists[i]; p; p = p->next)
	{
	  hash_entry_t *y_val;
	  y_val = (*hash_table_checker(y))(sc, y, p->key);

	  if ((!y_val) ||
	      (!s7_is_equal_1(sc, p->value, y_val->value, nci, morally)))
	    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 slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, bool morally, shared_info *nci)
{
  s7_pointer ey, py;
  for (ey = y; (is_let(ey)) && (ey != sc->rootlet); ey = outlet(ey))
    for (py = let_slots(ey); is_slot(py); py = next_slot(py))
      if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */
	return(s7_is_equal_1(sc, slot_value(px), slot_value(py), nci, morally));
  return(false);
}

static bool let_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  /* x == y if all unshadowed vars match, leaving aside the rootlet, so that for any local variable,
   *   we get the same value in either x or y.
   */

  s7_pointer ex, ey, px, py;
  shared_info *nci = ci;
  int x_len, y_len;

  if (x == y)
    return(true);

  if (morally)
    {
      s7_pointer equal_func;
      if (has_methods(x))
	{
	  equal_func = find_method(sc, find_let(sc, x), sc->is_morally_equal_symbol);
	  if (equal_func != sc->undefined)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
	}
      if (has_methods(y))
	{
	  equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
	  if (equal_func != sc->undefined)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
	}
    }
  if (!is_let(y))
    return(false);
  if ((x == sc->rootlet) || (y == sc->rootlet))
    return(false);

  if (ci)
    {
      int i;
      i = equal_ref(sc, x, y, ci);
      if (i == 0) return(false);
      if (i == 1) return(true);
    }

  clear_syms_in_list(sc);
  for (x_len = 0, ex = x; (is_let(ex)) && (ex != sc->rootlet); ex = outlet(ex))
    for (px = let_slots(ex); is_slot(px); px = next_slot(px))
      if (symbol_tag(slot_symbol(px)) != sc->syms_tag)
	{
	  add_sym_to_list(sc, slot_symbol(px));
	  x_len++;
	}

  for (ey = y; (is_let(ey)) && (ey != sc->rootlet); ey = outlet(ey))
    for (py = let_slots(ey); is_slot(py); py = next_slot(py))
      if (symbol_tag(slot_symbol(py)) != sc->syms_tag)       /* symbol in y, not in x */
	return(false);

  for (y_len = 0, ey = y; (is_let(ey)) && (ey != sc->rootlet); ey = outlet(ey))
    for (py = let_slots(ey); is_slot(py); py = next_slot(py))
      if (symbol_tag(slot_symbol(py)) != 0)
	{
	  y_len ++;
	  symbol_set_tag(slot_symbol(py), 0);
	}
  
  if (x_len != y_len)                                        /* symbol in x, not in y */
    return(false);

  if (!nci) nci = new_shared_info(sc);

  for (ex = x; (is_let(ex)) && (ex != sc->rootlet); ex = outlet(ex))
    for (px = let_slots(ex); is_slot(px); px = next_slot(px))
      if (symbol_tag(slot_symbol(px)) == 0)                /* unshadowed */
	{
	  symbol_set_tag(slot_symbol(px), sc->syms_tag);      /* values don't match */
	  if (!slots_match(sc, px, y, morally, nci))
	    return(false);
	}
  return(true);
}

static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  if (x == y)
    return(true);
  if (type(x) != type(y))
    return(false);
  if ((has_methods(x)) &&
      (has_methods(y)))
    {
      s7_pointer equal_func;
      equal_func = find_method(sc, closure_let(x), (morally) ? sc->is_morally_equal_symbol : sc->is_equal_symbol);
      if (equal_func != sc->undefined)
	return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, x, y))));
    }
  /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y))
   *   because locally defined constant functions on the second pass find the outer let.
   */
  return((morally) &&
	 (s7_is_equal_1(sc, closure_args(x), closure_args(y), ci, morally)) &&
	 (s7_is_equal_1(sc, closure_body(x), closure_body(y), ci, morally)));
}

static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  int i;
  s7_pointer px, py;
  shared_info *nci = ci;

  if (x == y)
    return(true);
  if (!is_pair(y))
    {
      if ((morally) && (has_methods(y)))
	{
	  s7_pointer equal_func;
	  equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
	  if (equal_func != sc->undefined)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
	}
      return(false);
    }
  if (ci)
    {
      i = equal_ref(sc, x, y, ci);
      if (i == 0) return(false);
      if (i == 1) return(true);
    }
  else nci = new_shared_info(sc);

  if (!s7_is_equal_1(sc, car(x), car(y), nci, morally)) return(false);
  for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py))
    {
      if (!s7_is_equal_1(sc, car(px), car(py), nci, morally)) return(false);
      i = equal_ref(sc, px, py, nci);
      if (i == 0) return(false);
      if (i == 1) return(true);
    }
  return(s7_is_equal_1(sc, px, py, nci, morally));
}

static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  int x_dims, y_dims;

  if (vector_has_dimensional_info(x))
    x_dims = vector_ndims(x);
  else x_dims = 1;
  if (vector_has_dimensional_info(y))
    y_dims = vector_ndims(y);
  else y_dims = 1;

  if (x_dims != y_dims)
    return(false);

  if (x_dims > 1)
    {
      int j;
      for (j = 0; j < x_dims; j++)
	if (vector_dimension(x, j) != vector_dimension(y, j))
	  return(false);
    }
  return(true);
}


static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  s7_int i, len;
  shared_info *nci = ci;

  if (x == y)
    return(true);
  if (!s7_is_vector(y))
    {
      if ((morally) && (has_methods(y)))
	{
	  s7_pointer equal_func;
	  equal_func = find_method(sc, find_let(sc, y), sc->is_morally_equal_symbol);
	  if (equal_func != sc->undefined)
	    return(s7_boolean(sc, s7_apply_function(sc, equal_func, list_2(sc, y, x))));
	}
      return(false);
    }
  len = vector_length(x);
  if (len != vector_length(y)) return(false);
  if (len == 0)
    {
      if (morally) return(true);
      if (!vector_rank_match(sc, x, y))
	return(false);
      return(true);
    }
  if (!vector_rank_match(sc, x, y))
    return(false);

  if (type(x) != type(y))
    {
      if (!morally) return(false);
      /* (morally-equal? (make-int-vector 3 0) (make-vector 3 0)) -> #t
       * (morally-equal? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t
       */
      for (i = 0; i < len; i++)
	if (!s7_is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL, true)) /* this could be greatly optimized */
	  return(false);
      return(true);
    }

  if (is_float_vector(x))
    {
      if (!morally)
	{
	  for (i = 0; i < len; i++)
	    {
	      s7_double z;
	      z = float_vector_element(x, i);
	      if ((is_NaN(z)) ||
		  (z != float_vector_element(y, i)))
		return(false);
	    }
	  return(true);
	}
      else
	{
	  s7_double *arr1, *arr2;
	  s7_double fudge;
	  arr1 = float_vector_elements(x);
	  arr2 = float_vector_elements(y);
	  fudge = sc->morally_equal_float_epsilon;
	  if (fudge == 0.0)
	    {
	      for (i = 0; i < len; i++)
		if ((arr1[i] != arr2[i]) &&
		    ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i]))))
		  return(false);
	    }
	  else
	    {
	      for (i = 0; i < len; i++)
		{
		  s7_double diff;
		  diff = fabs(arr1[i] - arr2[i]);
		  if (diff > fudge) return(false);
		  if ((is_NaN(diff)) &&
		      ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i]))))
		    return(false);
		}
	    }
	  return(true);
	}
    }

  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 (ci)
    {
      i = equal_ref(sc, x, y, ci);
      if (i == 0) return(false);
      if (i == 1) return(true);
    }
  else nci = new_shared_info(sc);

  for (i = 0; i < len; i++)
    if (!(s7_is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci, morally)))
      return(false);
  return(true);
}

static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  if (x == y) return(true);
  if (!is_iterator(y)) return(false);

  switch (type(iterator_sequence(x)))
    {
    case T_STRING:
      return((is_string(iterator_sequence(y))) &&
	     (iterator_position(x) == iterator_position(y)) &&
	     (string_equal(sc, iterator_sequence(x), iterator_sequence(y), ci, morally)));

    case T_VECTOR:
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
      return((s7_is_vector(iterator_sequence(y))) &&
	     (iterator_position(x) == iterator_position(y)) &&
	     (vector_equal(sc, iterator_sequence(x), iterator_sequence(y), ci, morally)));

    case T_PAIR:
      return((iterator_sequence(x) == iterator_sequence(y)) &&
	     (iterator_next(x) == iterator_next(y)) &&           /* even if seqs are equal, one might be at end */
	     (iterator_current(x) == iterator_current(y)));      /* current pointer into the sequence */

    case T_HASH_TABLE:
      return((iterator_sequence(x) == iterator_sequence(y)) &&
	     (iterator_next(x) == iterator_next(y)) &&
	     (iterator_current(x) == iterator_current(y)) &&
	     (iterator_hash_current(x) == iterator_hash_current(y)) &&
	     (iterator_position(x) == iterator_position(y)));

    default:
      break;
    }
  return(false);
}

static bool bignum_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  if (!s7_is_number(y)) return(false);
#if WITH_GMP
  if (!morally)
    return(big_numbers_are_eqv(x, y));
  return(big_equal(sc, set_plist_2(sc, x, y)) != sc->F);
#else
  return(false);
#endif
}

static bool integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
#if WITH_GMP
  if (is_big_number(y))
    {
      if (!morally)
	return(big_numbers_are_eqv(x, y));
      return(big_equal(sc, set_plist_2(sc, x, y)) != sc->F);
    }
#endif
  if (is_integer(y))
    return(integer(x) == integer(y));
  if ((!morally) || (!is_number(y)))
    return(false);

  if (is_t_real(y))
    return((!is_NaN(real(y))) &&
	   (fabs(integer(x) - real(y)) <= sc->morally_equal_float_epsilon));

  if (is_t_ratio(y))
    return(s7_fabsl(integer(x) - fraction(y)) <= sc->morally_equal_float_epsilon);

  return((!is_NaN(real_part(y))) &&
	 (!is_NaN(imag_part(y))) &&
	 (fabs(integer(x) - real_part(y)) <= sc->morally_equal_float_epsilon) &&
	 (fabs(imag_part(y)) <= sc->morally_equal_float_epsilon));
}

/* apparently ratio_equal is predefined in g++ -- name collision on mac */
static bool fraction_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
#if WITH_GMP
  if (is_big_number(y))
    {
      if (!morally)
	return(big_numbers_are_eqv(x, y));
      return(big_equal(sc, set_plist_2(sc, x, y)) != sc->F);
    }
#endif
  if (!morally)
    return((s7_is_ratio(y)) &&
	   (numerator(x) == numerator(y)) &&
	   (denominator(x) == denominator(y)));

  if (is_t_ratio(y))
    return(s7_fabsl(fraction(x) - fraction(y)) <= sc->morally_equal_float_epsilon);

  if (is_t_real(y))
    return(floats_are_morally_equal(sc, fraction(x), real(y)));

  if (is_integer(y))
    return(s7_fabsl(fraction(x) - integer(y)) <= sc->morally_equal_float_epsilon);

  if (is_t_complex(y))
    return((!is_NaN(real_part(y))) &&
	   (!is_NaN(imag_part(y))) &&
	   (s7_fabsl(fraction(x) - real_part(y)) <= sc->morally_equal_float_epsilon) &&
	   (fabs(imag_part(y)) <= sc->morally_equal_float_epsilon));
  return(false);
}

static bool real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
#if WITH_GMP
  if (is_big_number(y))
    {
      if (!morally)
	return(big_numbers_are_eqv(x, y));
      return(big_equal(sc, set_plist_2(sc, x, y)) != sc->F);
    }
#endif
  if (!morally)
    return((is_t_real(y)) &&
	   (real(x) == real(y)));
  if (!is_number(y)) return(false);

  if (is_t_real(y))
    return(floats_are_morally_equal(sc, real(x), real(y)));

  if (is_integer(y))
    return((!is_NaN(real(x))) &&
	   (fabs(real(x) - integer(y)) <= sc->morally_equal_float_epsilon));

  if (is_t_ratio(y))
    return(floats_are_morally_equal(sc, real(x), fraction(y)));

  if (is_NaN(real(x)))
    return((is_NaN(real_part(y))) &&
	   (fabs(imag_part(y)) <= sc->morally_equal_float_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)) <= sc->morally_equal_float_epsilon)) &&
	 (fabs(imag_part(y)) <= sc->morally_equal_float_epsilon));
}

static bool complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
#if WITH_GMP
  if (is_big_number(y))
    {
      if (!morally)
	return(big_numbers_are_eqv(x, y));
      return(big_equal(sc, set_plist_2(sc, x, y)) != sc->F);
    }
#endif
  if (!morally)
    return((is_t_complex(y)) &&
	   (!is_NaN(real_part(x))) &&
	   (!is_NaN(imag_part(x))) &&
	   (real_part(x) == real_part(y)) &&
	   (imag_part(x) == imag_part(y)));
  if (!is_number(y)) return(false);

  if (is_integer(y))
    return((!is_NaN(real_part(x))) &&
	   (!is_NaN(imag_part(x))) &&
	   (fabs(real_part(x) - integer(y)) <= sc->morally_equal_float_epsilon) &&
	   (fabs(imag_part(x)) <= sc->morally_equal_float_epsilon));

  if (s7_is_ratio(y))
    return((!is_NaN(real_part(x))) &&
	   (!is_NaN(imag_part(x))) &&
	   (s7_fabsl(real_part(x) - fraction(y)) <= sc->morally_equal_float_epsilon) &&
	   (fabs(imag_part(x)) <= sc->morally_equal_float_epsilon));

  if (is_real(y))
    {
      if (is_NaN(imag_part(x)))
	return(false);
      if (is_NaN(real(y)))
	return((is_NaN(real_part(x))) &&
	       (fabs(imag_part(x)) <= sc->morally_equal_float_epsilon));
      return(((real_part(x) == real(y)) ||
	      (fabs(real_part(x) - real(y)) <= sc->morally_equal_float_epsilon)) &&
	     (fabs(imag_part(x)) <= sc->morally_equal_float_epsilon));
    }

  /* should (morally-equal? nan.0 (complex nan.0 nan.0)) be #t (it's #f above)? */
  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)) <= sc->morally_equal_float_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)) <= sc->morally_equal_float_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)) <= sc->morally_equal_float_epsilon)) &&
	 ((imag_part(x) == imag_part(y)) ||
	  (fabs(imag_part(x) - imag_part(y)) <= sc->morally_equal_float_epsilon)));
}

static bool rng_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
#if WITH_GMP
  return(x == y);
#else
  return((x == y) ||
	 ((is_random_state(y)) &&
	  (random_seed(x) == random_seed(y)) &&
	  (random_carry(x) == random_carry(y))));
#endif
}



static bool (*equals[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally);

static void init_equals(void)
{
  int i;
  for (i = 0; i < NUM_TYPES; i++) equals[i] = eq_equal;
  equals[T_SYMBOL] =       symbol_equal;
  equals[T_C_POINTER] =    c_pointer_equal;
  equals[T_UNSPECIFIED] =  unspecified_equal;
  equals[T_STRING] =       string_equal;
  equals[T_SYNTAX] =       syntax_equal;
  equals[T_C_OBJECT] =     c_object_equal;
  equals[T_RANDOM_STATE] = rng_equal;
  equals[T_ITERATOR] =     iterator_equal;
  equals[T_INPUT_PORT] =   port_equal;
  equals[T_OUTPUT_PORT] =  port_equal;
  equals[T_MACRO] =        closure_equal;
  equals[T_MACRO_STAR] =   closure_equal;
  equals[T_BACRO] =        closure_equal;
  equals[T_BACRO_STAR] =   closure_equal;
  equals[T_CLOSURE] =      closure_equal;
  equals[T_CLOSURE_STAR] = closure_equal;
  equals[T_HASH_TABLE] =   hash_table_equal;
  equals[T_LET] =          let_equal;
  equals[T_PAIR] =         pair_equal;
  equals[T_VECTOR] =       vector_equal;
  equals[T_INT_VECTOR] =   vector_equal;
  equals[T_FLOAT_VECTOR] = vector_equal;
  equals[T_INTEGER] =      integer_equal;
  equals[T_RATIO] =        fraction_equal;
  equals[T_REAL] =         real_equal;
  equals[T_COMPLEX] =      complex_equal;
  equals[T_BIG_INTEGER] =  bignum_equal;
  equals[T_BIG_RATIO] =    bignum_equal;
  equals[T_BIG_REAL] =     bignum_equal;
  equals[T_BIG_COMPLEX] =  bignum_equal;
}

static bool s7_is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci, bool morally)
{
  return((*(equals[type(x)]))(sc, x, y, ci, morally));
}

bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  return(s7_is_equal_1(sc, x, y, NULL, false));
}

bool s7_is_morally_equal(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
  return(s7_is_equal_1(sc, x, y, NULL, true));
}

static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args)
{
  #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2"
  #define Q_is_equal pcl_bt
  return(make_boolean(sc, s7_is_equal(sc, car(args), cadr(args))));
}

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."
  #define Q_is_morally_equal pcl_bt
  return(make_boolean(sc, s7_is_morally_equal(sc, car(args), cadr(args))));
}



/* ---------------------------------------- length, copy, fill ---------------------------------------- */

static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst)
{
  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(real_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_ITERATOR:
      return(make_integer(sc, iterator_length(lst))); /* in several cases, this is incorrect */

    case T_HASH_TABLE:
      return(make_integer(sc, hash_table_mask(lst) + 1));

    case T_C_OBJECT:
      check_method(sc, lst, sc->length_symbol, list_1(sc, lst));
      return(object_length(sc, lst));

    case T_LET:
      check_method(sc, lst, sc->length_symbol, list_1(sc, lst));
      return(make_integer(sc, let_length(sc, lst)));

    case T_CLOSURE:
    case T_CLOSURE_STAR:
      if (has_methods(lst))
	return(make_integer(sc, closure_length(sc, lst)));
      return(sc->F);

    case T_INPUT_PORT:
      if (is_string_port(lst))
	return(make_integer(sc, port_data_size(lst)));
      return(sc->F);

    default:
      return(sc->F);
    }
  return(sc->F);
}

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.  Length of anything else returns #f."
  #define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_boolean_symbol), sc->T)
  return(s7_length(sc, car(args)));
}

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

PF_TO_PF(length, s7_length)



/* -------------------------------- copy -------------------------------- */

static s7_pointer copy_to_string_error = NULL, copy_to_byte_vector_error = NULL;

static void set_string_error_source(s7_scheme *sc, s7_pointer source)
{
  if (!copy_to_string_error)
    copy_to_string_error = s7_make_permanent_string("copy ~A to string, ~S is not a character");
  if (!copy_to_byte_vector_error)
    copy_to_byte_vector_error = s7_make_permanent_string("copy ~A to byte-vector, ~S is not a byte");
  set_cadr(sc->elist_3, prepackaged_type_name(sc, source));
}

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);
    }
  /* (copy #(3) "123"): wrong type arg because not a char, but it's very confusing to report
   *   error: copy argument 3, 3, is an integer but should be a character
   * perhaps better, copy #(3) to string, 3 is not a character
   */
#if DEBUGGING
  if (!copy_to_string_error) {fprintf(stderr, "string_error not set\n"); abort();}
#endif
  set_car(sc->elist_3, copy_to_string_error);
  set_caddr(sc->elist_3, val);
  return(s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}

static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val)
{
  if (s7_is_integer(val))
    {
      s7_int byte;
      byte = s7_integer(val);
      if ((byte >= 0) && (byte < 256))
	string_value(str)[loc] = (unsigned char)byte;
      else return(simple_wrong_type_argument_with_type(sc, sc->copy_symbol, val, an_unsigned_byte_string));
      return(val);
    }
#if DEBUGGING
  if (!copy_to_byte_vector_error) {fprintf(stderr, "byte_vector_error not set\n"); abort();}
#endif
  set_car(sc->elist_3, copy_to_byte_vector_error);
  set_caddr(sc->elist_3, val);
  return(s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}

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 byte_vector_getter(s7_scheme *sc, s7_pointer str, s7_int loc)
{
  return(make_integer(sc, (unsigned char)(string_value(str)[loc])));
}

static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val)
{
  set_car(sc->t2_1, make_integer(sc, loc));
  set_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)
{
  set_car(sc->t1_1, make_integer(sc, loc));
  return((*(c_object_ref(obj)))(sc, obj, sc->t1_1));
}

static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val)
{
  /* loc is irrelevant here
   * val has to be of the form (cons symbol value)
   * if symbol is already in e, its value is changed, otherwise a new slot is added to e
   */
  static s7_pointer ls_err = NULL;
  s7_pointer sym;
  if (!is_pair(val))
    {
      if (!ls_err) ls_err = s7_make_permanent_string("(cons symbol value)");
      return(wrong_type_argument_with_type(sc, sc->copy_symbol, 3, e, ls_err));
    }
  sym = car(val);
  if (!is_symbol(sym))
    {
      if (!ls_err) ls_err = s7_make_permanent_string("(cons symbol value)");
      return(wrong_type_argument_with_type(sc, sc->copy_symbol, 3, e, ls_err));
    }
  if ((symbol_id(sym) < let_id(e)) ||
      (s7_let_set(sc, e, sym, cdr(val)) != cdr(val)))
    make_slot_1(sc, e, sym, cdr(val));
  return(val);
}

static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val)
{
  /* loc is irrelevant here
   * val has to be of the form (cons key value)
   * if key is already in e, its value is changed, otherwise a new slot is added to e
   */
  if (!is_pair(val))
    return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, e, a_list_string));
  return(s7_hash_table_set(sc, e, car(val), cdr(val)));
}


s7_pointer s7_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 Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */
  /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence,
   *   but it can provide a copy method.  So, I think I'll just use #t
   */
  #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol)

  s7_pointer source, dest;
  s7_int i, j, dest_len, start, end, source_len;
  s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) = NULL;
  s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_int loc) = NULL;
  bool have_indices;

  source = car(args);
  if (is_null(cdr(args)))                  /* (copy obj) */
    {
      switch (type(source))
	{
	case T_STRING:
	  {
	    s7_pointer ns;
	    ns = s7_make_string_with_length(sc, string_value(source), string_length(source));
	    if (is_byte_vector(source))
	      set_byte_vector(ns);
	    return(ns);
	  }
	  
	case T_C_OBJECT:
	  return(object_copy(sc, args));

	case T_RANDOM_STATE:
	  return(rng_copy(sc, args));
	  
	case T_HASH_TABLE:              /* this has to copy nearly everything */
	  {
	    int gc_loc;
	    s7_pointer new_hash;
	    new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1);
	    gc_loc = s7_gc_protect(sc, new_hash);
	    hash_table_checker(new_hash) = hash_table_checker(source);
	    hash_table_mapper(new_hash) = hash_table_mapper(source);
	    hash_table_set_procedures(new_hash, hash_table_procedures(source));
	    hash_table_copy(sc, source, new_hash, 0, hash_table_entries(source));
	    s7_gc_unprotect_at(sc, gc_loc);
	    return(new_hash);
	  }
	  
	case T_ITERATOR:
	  return(iterator_copy(sc, source));
	  
	case T_LET:
	  check_method(sc, source, sc->copy_symbol, args);
	  return(let_copy(sc, source));   /* this copies only the local env and points to outer envs */
	  
	case T_CLOSURE: case T_CLOSURE_STAR:
	case T_MACRO: case T_MACRO_STAR:
	case T_BACRO: case T_BACRO_STAR:
	  check_method(sc, source, sc->copy_symbol, args);
	  return(copy_closure(sc, source));
	  
	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:
	  return(s7_vector_copy(sc, source)); /* "shallow" copy */
	  
	case T_PAIR:                    /* top level only, as in the other cases, last arg checks for circles */
	  return(protected_list_copy(sc, source));
	  
	case T_INTEGER:
	  new_cell(sc, dest, T_INTEGER);
	  integer(dest) = integer(source);
	  return(dest);

	case T_RATIO:
	  new_cell(sc, dest, T_RATIO);
	  numerator(dest) = numerator(source);
	  denominator(dest) = denominator(source);
	  return(dest);

	case T_REAL:
	  new_cell(sc, dest, T_REAL);
	  set_real(dest, real(source));
	  return(dest);

	case T_COMPLEX:
	  new_cell(sc, dest, T_COMPLEX);
	  set_real_part(dest, real_part(source));
	  set_imag_part(dest, imag_part(source));
	  return(dest);

#if WITH_GMP
	case T_BIG_INTEGER: return(mpz_to_big_integer(sc, big_integer(source)));
	case T_BIG_RATIO:   return(mpq_to_big_ratio(sc, big_ratio(source)));
	case T_BIG_REAL:    return(mpfr_to_big_real(sc, big_real(source)));
	case T_BIG_COMPLEX: return(mpc_to_big_complex(sc, big_complex(source)));
#endif
	  
	case T_C_POINTER:
	  return(s7_make_c_pointer(sc, s7_c_pointer(source)));
	}
      return(source);
    }

  have_indices = (is_pair(cddr(args)));
  dest = cadr(args);
  if ((source == dest) && (!have_indices))
    return(dest);
  
  switch (type(source))
    {
    case T_PAIR:
      if (dest == sc->key_readable_symbol)  /* a kludge, but I can't think of anything less stupid */
	return(copy_body(sc, source));

      end = s7_list_length(sc, source);
      if (end == 0) 
	end = circular_list_entries(source);
      else
	{
	  if (end < 0) end = -end;
	}
      break;

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      get = vector_getter(source);
      end = vector_length(source);
      break;

    case T_STRING:
      if (is_byte_vector(source))
	get = byte_vector_getter;
      else get = string_getter;
      end = string_length(source);
      break;

    case T_HASH_TABLE:
      end = hash_table_entries(source);
      break;

    case T_C_OBJECT:
      check_method(sc, source, sc->copy_symbol, args);
      {
	s7_pointer x;
	x = object_copy(sc, args);
	if (x == dest)
	  return(dest);
	/* if object_copy can't handle args for some reason, it should return #f (not dest), and we'll soldier on... */
      }
      get = c_object_direct_ref(source);
      if (!get) get = c_object_getter;
      end = object_length_to_int(sc, source);
      break;

    case T_LET:
      check_method(sc, source, sc->copy_symbol, args);
      if (source == sc->rootlet)
	return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, source, make_string_wrapper(sc, "a sequence other than the rootlet")));
      end = let_length(sc, source);
      break;

    case T_NIL:
      end = 0;
      if (is_sequence(dest))
	break;

    default:
      return(wrong_type_argument_with_type(sc, sc->copy_symbol, 1, source, a_sequence_string));
      /* copy doesn't have to duplicate fill!, so (copy 1 #(...)) need not be supported */
    }

  start = 0;
  if (have_indices)
    {
      s7_pointer p;
      p = start_and_end(sc, sc->copy_symbol, NULL, cddr(args), args, 3, &start, &end);
      if (p != sc->gc_nil) return(p);
    }
  if ((start == 0) && (source == dest))
    return(dest);
  source_len = end - start;

  switch (type(dest))
    {
    case T_PAIR:
      dest_len = s7_list_length(sc, dest);
      if (dest_len == 0) 
	dest_len = circular_list_entries(dest);
      else
	{
	  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:
      if (is_byte_vector(dest))
	set = byte_vector_setter;
      else set = string_setter;
      dest_len = string_length(dest);
      break;

    case T_HASH_TABLE:
      set = hash_table_setter;
      dest_len = source_len;
      break;

    case T_C_OBJECT:
      set = c_object_direct_set(dest);
      if (!set) set = c_object_setter;
      dest_len = object_length_to_int(sc, dest);
      break;

    case T_LET:
      if (dest == sc->rootlet)
	return(wrong_type_argument_with_type(sc, sc->copy_symbol, 2, dest, make_string_wrapper(sc, "a sequence other than the rootlet")));
      set = let_setter;
      dest_len = source_len;                     /* grows via set, so dest_len isn't relevant */
      break;

    case T_NIL:
      return(sc->nil);

    default:
      return(wrong_type_argument_with_type(sc, sc->copy_symbol, 2, dest, a_sequence_string));
    }

  if ((source_len == 0) || (dest_len == 0))
    return(dest);

  /* end is source_len if not set explicitly */
  if (dest_len < source_len)
    {
      end = dest_len + start;
      source_len = dest_len;
    }

  if ((source != dest) &&
      (type(source) == type(dest)))
    {
      switch (type(source))
	{
	case T_PAIR:
	  {
	    s7_pointer ps, pd;

	    ps = source;
	    for (i = 0; i < start; i++)
	      ps = cdr(ps);
	    for (pd = dest; (i < end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd))
	      set_car(pd, car(ps));
	    return(dest);
	  }

	case T_VECTOR:
	  memcpy((void *)(vector_elements(dest)), (void *)((vector_elements(source)) + start), source_len * sizeof(s7_pointer));
	  return(dest);

	case T_INT_VECTOR:
	  memcpy((void *)(int_vector_elements(dest)), (void *)((int_vector_elements(source)) + start), source_len * sizeof(s7_int));
	  return(dest);

	case T_FLOAT_VECTOR:
	  memcpy((void *)(float_vector_elements(dest)), (void *)((float_vector_elements(source)) + start), source_len * sizeof(s7_double));
	  return(dest);

	case T_STRING: /* this is 4 cases (string/byte-vector) */
	  memcpy((void *)string_value(dest), (void *)((string_value(source)) + start), source_len * sizeof(char));
	  return(dest);

	case T_C_OBJECT:
	  {
	    s7_pointer mi, mj;
	    int gc_loc1, gc_loc2;
	    s7_pointer (*ref)(s7_scheme *sc, s7_pointer obj, s7_pointer args);
	    s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_pointer args);

	    mi = make_mutable_integer(sc, start);
	    mj = make_mutable_integer(sc, end);
	    gc_loc1 = s7_gc_protect(sc, mi);
	    gc_loc2 = s7_gc_protect(sc, mj);
	    ref = c_object_ref(source);
	    set = c_object_set(dest);

	    for (i = start, j = 0; i < end; i++, j++)
	      {
		integer(mi) = i;
		integer(mj) = j;
		set_car(sc->t1_1, mi);
		set_car(sc->t2_2, ref(sc, source, sc->t1_1));
		set_car(sc->t2_1, mj);
		set(sc, dest, sc->t2_1);
	      }
	    s7_gc_unprotect_at(sc, gc_loc1);
	    s7_gc_unprotect_at(sc, gc_loc2);
	    return(dest);
	  }

	case T_LET:
	  break;

	case T_HASH_TABLE:
	  {
	    s7_pointer p;
	    p = hash_table_copy(sc, source, dest, start, end);
	    if ((hash_table_checker(source) != hash_table_checker(dest)) &&
		(!hash_table_checker_locked(dest)))
	      {
		if (hash_table_checker(dest) == hash_empty)
		  hash_table_checker(dest) = hash_table_checker(source);
		else hash_table_checker(dest) = hash_equal;
	      }
	    return(p);
	  }
	  break;

	default:
	  return(dest);
	}
    }

  switch (type(source))
    {
    case T_PAIR:
      {
	s7_pointer p;
	p = source;
	if (start > 0)
	  for (i = 0; i < start; i++)
	    p = cdr(p);
	/* dest won't be a pair here -- the pair->pair case was caught above */
	if (is_string(dest)) set_string_error_source(sc, source);
	for (i = start, j = 0; i < end; i++, j++, p = cdr(p))
	  set(sc, dest, j, car(p));
	return(dest);
      }

    case T_LET:
      /* implicit index can give n-way reality check (ht growth by new entries) 
       * if shadowed entries are they unshadowed by reversal?
       */
      {
	/* source and dest can't be rootlet (checked above) */
	s7_pointer slot;
	slot = let_slots(source);
	for (i = 0; i < start; i++) slot = next_slot(slot);
	if (is_pair(dest))
	  {
	    s7_pointer p;
	    for (i = start, p = dest; i < end; i++, p = cdr(p), slot = next_slot(slot))
	      set_car(p, cons(sc, slot_symbol(slot), slot_value(slot)));
	  }
	else
	  {
	    if (is_let(dest))
	      {
		for (i = start; i < end; i++, slot = next_slot(slot))
		  make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot));
	      }
	    else
	      {
		if (is_hash_table(dest))
		  {
		    for (i = start; i < end; i++, slot = next_slot(slot))
		      s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot));
		  }
		else
		  {
		    for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot))
		      set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot)));
		  }
	      }
	  }
	return(dest);
      }

    case T_HASH_TABLE:
      {
	int loc, skip;
	hash_entry_t **elements;
	hash_entry_t *x = NULL;
	elements = hash_table_elements(source);
	loc = -1;

	skip = start;
	while (skip > 0)
	  {
	    while (!x) x = elements[++loc];
	    skip--;
	    x = x->next;
	  }

      if (is_pair(dest))
	{
	  s7_pointer p;
	  for (i = start, p = dest; i < end; i++, p = cdr(p))
	    {
	      while (!x) x = elements[++loc];
	      set_car(p, cons(sc, x->key, x->value));
	      x = x->next;
	    }
	}
      else
	{
	  if (is_let(dest))
	    {
	      for (i = start; i < end; i++)
		{
		  while (!x) x = elements[++loc];
		  make_slot_1(sc, dest, x->key, x->value);
		  x = x->next;
		}
	    }
	  else
	    {
	      for (i = start, j = 0; i < end; i++, j++)
		{
		  while (!x) x = elements[++loc];
		  set(sc, dest, j, cons(sc, x->key, x->value));
		  x = x->next;
		}
	    }
	}
      return(dest);
      }

    case T_FLOAT_VECTOR:
      if (is_int_vector(dest))
	{
	  for (i = start, j = 0; i < end; i++, j++)
	    int_vector_element(dest, j) = (s7_int)(float_vector_element(source, i));
	  return(dest);
	}
      break;

    case T_INT_VECTOR:
      if (is_float_vector(dest))
	{
	  for (i = start, j = 0; i < end; i++, j++)
	    float_vector_element(dest, j) = (s7_double)(int_vector_element(source, i));
	  return(dest);
	}
      if (is_string(dest)) /* includes byte-vector, as below */
	{
	  for (i = start, j = 0; i < end; i++, j++)
	    string_value(dest)[j] = (unsigned char)int_vector_element(source, i);
	  return(dest);
	}
      break;

    case T_STRING:
      if (is_normal_vector(dest))
	{
	  if (is_byte_vector(source))
	    {
	      for (i = start, j = 0; i < end; i++, j++)
		vector_element(dest, j) = make_integer(sc, (s7_int)((unsigned char)string_value(source)[i]));
	    }
	  else
	    {
	      for (i = start, j = 0; i < end; i++, j++)
		vector_element(dest, j) = s7_make_character(sc, (unsigned char)string_value(source)[i]);
	    }
	  return(dest);
	}
      if (is_int_vector(dest))
	{
	  for (i = start, j = 0; i < end; i++, j++)
	    int_vector_element(dest, j) = (s7_int)((unsigned char)(string_value(source)[i]));
	  return(dest);
	}
      if (is_float_vector(dest))
	{
	  for (i = start, j = 0; i < end; i++, j++)
	    float_vector_element(dest, j) = (s7_double)((unsigned char)(string_value(source)[i]));
	  return(dest);
	}
    }

  if (is_pair(dest))
    {
      s7_pointer p;
      for (i = start, p = dest; i < end; i++, p = cdr(p))
	set_car(p, get(sc, source, i));
    }
  else
    {
      /* if source == dest here, we're moving data backwards, so this is safe in either case */
      if (is_string(dest)) set_string_error_source(sc, source);
      for (i = start, j = 0; i < end; i++, j++)
	set(sc, dest, j, get(sc, source, i));
    }
  /* some choices probably should raise an error, but don't:
   *   (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error
   */
  return(dest);
}

#define g_copy s7_copy

static s7_pointer c_copy(s7_scheme *sc, s7_pointer x) {return(s7_copy(sc, set_plist_1(sc, x)));}
PF_TO_PF(copy, c_copy)



/* -------------------------------- reverse -------------------------------- */
 
static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args)
{
  #define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order.  reverse \
also accepts a string or vector argument."
  #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)

  s7_pointer p, np;

  p = car(args);
  sc->temp3 = p;
  np = sc->nil;

  switch (type(p))
    {
    case T_NIL:
      return(sc->nil);

    case T_PAIR:
      return(s7_reverse(sc, p));

    case T_STRING:
      {
	char *source, *dest, *end;
	int len;
	len = string_length(p);
	source = string_value(p);
	end = (char *)(source + len);
	dest = (char *)malloc((len + 1) * sizeof(char));
	dest[len] = 0;
	np = make_string_uncopied_with_length(sc, dest, len);
	dest += len;
	while (source < end) *(--dest) = *source++;
	if (is_byte_vector(p))
	  set_byte_vector(np);
      }
      break;

    case T_INT_VECTOR:
      {
	s7_int *source, *dest, *end;
	s7_int len;
	len = vector_length(p);
	if (vector_rank(p) > 1)
	  np = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), small_int(0), sc->T));
	else np = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
	source = int_vector_elements(p);
	end = (s7_int *)(source + len);
	dest = (s7_int *)(int_vector_elements(np) + len);
	while (source < end) *(--dest) = *source++;
      }
      break;

    case T_FLOAT_VECTOR:
      {
	s7_double *source, *dest, *end;
	s7_int len;
	len = vector_length(p);
	if (vector_rank(p) > 1)
	  np = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), real_zero, sc->T));
	else np = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR);
	source = float_vector_elements(p);
	end = (s7_double *)(source + len);
	dest = (s7_double *)(float_vector_elements(np) + len);
	while (source < end) *(--dest) = *source++;
      }
      break;

    case T_VECTOR:
      {
	s7_pointer *source, *dest, *end;
	s7_int len;
	len = vector_length(p);
	if (vector_rank(p) > 1)
	  np = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, list_1(sc, p))));
	else np = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
	source = vector_elements(p);
	end = (s7_pointer *)(source + len);
	dest = (s7_pointer *)(vector_elements(np) + len);
	while (source < end) *(--dest) = *source++;
      }
      break;

    case T_HASH_TABLE:
      return(hash_table_reverse(sc, p));

    case T_C_OBJECT:
      check_method(sc, p, sc->reverse_symbol, args);
      if (c_object_reverse(p))
	return((*(c_object_reverse(p)))(sc, args));
      eval_error(sc, "attempt to reverse ~S?", p);

    default:
      method_or_bust_with_type(sc, p, sc->reverse_symbol, args, a_sequence_string, 0);
    }
  return(np);
}

static s7_pointer c_reverse(s7_scheme *sc, s7_pointer x) {return(g_reverse(sc, set_plist_1(sc, x)));}
PF_TO_PF(reverse, c_reverse)

static s7_pointer c_reverse_in_place(s7_scheme *sc, s7_pointer p)
{
  switch (type(p))
    {
    case T_NIL:
      return(sc->nil);

    case T_PAIR:
      {
	s7_pointer np;
	np = reverse_in_place(sc, sc->nil, p);
	if (is_null(np))
	  return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, a_proper_list_string));
	return(np);
      }
      break;
      /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast
       * so in a sense this is different from the other cases: it assumes (set! p (reverse! p))
       * To make (reverse! p) direct:
       *    for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l;
       *    if (!is_null(r)) return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, a_proper_list_string));
       *    for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); set_car(l, car(r)); set_car(r, t); if (cdr(l) != r) r = opt1(r);}
       */

    case T_STRING:
      {
	int len;
	char *s1, *s2;
	len = string_length(p);
	if (len < 2) return(p);
	s1 = string_value(p);
	s2 = (char *)(s1 + len - 1);
	while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;}
      }
      break;

    case T_INT_VECTOR:
      {
	s7_int len;
	s7_int *s1, *s2;
	len = vector_length(p);
	if (len < 2) return(p);
	s1 = int_vector_elements(p);
	s2 = (s7_int *)(s1 + len - 1);
	while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;}
      }
      break;

    case T_FLOAT_VECTOR:
      {
	s7_int len;
	s7_double *s1, *s2;
	len = vector_length(p);
	if (len < 2) return(p);
	s1 = float_vector_elements(p);
	s2 = (s7_double *)(s1 + len - 1);
	while (s1 < s2) {s7_double c; c = *s1; *s1++ = *s2; *s2-- = c;}
      }
      break;

    case T_VECTOR:
      {
	s7_int len;
	s7_pointer *s1, *s2;
	len = vector_length(p);
	if (len < 2) return(p);
	s1 = vector_elements(p);
	s2 = (s7_pointer *)(s1 + len - 1);
	while (s1 < s2) {s7_pointer c; c = *s1; *s1++ = *s2; *s2-- = c;}
      }
      break;

    default:
      if ((is_simple_sequence(p)) &&
	  (!has_methods(p)))
	return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, make_string_wrapper(sc, "a vector, string, or list")));
      method_or_bust_with_type(sc, p, sc->reverseb_symbol, list_1(sc, p), a_sequence_string, 0);
    }
  return(p);
}

static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args)
{
  #define H_reverse_in_place "(reverse! lst) reverses lst in place"
  #define Q_reverse_in_place s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)
  return(c_reverse_in_place(sc, car(args)));
}

PF_TO_PF(reverse_in_place, c_reverse_in_place)


/* -------------------------------- fill! -------------------------------- */

static s7_pointer list_fill(s7_scheme *sc, s7_pointer args)
{
  /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */
  s7_pointer x, y, obj, val;
  s7_int i, start = 0, end, len;

  obj = car(args);
  len = s7_list_length(sc, obj);
  end = len;
  if (end < 0) end = -end; else {if (end == 0) end = 123123123;}
  val = cadr(args);

  if (!is_null(cddr(args)))
    {
      s7_pointer p;
      p = start_and_end(sc, sc->fill_symbol, sc->fill_symbol, cddr(args), args, 3, &start, &end);
      if (p != sc->gc_nil) return(p);
      if (start == end) return(val);
    }

  if (len > 0)
    {
      s7_int i;
      s7_pointer p;
      if (end < len) len = end;
      for (i = 0, p = obj; i < start; p = cdr(p), i++);
      for (; i < len; p = cdr(p), i++) set_car(p, val);
      return(val);
    }

  for (x = obj, y = obj, i = 0; ;i++)
    {
      if ((end > 0) && (i >= end))
	return(val);
      if (i >= start) set_car(x, val);
      if (!is_pair(cdr(x)))
	{
	  if (!is_null(cdr(x)))
	    set_cdr(x, val);
	  return(val);
	}
      x = cdr(x);
      if ((i & 1) != 0) y = cdr(y);
      if (x == y) return(val);
    }
  return(val);
}


s7_pointer s7_fill(s7_scheme *sc, s7_pointer args)
{
  #define H_fill "(fill! obj val (start 0) end) fills obj with val"
  #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol)
  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_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(g_vector_fill(sc, args));

    case T_PAIR:
      return(list_fill(sc, args));

    case T_NIL:
      return(cadr(args));        /* this parallels the empty vector case */

    case T_HASH_TABLE:
      return(hash_table_fill(sc, args));

    case T_C_OBJECT:
      check_method(sc, p, sc->fill_symbol, args);
      if (c_object_fill(p))
	return((*(c_object_fill(p)))(sc, args));
      eval_error(sc, "attempt to fill ~S?", p);

    default:
      check_method(sc, p, sc->fill_symbol, args);
    }
  return(wrong_type_argument_with_type(sc, sc->fill_symbol, 1, p, a_sequence_string)); /* (fill! 1 0) */
}

#define g_fill s7_fill
/* perhaps (fill iterator obj) could fill the underlying sequence (if any) -- not let/closure
 *   similarly for length, reverse etc
 */

static s7_pointer c_fill(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(s7_fill(sc, set_plist_2(sc, x, y)));}
PF2_TO_PF(fill, c_fill)


/* -------------------------------- append -------------------------------- */

static s7_int sequence_length(s7_scheme *sc, s7_pointer lst)
{
  switch (type(lst))
    {
    case T_PAIR:
      {
	int len;
	len = s7_list_length(sc, lst);
	if (len == 0) return(-1);
	return(len);
      }
    case T_NIL:        return(0);
    case T_INT_VECTOR: 
    case T_FLOAT_VECTOR: 
    case T_VECTOR:     return(vector_length(lst));
    case T_STRING:     return(string_length(lst));
    case T_HASH_TABLE: return(hash_table_entries(lst));
    case T_LET:        return(let_length(sc, lst));
    case T_C_OBJECT:   
      {
	s7_pointer x;
	x = object_length(sc, lst);
	if (s7_is_integer(x))
	  return(s7_integer(x));
      }
    }
  return(-1);
}

static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, int typ)
{
  s7_pointer p;
  int i;
  s7_int len = 0;

  for (i = 1, p = args; is_pair(p); p = cdr(p), i++)
    {
      s7_pointer seq;
      s7_int n;
      seq = car(p);
      n = sequence_length(sc, seq);
      if ((n > 0) && 
	  (typ != T_FREE) && 
	  ((type(seq) == T_HASH_TABLE) ||  /* can't append hash-tables (no obvious meaning to the operation) */
	   ((type(seq) == T_LET) &&        /*   similarly for lets, unless this is a mock-string or something similar */
	    ((!has_methods(seq)) || (find_method(sc, seq, sc->append_symbol) == sc->undefined)))))
	{
	  wrong_type_argument(sc, sc->append_symbol, i, seq, typ);
	  return(0);
	}
      if (n < 0)
	{
	  wrong_type_argument_with_type(sc, sc->append_symbol, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string);
	  return(0);
	}
      len += n;
    }
  return(len);
}

static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, int typ)
{
  s7_pointer new_vec;
  s7_int len;

  len = total_sequence_length(sc, args, sc->vector_append_symbol, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER));
  new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ);  /* might hit GC in loop below so we can't use NOT_FILLED here */

  if (len > 0)
    {
      s7_pointer p, sv;
      int i;

      sc->temp9 = new_vec; /* s7_copy below can call s7_error so s7_gc_protect here is tricky -- use a preset position perhaps? */
      sv = make_subvector(sc, new_vec);
      sc->temp10 = sv;

      for (i = 0, p = args; is_pair(p); p = cdr(p))
	{
	  s7_int n;
	  s7_pointer x;
	  x = car(p);
	  n = sequence_length(sc, x);
	  if (n > 0)
	    {
	      vector_length(sv) = n;
	      s7_copy(sc, set_plist_2(sc, x, sv));
	      vector_length(sv) = 0; /* so GC doesn't march off the end */
	      i += n;
	      if (typ == T_VECTOR)
		vector_elements(sv) = (s7_pointer *)(vector_elements(new_vec) + i);
	      else
		{
		  if (typ == T_FLOAT_VECTOR)
		    float_vector_elements(sv) = (s7_double *)(float_vector_elements(new_vec) + i);
		  else int_vector_elements(sv) = (s7_int *)(int_vector_elements(new_vec) + i);
		}
	    }
	}
      set_plist_2(sc, sc->nil, sc->nil);
      sc->temp9 = sc->nil;
      sc->temp10 = sc->nil;
      vector_length(sv) = 0;
    }
  return(new_vec);
}

static s7_pointer string_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer new_str;
  s7_int len;

  len = total_sequence_length(sc, args, sc->string_append_symbol, (is_byte_vector(car(args))) ? T_INTEGER : T_CHARACTER);
  new_str = make_empty_string(sc, len, 0);
  if (is_byte_vector(car(args)))
    set_byte_vector(new_str);

  if (len > 0)
    {
      s7_pointer p, sv;
      int i;

      sc->temp9 = new_str;
      sv = make_string_wrapper_with_length(sc, (const char *)string_value(new_str), len);
      if (is_byte_vector(new_str))
	set_byte_vector(sv);
      sc->temp10 = sv;

      for (i = 0, p = args; is_pair(p); p = cdr(p))
	{
	  s7_pointer x;
	  s7_int n;
	  x = car(p);
	  n = sequence_length(sc, x);
	  if (n > 0)
	    {
	      string_length(sv) = n;
	      s7_copy(sc, set_plist_2(sc, x, sv));
	      i += n;
	      string_value(sv) = (char *)(string_value(new_str) + i);
	    }
	}
      set_plist_2(sc, sc->nil, sc->nil);
      sc->temp9 = sc->nil;
      sc->temp10 = sc->nil;
      string_length(sv) = 0;
    }

  return(new_str);
}

static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer new_hash, p;
  new_hash = s7_make_hash_table(sc, sc->default_hash_table_length);
  for (p = args; is_pair(p); p = cdr(p))
    s7_copy(sc, set_plist_2(sc, car(p), new_hash));
  set_plist_2(sc, sc->nil, sc->nil);
  return(new_hash);
}

static s7_pointer let_append(s7_scheme *sc, s7_pointer args)
{
  s7_pointer new_let, p, e;
  
  e = car(args);
  check_method(sc, e, sc->append_symbol, args);
  new_let = new_frame_in_env(sc, sc->nil);
  for (p = args; is_pair(p); p = cdr(p))
    s7_copy(sc, set_plist_2(sc, car(p), new_let)); 
  set_plist_2(sc, sc->nil, sc->nil);
  return(new_let);
}

static s7_pointer g_append(s7_scheme *sc, s7_pointer args)
{
  #define H_append "(append ...) returns its argument sequences appended into one sequence"
  #define Q_append s7_make_circular_signature(sc, 0, 1, sc->T)
  s7_pointer a1;

  if (is_null(args)) return(sc->nil);  /* (append) -> () */
  a1 = car(args);                      /* first arg determines result type unless all args but last are empty (sigh) */
  if (is_null(cdr(args))) return(a1);  /* (append <anything>) -> <anything> */

  switch (type(a1))
    {
    case T_NIL:
    case T_PAIR:
      return(g_list_append(sc, args)); /* only list case accepts any trailing arg because dotted lists are special */

    case T_VECTOR:
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
      return(vector_append(sc, args, type(a1)));

    case T_STRING:
      return(string_append(sc, args));

    case T_HASH_TABLE:
      return(hash_table_append(sc, args));

    case T_LET:
      return(let_append(sc, args));

     default:
      check_method(sc, a1, sc->append_symbol, args);
    }
  return(wrong_type_argument_with_type(sc, sc->append_symbol, 1, a1, a_sequence_string)); /* (append 1 0) */
}

static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj)
{
  /* used only in format_to_port_1 and (map values ...) */
  switch (type(obj))
    {
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(s7_vector_to_list(sc, obj));

    case T_STRING:
      if (is_byte_vector(obj))
	return(byte_vector_to_list(sc, string_value(obj), string_length(obj)));
      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;
	  iterator = s7_make_iterator(sc, obj);
	  sc->temp8 = iterator;
	  sc->w = sc->nil;
	  while (true)
	    {
	      x = s7_iterate(sc, iterator);
	      if (iterator_is_at_end(iterator)) break;
	      sc->w = cons(sc, x, sc->w);
	    }
	  x = sc->w;
	  sc->w = sc->nil;
	  sc->temp8 = sc->nil;
	  return(x);
	}
      return(sc->nil);

    case T_LET:
#if (!WITH_PURE_S7)
      check_method(sc, obj, sc->let_to_list_symbol, list_1(sc, obj));
#endif
      return(s7_let_to_list(sc, obj));

    case T_ITERATOR:
      {
	s7_pointer result, p = NULL;
	int results = 0;
	result = sc->nil;
	while (true)
	  {
	    s7_pointer val;
	    val = s7_iterate(sc, obj);
	    if ((val == sc->ITERATOR_END) &&
		(iterator_is_at_end(obj)))
	      {
		sc->temp8 = sc->nil;
		return(result);
	      }
	    if (sc->safety > 0)
	      {
		results++;
		if (results > 10000)
		  {
		    fprintf(stderr, "iterator in object->list is creating a very long list!\n");
		    results = S7_LONG_MIN;
		  }
	      }
	    if (val != sc->no_value)
	      {
		if (is_null(result))
		  {
		    if (is_multiple_value(val))
		      {
			result = multiple_value(val);
			clear_multiple_value(val);
			for (p = result; is_pair(cdr(p)); p = cdr(p));
		      }
		    else 
		      {
			result = cons(sc, val, sc->nil);
			p = result;
		      }
		    sc->temp8 = result;
		  }
		else
		  {
		    if (is_multiple_value(val))
		      {
			set_cdr(p, multiple_value(val));
			clear_multiple_value(val);
			for (; is_pair(cdr(p)); p = cdr(p));
		      }
		    else 
		      {
			set_cdr(p, cons(sc, val, sc->nil));
			p = cdr(p);
		      }
		  }
	      }
	  }
      }

    case T_C_OBJECT:
      {
	long int i, len; /* the "long" matters on 64-bit machines */
	s7_pointer x, z, result;
	int gc_z = -1;

	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);
	sc->temp8 = result;
	z = list_1(sc, sc->F);
	gc_z = s7_gc_protect(sc, z);

	set_car(sc->z2_1, sc->x);
	set_car(sc->z2_2, sc->z);
	for (i = 0, x = result; i < len; i++, x = cdr(x))
	  {
	    set_car(z, make_integer(sc, i));
	    set_car(x, (*(c_object_ref(obj)))(sc, obj, z));
	  }
	sc->x = car(sc->z2_1);
	sc->z = car(sc->z2_2);
	s7_gc_unprotect_at(sc, gc_z);
	sc->temp8 = sc->nil;
	return(result);
      }
    }
  return(obj);
}


/* -------------------------------- object->let -------------------------------- */

static bool is_decodable(s7_scheme *sc, s7_pointer p);
static s7_pointer stack_entries(s7_scheme *sc, s7_pointer stack, int top);

static s7_pointer g_object_to_let(s7_scheme *sc, s7_pointer args)
{
  #define H_object_to_let "(object->let obj) returns a let (namespace) describing obj."
  #define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T)

  s7_pointer obj;
  obj = car(args);

  switch (type(obj))
    {
    case T_NIL:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_null_symbol)));

    case T_UNSPECIFIED:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, obj)));

    case T_SYNTAX:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, s7_make_symbol(sc, "syntax?"))));

    case T_UNIQUE:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, (is_eof(obj)) ? sc->is_eof_object_symbol : obj)));

    case T_BOOLEAN:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_boolean_symbol)));
      
    case T_SYMBOL:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, (is_keyword(obj)) ? sc->is_keyword_symbol : sc->is_symbol_symbol)));
      
    case T_CHARACTER:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_char_symbol)));
      
    case T_INTEGER:
    case T_BIG_INTEGER:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol)));
      
    case T_RATIO:
    case T_BIG_RATIO:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol)));
      
    case T_REAL:
    case T_BIG_REAL:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol)));
      
    case T_COMPLEX:
    case T_BIG_COMPLEX:
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol)));

    case T_STRING:
      return(s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj, 
				  sc->type_symbol, (is_byte_vector(obj)) ? sc->is_byte_vector_symbol : sc->is_string_symbol,
				  sc->length_symbol, s7_length(sc, obj))));

    case T_PAIR:
      return(s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj, 
				  sc->type_symbol, sc->is_pair_symbol,
				  sc->length_symbol, s7_length(sc, obj))));

    case T_RANDOM_STATE:
#if WITH_GMP
      return(s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_random_state_symbol)));
#else
      return(s7_inlet(sc, s7_list(sc, 8, sc->value_symbol, obj,
				  sc->type_symbol, sc->is_random_state_symbol,
				  s7_make_symbol(sc, "seed"), s7_make_integer(sc, random_seed(obj)),
				  s7_make_symbol(sc, "carry"), s7_make_integer(sc, random_carry(obj)))));
#endif

    case T_GOTO:
      return(s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj, 
				  sc->type_symbol, s7_make_symbol(sc, "goto?"),
				  s7_make_symbol(sc, "active"), s7_make_boolean(sc, call_exit_active(obj)))));

    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      return(s7_inlet(sc, s7_list(sc, 10, sc->value_symbol, obj, 
				  sc->type_symbol, 
				    (is_int_vector(obj)) ? sc->is_int_vector_symbol : ((is_float_vector(obj)) ? sc->is_float_vector_symbol : sc->is_vector_symbol),
				  sc->length_symbol, s7_length(sc, obj),
				  s7_make_symbol(sc, "dimensions"), g_vector_dimensions(sc, list_1(sc, obj)),
				  s7_make_symbol(sc, "shared"), 
				    ((vector_has_dimensional_info(obj)) && (is_normal_vector(shared_vector(obj)))) ? shared_vector(obj) : sc->F)));

    case T_C_POINTER:
      return(s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj, 
				  sc->type_symbol, sc->is_c_pointer_symbol,
				  s7_make_symbol(sc, "s7-value"),
				    ((is_decodable(sc, (s7_pointer)raw_pointer(obj))) && 
				     (!is_free(obj))) ? g_object_to_let(sc, cons(sc, (s7_pointer)raw_pointer(obj), sc->nil)) : sc->F)));

    case T_CONTINUATION:
      {
	s7_pointer let;
	int gc_loc;
	let = s7_inlet(sc, s7_list(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol));
	gc_loc = s7_gc_protect(sc, let);
	s7_varlet(sc, let, s7_make_symbol(sc, "stack"), stack_entries(sc, continuation_stack(obj), continuation_stack_top(obj)));
	s7_gc_unprotect_at(sc, gc_loc);
	return(let);
      }

    case T_ITERATOR:
      {
	s7_pointer let, seq;
	seq = iterator_sequence(obj);
	let = s7_inlet(sc, s7_list(sc, 8, sc->value_symbol, obj,
				   sc->type_symbol, sc->is_iterator_symbol,
				   s7_make_symbol(sc, "at-end"), s7_make_boolean(sc, iterator_is_at_end(obj)),
				   s7_make_symbol(sc, "sequence"), iterator_sequence(obj)));
	if (is_pair(seq))
	  s7_varlet(sc, let, sc->length_symbol, s7_length(sc, seq));
	else
	  {
	    if (is_hash_table(seq))
	      s7_varlet(sc, let, sc->length_symbol, s7_make_integer(sc, hash_table_entries(seq)));
	    else s7_varlet(sc, let, sc->length_symbol, s7_length(sc, obj));
	  }
	if ((is_string(seq)) || 
	    (is_normal_vector(seq)) ||
	    (is_int_vector(seq)) ||
	    (is_float_vector(seq)) ||
	    (seq == sc->rootlet) ||
	    (is_c_object(seq)) ||
	    (is_hash_table(seq)))
	  s7_varlet(sc, let, s7_make_symbol(sc, "position"), s7_make_integer(sc, iterator_position(obj)));
	else
	  {
	    if (is_pair(seq))
	      s7_varlet(sc, let, s7_make_symbol(sc, "position"), iterator_current(obj));
	  }
	return(let);
      }

    case T_HASH_TABLE:
      {
	s7_pointer let;
	let = s7_inlet(sc, s7_list(sc, 10, sc->value_symbol, obj,
				   sc->type_symbol, sc->is_hash_table_symbol,
				   sc->length_symbol, s7_length(sc, obj),
				   s7_make_symbol(sc, "entries"), s7_make_integer(sc, hash_table_entries(obj)),
				   s7_make_symbol(sc, "locked"), s7_make_boolean(sc, hash_table_checker_locked(obj))));

	if ((hash_table_checker(obj) == hash_eq) ||
	    (hash_table_checker(obj) == hash_c_function) ||
	    (hash_table_checker(obj) == hash_closure) ||
	    (hash_table_checker(obj) == hash_equal_eq) ||
	    (hash_table_checker(obj) == hash_equal_syntax) ||
	    (hash_table_checker(obj) == hash_symbol))
	  s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->is_eq_symbol);
	else
	  {
	    if (hash_table_checker(obj) == hash_eqv) 
	      s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->is_eqv_symbol);
	    else
	      {
		if ((hash_table_checker(obj) == hash_equal) || 
		    (hash_table_checker(obj) == hash_empty))
		  s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->is_equal_symbol);
		else
		  {
		    if (hash_table_checker(obj) == hash_morally_equal) 
		      s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->is_morally_equal_symbol);
		    else
		      {
			if ((hash_table_checker(obj) == hash_number) ||
			    (hash_table_checker(obj) == hash_int) ||
			    (hash_table_checker(obj) == hash_float) ||
			    (hash_table_checker(obj) == hash_equal_real) ||
			    (hash_table_checker(obj) == hash_equal_complex))
			  s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->eq_symbol);
			else
			  {
			    if (hash_table_checker(obj) == hash_string) 
			      s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->string_eq_symbol);
			    else
			      {
				if (hash_table_checker(obj) == hash_char) 
				  s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->char_eq_symbol);
#if (!WITH_PURE_S7)
				else
				  {
				    if (hash_table_checker(obj) == hash_ci_char) 
				      s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->char_ci_eq_symbol);
				    else
				      {
					if (hash_table_checker(obj) == hash_ci_string) 
					  s7_varlet(sc, let, s7_make_symbol(sc, "function"), sc->string_ci_eq_symbol);
				      }}
#endif
			      }}}}}}
	return(let);
      }

    case T_LET:
      {
	s7_pointer let;
	let = s7_inlet(sc, s7_list(sc, 10, sc->value_symbol, obj,
				   sc->type_symbol, sc->is_let_symbol,
				   sc->length_symbol, s7_length(sc, obj),
				   s7_make_symbol(sc, "open"), s7_make_boolean(sc, has_methods(obj)),
				   sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : outlet(obj)));
	if (obj == sc->rootlet)
	  s7_varlet(sc, let, s7_make_symbol(sc, "alias"), sc->rootlet_symbol);
	else
	  {
	    if (obj == sc->owlet)
	      s7_varlet(sc, let, s7_make_symbol(sc, "alias"), sc->owlet_symbol);
	    else
	      {
		if (is_function_env(obj))
		  {
		    s7_varlet(sc, let, s7_make_symbol(sc, "function"), funclet_function(obj));
		    if ((let_file(obj) > 0) && 
			(let_file(obj) < (s7_int)sc->file_names_top) &&
			(let_line(obj) > 0))
		      {
			s7_varlet(sc, let, s7_make_symbol(sc, "file"), sc->file_names[let_file(obj)]);
			s7_varlet(sc, let, s7_make_symbol(sc, "line"), make_integer(sc, let_line(obj)));
		      }
		  }
	      }
	  }
	if (has_methods(obj))
	  {
	    s7_pointer func;
	    func = find_method(sc, obj, sc->object_to_let_symbol);
	    if (func != sc->undefined)
	      {
		int gc_loc;
		gc_loc = s7_gc_protect(sc, let);
		s7_apply_function(sc, func, list_2(sc, obj, let));
		s7_gc_unprotect_at(sc, gc_loc);
	      }
	  }
	return(let);
      }

    case T_C_OBJECT:
      {
	s7_pointer let, clet;
	clet = c_object_let(obj);
	let = s7_inlet(sc, s7_list(sc, 12, sc->value_symbol, obj,
				   sc->type_symbol, sc->is_c_object_symbol,
				   sc->length_symbol, s7_length(sc, obj),
				   s7_make_symbol(sc, "c-type"), s7_make_integer(sc, c_object_type(obj)),
				   sc->let_symbol, clet,
				   s7_make_symbol(sc, "class"), c_object_scheme_name(obj)));
	if ((is_let(clet)) &&
	    ((has_methods(clet)) || (has_methods(obj))))
	  {
	    s7_pointer func;
	    func = find_method(sc, clet, sc->object_to_let_symbol);
	    if (func != sc->undefined)
	      {
		int gc_loc;
		gc_loc = s7_gc_protect(sc, let);
		s7_apply_function(sc, func, list_2(sc, obj, let));
		s7_gc_unprotect_at(sc, gc_loc);
	      }
	  }
	return(let);
      }

    case T_INPUT_PORT:
    case T_OUTPUT_PORT:
      {
	s7_pointer let;
	int gc_loc;
	let = s7_inlet(sc, s7_list(sc, 8, sc->value_symbol, obj,
				   sc->type_symbol, (is_input_port(obj)) ? sc->is_input_port_symbol : sc->is_output_port_symbol,
				   s7_make_symbol(sc, "port-type"), 
				     (is_string_port(obj)) ? sc->string_symbol : 
				       ((is_file_port(obj)) ? s7_make_symbol(sc, "file") : s7_make_symbol(sc, "function")),
				   s7_make_symbol(sc, "closed"), s7_make_boolean(sc, port_is_closed(obj))));
	gc_loc = s7_gc_protect(sc, let);
	if (is_file_port(obj))
	  {
	    s7_varlet(sc, let, s7_make_symbol(sc, "file"), g_port_filename(sc, list_1(sc, obj)));
	    if (is_input_port(obj))
	      s7_varlet(sc, let, s7_make_symbol(sc, "line"), g_port_line_number(sc, list_1(sc, obj)));
	  }
	if (port_data_size(obj) > 0)
	  {
	    s7_varlet(sc, let, sc->length_symbol, s7_make_integer(sc, port_data_size(obj)));
	    s7_varlet(sc, let, s7_make_symbol(sc, "position"), s7_make_integer(sc, port_position(obj)));
	    /* I think port_data need not be null-terminated, but s7_make_string assumes it is:
	     *   both valgrind and lib*san complain about the uninitialized data during strlen.
	     */
	    s7_varlet(sc, let, s7_make_symbol(sc, "data"), s7_make_string_with_length(sc, (const char *)port_data(obj), port_data_size(obj)));
	  }
	s7_gc_unprotect_at(sc, gc_loc);
	return(let);
      }

    case T_CLOSURE:
    case T_CLOSURE_STAR:
    case T_MACRO:
    case T_MACRO_STAR:
    case T_BACRO:
    case T_BACRO_STAR:
      {
	s7_pointer let, sig;
	const char* doc;
	int gc_loc;
	let = s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj,
				   sc->type_symbol, (is_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol,
				   s7_make_symbol(sc, "arity"), s7_arity(sc, obj)));
	gc_loc = s7_gc_protect(sc, let);

	sig = s7_procedure_signature(sc, obj);
	if (is_pair(sig))
	  s7_varlet(sc, let, sc->signature_symbol, sig);
	
	doc = s7_procedure_documentation(sc, obj);
	if (doc)
	  s7_varlet(sc, let, sc->documentation_symbol, s7_make_string(sc, doc));
	
	if (is_let(closure_let(obj)))
	  {
	    s7_pointer flet;
	    flet = closure_let(obj);
	    if ((let_file(flet) > 0) && 
		(let_file(flet) < (s7_int)sc->file_names_top) &&
		(let_line(flet) > 0))
	      {
		s7_varlet(sc, let, s7_make_symbol(sc, "file"), sc->file_names[let_file(flet)]);
		s7_varlet(sc, let, s7_make_symbol(sc, "line"), make_integer(sc, let_line(flet)));
	      }
	  }
	
	if (closure_setter(obj) != sc->F)
	  s7_varlet(sc, let, s7_make_symbol(sc, "setter"), closure_setter(obj));

	s7_varlet(sc, let, s7_make_symbol(sc, "source"), 
			    append_in_place(sc, list_2(sc, (is_closure_star(obj)) ? sc->lambda_star_symbol : sc->lambda_symbol, 
						       closure_args(obj)), 
					    closure_body(obj)));
	s7_gc_unprotect_at(sc, gc_loc);
	return(let);
      }

    case T_C_MACRO:
    case T_C_FUNCTION_STAR:
    case T_C_FUNCTION:
    case T_C_ANY_ARGS_FUNCTION:
    case T_C_OPT_ARGS_FUNCTION:
    case T_C_RST_ARGS_FUNCTION:
      {
	s7_pointer let, sig;
	const char* doc;
	let = s7_inlet(sc, s7_list(sc, 6, sc->value_symbol, obj,
				   sc->type_symbol, (is_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol,
				   s7_make_symbol(sc, "arity"), s7_arity(sc, obj)));

	sig = s7_procedure_signature(sc, obj);
	if (is_pair(sig))
	  s7_varlet(sc, let, sc->signature_symbol, sig);
	
	doc = s7_procedure_documentation(sc, obj);
	if (doc)
	  s7_varlet(sc, let, sc->documentation_symbol, s7_make_string(sc, doc));

	if (c_function_setter(obj) != sc->F)
	  s7_varlet(sc, let, s7_make_symbol(sc, "setter"), c_function_setter(obj));
	
	return(let);
      }

    default:
#if DEBUGGING
      fprintf(stderr, "object->let: %s, type: %d\n", DISPLAY(obj), type(obj));
#endif
      return(sc->F);
    }

  return(sc->F);
}



/* ---------------- stacktrace ---------------- */

static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e)
{
  if ((is_let(e)) && (e != sc->rootlet))
    {
      if (is_function_env(e))
	return(funclet_function(e));
      return(stacktrace_find_caller(sc, outlet(e)));
    }
  return(sc->F);
}

static bool stacktrace_find_let(s7_scheme *sc, int loc, s7_pointer e)
{
  return((loc > 0) &&
	 ((stack_let(sc->stack, loc) == e) ||
	  (stacktrace_find_let(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((outlet(sc->owlet) == sc->envir) ||
	 (stacktrace_find_let(sc, loc * 4, outlet(sc->owlet))) ||
	 (stacktrace_find_error_hook_quit(sc) > 0));
}


static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym)
{
  if (is_symbol(sym))
    {
      s7_pointer f;
      f = s7_symbol_value(sc, sym);
      return((is_procedure(f)) &&
	     (is_procedure(sc->error_hook)) &&
	     (hook_has_functions(sc->error_hook)) &&
	     (direct_memq(f, s7_hook_functions(sc, sc->error_hook))));
    }
  return(false);
}

static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e,
			       char *notes, 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)) &&
	  (!is_slot(global_slot(code))))
	{
	  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) && (val != sc->undefined) &&
	      (!is_any_macro(val)))
	    {
	      int typ;

	      typ = type(val);
	      if (typ < T_GOTO)
		{
		  char *objstr, *str;
		  const char *spaces;
		  int objlen, new_note_len, notes_max, cur_line_len = 0, spaces_len;
		  bool new_notes_line = false, old_short_print;
		  s7_int old_len;

		  spaces = "                                                                                ";
		  spaces_len = strlen(spaces);

		  if (notes_start_col < 0) notes_start_col = 50;
		  notes_max = total_cols - notes_start_col;

		  old_short_print = sc->short_print;
		  sc->short_print = true;
		  old_len = sc->print_length;
		  if (sc->print_length > 4) sc->print_length = 4;
		  objstr = s7_object_to_c_string(sc, val);
		  objlen = safe_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;
		    }
		  sc->short_print = old_short_print;
		  sc->print_length = old_len;

		  new_note_len = symbol_name_length(code) + 3 + objlen;
		  /* we want to append this much info to the notes, but does it need a new line?
		   */
		  if (notes_start_col < code_cols)
		    new_notes_line = true;
		  else
		    {
		      if (notes)
			{
			  char *last_newline;
			  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 *)malloc(new_note_len * sizeof(char));
		      snprintf(str, new_note_len, "%s\n%s%s%s%s: %s",
			       (notes) ? notes : "",
			       (as_comment) ? "; " : "",
			       (spaces_len >= notes_start_col) ? (char *)(spaces + spaces_len - notes_start_col) : "",
			       (as_comment) ? "" : " ; ",
			       symbol_name(code),
			       objstr);
		    }
		  else
		    {
		      new_note_len += ((notes) ? strlen(notes) : 0) + 4;
		      str = (char *)malloc(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;
  char *newstr, *str;

  errlen = strlen(errstr);
  if ((is_symbol(f)) &&
      (f != car(code)))
    {
      newlen = symbol_name_length(f) + errlen + 10;
      newstr = (char *)malloc(newlen * sizeof(char));
      errlen = snprintf(newstr, newlen, "%s: %s", symbol_name(f), errstr);
    }
  else
    {
      newlen = errlen + 8;
      newstr = (char *)malloc(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 *)malloc(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
    {
      /* send out newstr, pad with spaces to code_max, then notes */
      int len;
      len = snprintf(str, newlen, "%s%s", (as_comment) ? "; " : "", newstr);
      if (notes)
	{
	  int i;
	  for (i = len; i < code_max - 1; i++)
	    str[i] = ' ';
	  str[i] = '\0';
#ifdef __OpenBSD__
	  strlcat(str, notes, newlen);
	  strlcat(str, "\n", newlen);
#else
	  strcat(str, notes);
	  strcat(str, "\n");
#endif
	}
    }
  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; /* (*s7* '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 = outlet(sc->owlet);
	  f = stacktrace_find_caller(sc, cur_env); /* this is a symbol */
	  if ((is_let(cur_env)) &&
	      (cur_env != sc->rootlet))
	    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); /* can code be free here? [hit this once, could not repeat it] */

      if (is_pair(code))
	{
	  char *codestr;
	  codestr = s7_object_to_c_string(sc, code);
	  if (codestr)
	    {
	      if ((!local_strcmp(codestr, "(result)")) &&
		  (!local_strcmp(codestr, "(#f)")) &&
		  (strstr(codestr, "(stacktrace)") == NULL) &&
		  (strstr(codestr, "(stacktrace ") == NULL))
		{
		  s7_pointer e, f;

		  e = stack_let(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_let(e)) && (e != sc->rootlet))
			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 *)malloc(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)
{
  char *str;
  str = stacktrace_1(sc, 30, 45, 80, 45, false);
  return(make_string_uncopied_with_length(sc, str, safe_strlen(str)));
}


static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args)
{
  #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \
a stacktrace as a string.  Each line has two portions, the code being evaluated and a note giving \
the value of local variables in that code.  The first argument sets how many lines are displayed. \
The next three arguments set the length and layout of those lines.  'as-comment' if #t causes each \
line to be preceded by a semicolon."
  #define Q_stacktrace s7_make_signature(sc, 6, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol)

  s7_int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50;
  bool as_comment = false;
  char *str;

  if (!is_null(args))
    {
      if (s7_is_integer(car(args)))
	{
	  max_frames = s7_integer(car(args));
	  if ((max_frames <= 0) || (max_frames > s7_int32_max))
	    max_frames = 30;
	  args = cdr(args);
	  if (!is_null(args))
	    {
	      if (s7_is_integer(car(args)))
		{
		  code_cols = s7_integer(car(args));
		  if ((code_cols <= 8) || (code_cols > s7_int32_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_int32_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_int32_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_symbol, 5, car(args), T_BOOLEAN));
				    }
				}
			      else return(wrong_type_argument(sc, sc->stacktrace_symbol, 4, car(args), T_INTEGER));
			    }
			}
		      else return(wrong_type_argument(sc, sc->stacktrace_symbol, 3, car(args), T_INTEGER));
		    }
		}
	      else return(wrong_type_argument(sc, sc->stacktrace_symbol, 2, car(args), T_INTEGER));
	    }
	}
      else method_or_bust(sc, car(args), sc->stacktrace_symbol, args, T_INTEGER, 1);
    }
  str = stacktrace_1(sc, (int)max_frames, (int)code_cols, (int)total_cols, (int)notes_start_col, as_comment);
  return(make_string_uncopied_with_length(sc, str, safe_strlen(str)));
}



/* -------- error handlers -------- */

static const char *make_type_name(s7_scheme *sc, const char *name, int article)
{
  int i, slen, len;

  slen = safe_strlen(name);
  len = slen + 8;
  if (len > sc->typnam_len)
    {
      if (sc->typnam) free(sc->typnam);
      sc->typnam = (char *)malloc(len * sizeof(char));
      sc->typnam_len = len;
    }
  if (article == INDEFINITE_ARTICLE)
    {
      i = 1;
      sc->typnam[0] = 'a';
      if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u'))
	sc->typnam[i++] = 'n';
      sc->typnam[i++] = ' ';
    }
  else i = 0;
  memcpy((void *)(sc->typnam + i), (void *)name, slen);
  sc->typnam[i + slen] = '\0';
  return(sc->typnam);
}


static const char *type_name_from_type(s7_scheme *sc, int typ, int article)
{
  static const char *frees[2] =          {"free cell",          "a free cell"};
  static const char *nils[2] =           {"nil",                "nil"};
  static const char *uniques[2] =        {"untyped",            "untyped"};
  static const char *booleans[2] =       {"boolean",            "boolean"};
  static const char *strings[2] =        {"string",             "a string"};
  static const char *symbols[2] =        {"symbol",             "a symbol"};
  static const char *syntaxes[2] =       {"syntax",             "syntactic"};
  static const char *pairs[2] =          {"pair",               "a pair"};
  static const char *gotos[2] =          {"goto",               "a goto (from call-with-exit)"};
  static const char *continuations[2] =  {"continuation",       "a continuation"};
  static const char *c_functions[2] =    {"c-function",         "a c-function"};
  static const char *macros[2] =         {"macro",              "a macro"};
  static const char *c_macros[2] =       {"c-macro",            "a c-macro"};
  static const char *bacros[2] =         {"bacro",              "a bacro"};
  static const char *vectors[2] =        {"vector",             "a vector"};
  static const char *int_vectors[2] =    {"int-vector",         "an int-vector"};
  static const char *float_vectors[2] =  {"float-vector",       "a float-vector"};
  static const char *c_pointers[2] =     {"C pointer",          "a raw C pointer"};
  static const char *counters[2] =       {"internal counter",   "an internal counter"};
  static const char *baffles[2] =        {"baffle",             "a baffle"};
  static const char *slots[2] =          {"slot",               "a slot (variable binding)"};
  static const char *characters[2] =     {"character",          "a character"};
  static const char *catches[2] =        {"catch",              "a catch"};
  static const char *dynamic_winds[2] =  {"dynamic-wind",       "a dynamic-wind"};
  static const char *hash_tables[2] =    {"hash-table",         "a hash-table"};
  static const char *iterators[2] =      {"iterator",           "an iterator"};
  static const char *environments[2] =   {"environment",        "an environment"};
  static const char *integers[2] =       {"integer",            "an integer"};
  static const char *big_integers[2] =   {"big integer",        "a big integer"};
  static const char *ratios[2] =         {"ratio",              "a ratio"};
  static const char *big_ratios[2] =     {"big ratio",          "a big ratio"};
  static const char *reals[2] =          {"real",               "a real"};
  static const char *big_reals[2] =      {"big real",           "a big real"};
  static const char *complexes[2] =      {"complex number",     "a complex number"};
  static const char *big_complexes[2] =  {"big complex number", "a big complex number"};
  static const char *functions[2] =      {"function",           "a function"};
  static const char *function_stars[2] = {"function*",          "a function*"};
  static const char *rngs[2] =           {"random-state",       "a random-state"};

  switch (typ)
    {
    case T_FREE:            return(frees[article]);
    case T_NIL:             return(nils[article]);
    case T_UNIQUE:          return(uniques[article]);
    case T_UNSPECIFIED:     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_ANY_ARGS_FUNCTION:
    case T_C_FUNCTION_STAR:
    case T_C_FUNCTION:      return(c_functions[article]);
    case T_CLOSURE:         return(functions[article]);
    case T_CLOSURE_STAR:    return(function_stars[article]);
    case T_C_MACRO:         return(c_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_MACRO_STAR:
    case T_MACRO:           return(macros[article]);
    case T_BACRO_STAR:
    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_ITERATOR:        return(iterators[article]);
    case T_LET:             return(environments[article]);
    case T_COUNTER:         return(counters[article]);
    case T_BAFFLE:          return(baffles[article]);
    case T_RANDOM_STATE:    return(rngs[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)
{
  switch (unchecked_type(arg))
    {
    case T_C_OBJECT:
      return(make_type_name(sc, object_types[c_object_type(arg)]->name, article));

    case T_INPUT_PORT:
      return(make_type_name(sc, (is_file_port(arg)) ? "input file port" : ((is_string_port(arg)) ? "input string port" : "input port"), article));

    case T_OUTPUT_PORT:
      return(make_type_name(sc, (is_file_port(arg)) ? "output file port" : ((is_string_port(arg)) ? "output string port" : "output port"), article));

    case T_LET:
      if (has_methods(arg))
	{
	  s7_pointer class_name;
	  class_name = find_method(sc, arg, sc->class_name_symbol);
	  if (is_symbol(class_name))
	    return(make_type_name(sc, symbol_name(class_name), article));
	}

    default:
      {
	const char *str;
	str = type_name_from_type(sc, unchecked_type(arg), article);
	if (str) return(str);
      }
    }
  return("messed up object");
}


static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x)
{
  s7_pointer p;

  if (has_methods(x))
    {
      p = find_method(sc, find_let(sc, x), sc->class_name_symbol);
      if (is_symbol(p))
	return(symbol_name_cell(p));
    }

  p = prepackaged_type_names[type(x)];
  if (is_string(p)) return(p);

  switch (type(x))
    {
    case T_C_OBJECT:    return(c_object_scheme_name(x));
    case T_INPUT_PORT:  return((is_file_port(x)) ? an_input_file_port_string : ((is_string_port(x)) ? an_input_string_port_string : an_input_port_string));
    case T_OUTPUT_PORT: return((is_file_port(x)) ? an_output_file_port_string : ((is_string_port(x)) ? an_output_string_port_string : an_output_port_string));
    }
  return(make_string_wrapper(sc, "unknown type!"));
}

static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg)
{
  if (type(arg) < NUM_TYPES)
    {
      s7_pointer p;
      p = prepackaged_type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */
      if (is_string(p)) return(p);
    }
  return(make_string_wrapper(sc, type_name(sc, arg, INDEFINITE_ARTICLE)));
}


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)
{
  s7_pointer p;
  p = cdr(sc->wrong_type_arg_info);  /* info list is '(format_string caller arg_n arg type_name descr) */
  set_car(p, caller);  p = cdr(p);
  set_car(p, arg_n);   p = cdr(p);
  set_car(p, arg);     p = cdr(p);
  set_car(p, (typnam == sc->gc_nil) ? prepackaged_type_name(sc, arg) : typnam);
  p = cdr(p);
  set_car(p, descr);
  return(s7_error(sc, sc->wrong_type_arg_symbol, 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)
{
  set_wlist_4(sc, cdr(sc->simple_wrong_type_arg_info), caller, arg, (typnam == sc->gc_nil) ? prepackaged_type_name(sc, arg) : typnam, descr);
  return(s7_error(sc, sc->wrong_type_arg_symbol, 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_string_wrapper(sc, caller),
					    make_integer(sc, arg_n), arg, type_name_string(sc, arg),
					    make_string_wrapper(sc, descr)));
  return(simple_wrong_type_arg_error_prepackaged(sc, make_string_wrapper(sc, caller),
						 arg, type_name_string(sc, arg),
						 make_string_wrapper(sc, descr)));
}


static s7_pointer out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr)
{
  /* info list is '(format_string caller arg_n arg descr) */
  set_wlist_4(sc, cdr(sc->out_of_range_info), caller, arg_n, arg, descr);
  return(s7_error(sc, sc->out_of_range_symbol, sc->out_of_range_info));
}


static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr)
{
  set_wlist_3(sc, cdr(sc->simple_out_of_range_info), caller, arg, descr);
  return(s7_error(sc, sc->out_of_range_symbol, 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_string_wrapper(sc, caller), make_integer(sc, arg_n), arg, make_string_wrapper(sc, descr)));
  return(simple_out_of_range_error_prepackaged(sc, make_string_wrapper(sc, caller), arg, make_string_wrapper(sc, 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_symbol,  set_elist_2(sc, make_string_wrapper(sc, caller), args))); /* "caller" includes the format directives */
}


static s7_pointer division_by_zero_error(s7_scheme *sc, s7_pointer caller, s7_pointer arg)
{
  return(s7_error(sc, sc->division_by_zero_symbol, set_elist_3(sc, sc->division_by_zero_error_string, caller, arg)));
}


static s7_pointer file_error(s7_scheme *sc, const char *caller, const char *descr, const char *name)
{
  return(s7_error(sc, sc->io_error_symbol, 
		  set_elist_4(sc, make_string_wrapper(sc, "~A: ~A ~S"), 
				  make_string_wrapper(sc, caller), 
				  make_string_wrapper(sc, descr), 
				  make_string_wrapper(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_symbol) 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"
  #define Q_dynamic_wind s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->is_procedure_symbol)

  s7_pointer p;

  if (!is_thunk(sc, car(args)))
    method_or_bust_with_type(sc, car(args), sc->dynamic_wind_symbol, args, a_thunk_string, 1);
  if (!is_thunk(sc, cadr(args)))
    method_or_bust_with_type(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2);
  if (!is_thunk(sc, caddr(args)))
    method_or_bust_with_type(sc, caddr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 3);

  /* this won't work:

       (let ((final (lambda (a b c) (list a b c))))
         (dynamic-wind
           (lambda () #f)
           (lambda () (set! final (lambda () (display "in final"))))
           final))

   * but why not?  'final' is a thunk by the time it is evaluated.
   *   catch (the error handler) is similar.
   *
   * It can't work here because we set up the dynamic_wind_out slot below and
   *   even if the thunk check was removed, we'd still be trying to apply the original function.
   */

  new_cell(sc, p, T_DYNAMIC_WIND);                          /* don't mark car/cdr, don't copy */
  dynamic_wind_in(p) = closure_or_f(sc, car(args));
  dynamic_wind_body(p) = cadr(args);
  dynamic_wind_out(p) = closure_or_f(sc, caddr(args));

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


s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish)
{
  /* this is essentially s7_call with a dynamic-wind wrapper around "body" */
  s7_pointer p;
  declare_jump_info();

  sc->temp1 = ((init == sc->F) ? finish : init);
  sc->temp2 = body;

  store_jump_info(sc);
  set_jump_info(sc, DYNAMIC_WIND_SET_JUMP); 
  if (jump_loc != NO_JUMP)
    {
      if (jump_loc != ERROR_JUMP)
	eval(sc, sc->op);
    }
  else
    {
      push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
      sc->args = sc->nil;
      
      new_cell(sc, p, T_DYNAMIC_WIND);
      dynamic_wind_in(p) = _NFre(init);
      dynamic_wind_body(p) = _NFre(body);
      dynamic_wind_out(p) = _NFre(finish);
      push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p);
      if (init != sc->F)
	{
	  dynamic_wind_state(p) = DWIND_INIT;
	  sc->code = init;
	}
      else
	{
	  dynamic_wind_state(p) = DWIND_BODY;
	  sc->code = body;
	}
      eval(sc, OP_APPLY);
    }
  restore_jump_info(sc);

  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
 return(sc->value);
}


static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
{
  #define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called"
  #define Q_catch s7_make_circular_signature(sc, 2, 3, sc->values_symbol, sc->T, sc->is_procedure_symbol)

  s7_pointer p, proc, err;

  /* Guile sets up the catch before looking for arg errors:
   *   (catch #t log (lambda args "hiho")) -> "hiho"
   * which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...)
   */

  proc = cadr(args);
  err = caddr(args);
  /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */

  new_cell(sc, p, T_CATCH);
  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) = err;

  if (is_any_macro(err))
    push_stack(sc, OP_CATCH_2, args, p);
  else push_stack(sc, OP_CATCH, args, p);      /* args ignored but maybe safer for GC? */

  /* not sure about these error checks -- they can be omitted */
  if (!is_thunk(sc, proc))
    return(wrong_type_argument_with_type(sc, sc->catch_symbol, 2, proc, a_thunk_string));

  if (!is_applicable(err))
    return(wrong_type_argument_with_type(sc, sc->catch_symbol, 3, err, something_applicable_string));

  /* should we check here for (aritable? err 2)? -- right now:
   *  (catch #t (lambda () 1) "hiho") -> 1
   * currently this is checked only if the error handler is called
   */

  if (is_closure(proc))                        /* not also lambda* here because we need to handle the arg defaults */
    {
      sc->code = closure_body(proc);
      new_frame(sc, closure_let(proc), sc->envir);
      push_stack(sc, OP_BEGIN_UNCHECKED, sc->args, sc->code);
    }
  else push_stack(sc, OP_APPLY, sc->nil, proc);

  return(sc->F);
}

/* s7_catch(sc, tag, body, error): return(g_catch(sc, list(sc, 3, tag, body, error))) */

/* error reporting info -- save filename and line number */

#define remember_location(Line, File) (((File) << 20) | (Line))
#define remembered_line_number(Line) ((Line) & 0xfffff)
#define remembered_file_name(Line)   ((((Line) >> 20) <= sc->file_names_top) ? sc->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;

  for (i = 0; i <= sc->file_names_top; i++)
    if (safe_strcmp(file, string_value(sc->file_names[i])))
      return(i);

  sc->file_names_top++;
  if (sc->file_names_top >= sc->file_names_size)
    {
      int old_size = 0;
      if (sc->file_names_size == 0)
	{
	  sc->file_names_size = INITIAL_FILE_NAMES_SIZE;
	  sc->file_names = (s7_pointer *)calloc(sc->file_names_size, sizeof(s7_pointer));
	}
      else
	{
	  old_size = sc->file_names_size;
	  sc->file_names_size *= 2;
	  sc->file_names = (s7_pointer *)realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer));
	}
      for (i = old_size; i < sc->file_names_size; i++)
	sc->file_names[i] = sc->F;
    }
  sc->file_names[sc->file_names_top] = s7_make_permanent_string(file);

  return(sc->file_names_top);
}


static s7_pointer init_owlet(s7_scheme *sc)
{
  s7_pointer e;
  e = new_frame_in_env(sc, sc->rootlet);
  sc->temp3 = e;
  sc->error_type = make_slot_1(sc, e, make_symbol(sc, "error-type"), sc->F);  /* the error type or tag ('division-by-zero) */
  sc->error_data = make_slot_1(sc, e, make_symbol(sc, "error-data"), sc->F);  /* the message or information passed by the error function */
  sc->error_code = make_slot_1(sc, e, make_symbol(sc, "error-code"), sc->F);  /* the code that s7 thinks triggered the error */
  sc->error_line = make_slot_1(sc, e, make_symbol(sc, "error-line"), sc->F);  /* the line number of that code */
  sc->error_file = make_slot_1(sc, e, make_symbol(sc, "error-file"), sc->F);  /* the file name of that code */
#if WITH_HISTORY
  sc->error_history = make_slot_1(sc, e, make_symbol(sc, "error-history"), sc->F); /* buffer of previous evaluations */
#endif
  return(e);
}


static s7_pointer g_owlet(s7_scheme *sc, s7_pointer args)
{
#if WITH_HISTORY
  #define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history."
#else
  #define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, and error-file."
#endif
  #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol)
  /* if owlet is not copied, (define e (owlet)), e changes as owlet does!
   */
  s7_pointer e, x;
  int gc_loc;

  e = let_copy(sc, sc->owlet);
  gc_loc = s7_gc_protect(sc, e);

  /* also make sure the pairs are copied: should be error-data, error-code, and possibly error-history */
  for (x = let_slots(e); is_slot(x); x = next_slot(x))
    if (is_pair(slot_value(x)))
      slot_set_value(x, protected_list_copy(sc, slot_value(x)));

  s7_gc_unprotect_at(sc, gc_loc);
  return(e);
}

static s7_pointer c_owlet(s7_scheme *sc) {return(g_owlet(sc, sc->nil));}
PF_0(owlet, c_owlet)


static s7_pointer active_catches(s7_scheme *sc)
{
  int i;
  s7_pointer x, lst;
  lst = sc->nil;
  for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
    switch (stack_op(sc->stack, i))
      {
      case OP_CATCH_ALL:
	lst = cons(sc, sc->T, lst);
	break;

      case OP_CATCH_2:
      case OP_CATCH_1:
      case OP_CATCH:
	x = stack_code(sc->stack, i);
	lst = cons(sc, catch_tag(x), lst);
	break;
      }
  return(reverse_in_place_unchecked(sc, sc->nil, lst));
}

static s7_pointer active_exits(s7_scheme *sc)
{
  /* (call-with-exit (lambda (exiter) (*s7* 'exits))) */
  int i;
  s7_pointer lst;
  lst = sc->nil;
  for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
    if (stack_op(sc->stack, i) == OP_DEACTIVATE_GOTO)
      {
	s7_pointer func, jump;
	func = stack_code(sc->stack, i);  /* presumably this has the goto name */
	jump = stack_args(sc->stack, i);  /* call this to jump */

	if (is_any_closure(func))
	  lst = cons(sc, cons(sc, car(closure_args(func)), jump), lst);
	else
	  {
	    if ((is_pair(func)) && (car(func) == sc->call_with_exit_symbol))
	      lst = cons(sc, cons(sc, car(cadr(cadr(func))), jump), lst); /* (call-with-exit (lambda (three) ...)) */
	    else lst = cons(sc, cons(sc, sc->unspecified, jump), lst);
	  }
	sc->w = lst;
      }
  return(reverse_in_place_unchecked(sc, sc->nil, lst));
}

static s7_pointer stack_entries(s7_scheme *sc, s7_pointer stack, int top)
{
  int i;
  s7_pointer lst;
  lst = sc->nil;
  for (i = top - 1; i >= 3; i -= 4)
    {
      s7_pointer func, args, e;
      opcode_t op;
      func = stack_code(stack, i);
      args = stack_args(stack, i);
      e = stack_let(stack, i);
      op = stack_op(stack, i);
      if ((s7_is_valid(sc, func)) &&
	  (s7_is_valid(sc, args)) &&
	  (s7_is_valid(sc, e)) &&
	  (op < OP_MAX_DEFINED))
	{
#if DEBUGGING
	  if (op < OP_MAX_DEFINED_1)
	    lst = cons(sc, list_4(sc, func, args, e, make_string_wrapper(sc, op_names[op])), lst);
	  else lst = cons(sc, list_4(sc, func, args, e, make_integer(sc, op)), lst);
#else
	  lst = cons(sc, list_4(sc, func, args, e, make_integer(sc, op)), lst);
#endif
	  sc->w = lst;
	}
    }
  return(reverse_in_place_unchecked(sc, sc->nil, lst));
}


/* catch handlers */

typedef bool (*catch_function)(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook);
static catch_function catchers[OP_MAX_DEFINED + 1];

static bool catch_all_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  s7_pointer catcher;
  catcher = stack_let(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);
  return(true);
}

static bool catch_2_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  /* this is the macro-error-handler case from g_catch
   *    (let () (define-macro (m . args) (apply (car args) (cadr args))) (catch #t (lambda () (error abs -1)) m))
   */
  s7_pointer x;
  x = stack_code(sc->stack, i);
  if ((catch_tag(x) == sc->T) ||
      (catch_tag(x) == type) ||
      (type == sc->T))
    {
      int loc;
      loc = catch_goto_loc(x);
      sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(x));
      sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
      sc->code = catch_handler(x);

      set_car(sc->t2_1, type);
      set_car(sc->t2_2, info);
      sc->args = sc->t2_1; /* copied in op_apply? */

      sc->op = OP_APPLY;
      return(true);
    }
  return(false);
}

static bool catch_1_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  s7_pointer x;
  x = stack_code(sc->stack, i);
  if ((catch_tag(x) == sc->T) ||
      (catch_tag(x) == type) ||
      (type == sc->T))
    {
      unsigned int loc;
      opcode_t op;
      s7_pointer catcher, error_func, body;

      op = stack_op(sc->stack, i);
      sc->temp4 = stack_let(sc->stack, i); /* GC protect this, since we're moving the stack top below */
      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 is the args symbol, return (list type info)
       */

      /* if OP_CATCH_1, we deferred making the error handler until it is actually needed */
      if (op == OP_CATCH_1)
	body = cdr(error_func);
      else
	{
	  if (is_closure(error_func))
	    body = closure_body(error_func);
	  else body = NULL;
	}

      if ((body) && (is_null(cdr(body))))
	{
	  s7_pointer y = NULL;
	  body = car(body);
	  if (is_pair(body))
	    {
	      if (car(body) == sc->quote_symbol)
		y = cadr(body);
	      else
		{
		  if ((car(body) == sc->car_symbol) &&
		      (is_pair(error_func)) &&
		      (cadr(body) == car(error_func)))
		    y = type;
		}
	    }
	  else
	    {
	      if (is_symbol(body))
		{
		  if ((is_pair(error_func)) &&
		      (body == car(error_func)))
		    y = list_2(sc, type, info);
		}
	      else y = body;
	    }
	  if (y)
	    {
	      if (loc > 4)
		pop_stack(sc);
	      /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming
	       *   from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE
	       *   to end that call, but it's pushed at the precatch stack end (far beyond the catch loc).
	       *   If we catch an error, catch unwinds to its starting point, and the pop_stack above
	       *   puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE.
	       *   Now we return true, ending up back in eval, because the error handler jumped out of eval,
	       *   back to wherever we were in eval when we hit the error.  eval jumps back to the start
	       *   of its loop, and pops the stack to see what to do next!  So the (loc > 4) at least
	       *   protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval.
	       *   We can't do anything fancy here because we have to unwind the C stack as well as s7's stack.
	       *   s7_eval doesn't know anything about the catches on the stack.  We can't look back for
	       *   OP_EVAL_DONE -- segfault in OP_BEGIN.  Hmmmm.  Perhaps catch should not unwind until the
	       *   end?  But we want the error handler to run as a part of the calling expression, and
	       *   in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case).
	       */
	      sc->value = y;
	      sc->temp4 = sc->nil;
	      return(true);
	    }
	}
      if (op == OP_CATCH_1)
	{
	  s7_pointer y = NULL;
	  make_closure_without_capture(sc, y, car(error_func), cdr(error_func), sc->temp4);
	  sc->code = y;
	}
      else sc->code = error_func;
      sc->temp4 = sc->nil;

      /* 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 (!s7_is_aritable(sc, sc->code, 2))
	{
	  s7_wrong_number_of_args_error(sc, "catch error handler should accept 2 args: ~S", sc->code);
	  return(false);
	}

      /* since make_closure_with_let sets needs_copied_args and we're going to OP_APPLY,
       *   we don't need a new list here.
       */
      set_car(sc->t2_1, type);
      set_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
       */
      return(true);
    }
  return(false);
}

static bool catch_dw_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  s7_pointer x;
  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->code = dynamic_wind_out(x);
	  sc->args = sc->nil;
	  eval(sc, OP_APPLY);                  /* I guess this means no call/cc out of the exit thunk in an error-catching context */
	}
    }
  return(false);
}

static bool catch_out_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  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;
  return(false);
}

static bool catch_in_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  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 */
  return(false);
}

static bool catch_read_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  pop_input_port(sc);
  return(false);
}

static bool catch_eval_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  s7_close_input_port(sc, sc->input_port);
  pop_input_port(sc);
  return(false);
}

static bool catch_barrier_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  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));
    }
  return(false);
}

static bool catch_hook_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  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*! */
  return(false);
}

static bool catch_goto_function(s7_scheme *sc, int i, s7_pointer type, s7_pointer info, bool *reset_hook)
{
  call_exit_active(stack_args(sc->stack, i)) = false;
  return(false);
}

static void init_catchers(void)
{
  int i;
  for (i = 0; i <= OP_MAX_DEFINED; i++) catchers[i] = NULL;
  catchers[OP_CATCH_ALL] =           catch_all_function;
  catchers[OP_CATCH_2] =             catch_2_function;
  catchers[OP_CATCH_1] =             catch_1_function;
  catchers[OP_CATCH] =               catch_1_function;
  catchers[OP_DYNAMIC_WIND] =        catch_dw_function;
  catchers[OP_GET_OUTPUT_STRING_1] = catch_out_function;
  catchers[OP_UNWIND_OUTPUT] =       catch_out_function;
  catchers[OP_UNWIND_INPUT] =        catch_in_function;
  catchers[OP_READ_DONE] =           catch_read_function;      /* perhaps an error during (read) */
  catchers[OP_EVAL_STRING_1] =       catch_eval_function;      /* perhaps an error happened before we could push the OP_EVAL_STRING_2 */
  catchers[OP_EVAL_STRING_2] =       catch_eval_function;
  catchers[OP_BARRIER] =             catch_barrier_function;
  catchers[OP_DEACTIVATE_GOTO] =     catch_goto_function;
  catchers[OP_ERROR_HOOK_QUIT] =     catch_hook_function;
}

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 owlet. \
It looks for an existing catch with a matching tag, and jumps to it if found.  Otherwise it raises an error."
  #define Q_throw pcl_t

  bool ignored_flag = false;
  int i;
  s7_pointer type, info;

  type = car(args);
  info = cdr(args);
  /* look for a catcher */

  for (i = s7_stack_top(sc) - 1; i >= 3; i -= 4)
    {
      catch_function catcher;
      catcher = catchers[stack_op(sc->stack, i)];
      if ((catcher) &&
	  (catcher(sc, i, type, info, &ignored_flag)))
	{
	  if (sc->longjmp_ok) longjmp(sc->goto_start, THROW_JUMP);
	  return(sc->value);
	}
    }
  if (is_let(car(args))) check_method(sc, car(args), sc->throw_symbol, args);
  return(s7_error(sc, make_symbol(sc, "uncaught-throw"), 
		  set_elist_3(sc, make_string_wrapper(sc, "no catch found for (throw ~W~{~^ ~S~~})"), type, info)));
}


static void s7_warn(s7_scheme *sc, int len, const char *ctrl, ...)
{
  va_list ap;
  char *str;

  str = (char *)malloc(len * sizeof(char));
  va_start(ap, ctrl);
  len = vsnprintf(str, len, ctrl, ap);
  va_end(ap);

  if (port_is_closed(sc->error_port))
    sc->error_port = sc->standard_error;
  s7_display(sc, make_string_uncopied_with_length(sc, str, len), sc->error_port);
}


s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
{
  static int last_line = -1;
  bool reset_error_hook = false;
  s7_pointer cur_code;

  /* type is a symbol normally, and info is compatible with format: (apply format #f info) --
   *    car(info) is the control string, cdr(info) its args
   *    type/range errors have cadr(info)=caller, caddr(info)=offending arg number
   *    null info can mean symbol table is locked so make-symbol uses s7_error to get out
   *
   * set up (owlet), 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.
   */
  sc->no_values = 0;
  sc->format_depth = -1;
  sc->gc_off = false;            /* this is in case we were triggered from the sort function -- clumsy! */
  s7_xf_clear(sc);

  slot_set_value(sc->error_type, type);
  slot_set_value(sc->error_data, info);

#if DEBUGGING
  if (!is_let(sc->owlet)) 
    fprintf(stderr, "owlet clobbered!\n");
#endif
  if ((unchecked_type(sc->envir) != T_LET) &&
      (sc->envir != sc->nil))
    sc->envir = sc->nil;          /* in reader, the envir frame is mostly ignored so it can be (and usually is) garbage */

  set_outlet(sc->owlet, sc->envir);

  cur_code = current_code(sc);
  slot_set_value(sc->error_code, cur_code);
#if WITH_HISTORY
  slot_set_value(sc->error_history, sc->cur_code);
  if (sc->using_history1)
    sc->cur_code = sc->eval_history2;
  else sc->cur_code = sc->eval_history1;
  sc->using_history1 = (!sc->using_history1);
#endif

  if ((is_pair(cur_code)) &&     /* can be () if unexpected close paren read error */
      (has_line_number(cur_code)))
    {
      int line;
      line = (int)pair_line(cur_code); /* cast to int (from unsigned int) for last_line */
      if (line != last_line)
	{
	  last_line = line;
	  if (line > 0)
	    {
	      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);
    }

  { /* look for a catcher */
    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)
      {
	catch_function catcher;
	catcher = catchers[stack_op(sc->stack, i)];
	/* fprintf(stderr, "catching %s %s\n", DISPLAY(type), DISPLAY(info)); */
	if ((catcher) &&
	    (catcher(sc, i, type, info, &reset_error_hook)))
	  {
	    if (sc->longjmp_ok) longjmp(sc->goto_start, CATCH_JUMP);
	    /* all the rest of the code expects s7_error to jump, not return, 
	     *   so presumably if we get here, we're in trouble -- try to send out an error message
	     */
	    /* return(type); */
	    /* fprintf(stderr, "falling through now\n"); */
	  }
      }
  }

  /* error not caught */
  /* (set! *error-hook* (list (lambda (hook) (apply format #t (hook 'args))))) */

  if ((!reset_error_hook) &&
      (is_procedure(sc->error_hook)) &&
      (hook_has_functions(sc->error_hook)))
    {
      s7_pointer error_hook_func;
      /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */

      error_hook_func = 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_hook_func); /* restore *error-hook* upon successful (or any!) evaluation */
      sc->args = list_2(sc, type, info);
      sc->code = error_hook_func;

      /* 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 (port_is_closed(sc->error_port))
	sc->error_port = sc->standard_error;
      /* if info is not a list, send object->string to current error port,
       *   else assume car(info) is a format control string, and cdr(info) are its args
       *
       * if at all possible, get some indication of where we are!
       */
      if ((!s7_is_list(sc, info)) ||
	  (!is_string(car(info))))
	format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), NULL, false, 7);
      else
	{
	  int len = 0;
	  bool use_format = false;

	  /* it's possible that the error string is just a string -- not intended for format */
	  if (type != sc->format_error_symbol)          /* avoid an infinite loop of format errors */
	    {
	      int i;
	      const char *carstr;
	      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;
	      tmpbuf_malloc(errstr, len);
	      str_len = snprintf(errstr, len, "\n;%s", string_value(car(info)));
	      format_to_port(sc, sc->error_port, errstr, cdr(info), NULL, false, str_len);
	      tmpbuf_free(errstr, len);
	    }
	  else format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_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, sc->error_port, "\n;  ~A[~D]", set_plist_2(sc, make_string_wrapper(sc, filename), make_integer(sc, line)), NULL, false, 10);
	  else
	    {
	      if ((line > 0) &&
		  (slot_value(sc->error_line) != sc->F))
		format_to_port(sc, sc->error_port, "\n;  line ~D", set_plist_1(sc, make_integer(sc, line)), NULL, false, 11);
	      else
		{
		  if (is_pair(sc->input_port_stack))
		    {
		      s7_pointer p;
		      p = car(sc->input_port_stack);
		      if ((is_input_port(p)) &&
			  (port_file(p) != stdin) &&
			  (!port_is_closed(p)))
			{
			  filename = port_filename(p);
			  line = port_line_number(p);
			  if (filename)
			    format_to_port(sc, sc->error_port, "\n;  ~A[~D]", 
					   set_plist_2(sc, make_string_wrapper(sc, filename), make_integer(sc, line)), NULL, false, 10);
			}
		    }
		}
	    }
	}
      else
	{
	  const char *call_name;
	  call_name = sc->s7_call_name;

	  /* sc->s7_call_name = NULL; */
	  if (call_name)
	    {
	      sc->s7_call_name = NULL;
	      if ((sc->s7_call_file != NULL) &&
		  (sc->s7_call_line >= 0))
		{
		  format_to_port(sc, sc->error_port, "\n;  ~A ~A[~D]",
				 set_plist_3(sc,
					     make_string_wrapper(sc, call_name),
					     make_string_wrapper(sc, sc->s7_call_file),
					     make_integer(sc, sc->s7_call_line)),
				 NULL, false, 13);
		}
	    }
	}
      s7_newline(sc, sc->error_port);

      if (is_string(slot_value(sc->error_file)))
	{
	  format_to_port(sc, sc->error_port, ";    ~S, line ~D",
			 set_plist_2(sc, slot_value(sc->error_file),	slot_value(sc->error_line)),
			 NULL, false, 16);
	  s7_newline(sc, sc->error_port);
	}

      /* look for __func__ in the error environment etc */
      if (sc->error_port != sc->F)
	{
	  char *errstr;
	  errstr = stacktrace_1(sc,
				s7_integer(car(sc->stacktrace_defaults)),
				s7_integer(cadr(sc->stacktrace_defaults)),
				s7_integer(caddr(sc->stacktrace_defaults)),
				s7_integer(cadddr(sc->stacktrace_defaults)),
				s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)));
	  if (errstr)
	    {
	      port_write_string(sc->error_port)(sc, ";\n", 2, sc->error_port);
	      port_write_string(sc->error_port)(sc, errstr, strlen(errstr), sc->error_port);
	      free(errstr);
	      port_write_character(sc->error_port)(sc, '\n', sc->error_port);
	    }
	}
      else
	{
	  if (is_pair(slot_value(sc->error_code)))
	    {
	      format_to_port(sc, sc->error_port, ";    ~S", set_plist_1(sc, slot_value(sc->error_code)), NULL, false, 7);
	      s7_newline(sc, sc->error_port);
	    }
	}

      /* if (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, ERROR_JUMP);
  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_symbol, set_elist_2(sc, make_string_wrapper_with_length(sc, "attempt to apply nil to ~S?", 27), args)));
  if (!errstr)
    errstr = s7_make_permanent_string("attempt to apply ~A ~S to ~S?");
  return(s7_error(sc, sc->syntax_error_symbol, set_elist_4(sc, errstr, type_name_string(sc, obj), obj, args)));
}


static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_error)
{
  /* 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;

  /* fprintf(stderr, "read error: %s\n", errmsg); */
  pt = sc->input_port;
  if (!string_error)
    {
      /* 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_position(pt) >= port_data_size(pt))
	    port_position(pt) = port_data_size(pt) - 1;

	  /* start at current position and look back a few chars */
	  for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++)
	    if ((port_data(pt)[i] == '\0') ||
		(port_data(pt)[i] == '\n') ||
		(port_data(pt)[i] == '\r'))
	      break;
	  start = i;

	  /* start at current position and look ahead a few chars */
	  for (i = port_position(pt), j = 0; (i < port_data_size(pt)) && (j < QUOTE_SIZE); i++, j++)
	    if ((port_data(pt)[i] == '\0') ||
		(port_data(pt)[i] == '\n') ||
		(port_data(pt)[i] == '\r'))
	      break;

	  end = i;
	  slen = end - start;
	  /* hopefully this is more or less the current line where the read error happened */

	  if (slen > 0)
	    {
	      recent_input = (char *)calloc((slen + 9), 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_data(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[%u], 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_symbol, set_elist_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) + 128;
      msg = (char *)malloc(len * sizeof(char));

      if (string_error)
	len = snprintf(msg, len, "%s %s[%u],\n;  possible culprit: \"%s...\"\n;  last top-level form at %s[%d]",
		       errmsg, port_filename(pt), port_line_number(pt),
		       sc->strbuf, sc->current_file, sc->current_line);
      else len = snprintf(msg, len, "%s %s[%u], 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_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
    }

  return(s7_error(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, (char *)errmsg))));
}

static s7_pointer read_error(s7_scheme *sc, const char *errmsg)
{
  return(read_error_1(sc, errmsg, false));
}

static s7_pointer string_read_error(s7_scheme *sc, const char *errmsg)
{
  return(read_error_1(sc, errmsg, true));
}


static s7_pointer g_error(s7_scheme *sc, s7_pointer args)
{
  #define H_error "(error type ...) signals an error.  The 'type' can be used with catch to trap \
particular errors.  If the error is not caught, s7 treats the second argument as a format control string, \
and applies it to the rest of the arguments."
  #define Q_error pcl_t

  if (is_not_null(args))
    {
      if (is_string(car(args)))                    /* CL-style error? -- use tag = 'no-catch */
	{
	  s7_error(sc, sc->no_catch_symbol, args);        /* this can have trailing args (implicit format) */
	  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)
{
  unsigned char *f;
  f = (unsigned char *)form;

  if (use_write != USE_DISPLAY)
    {
      /* I guess we need to protect the outer double quotes in this case */
      int i;
      for (i = len - 5; i >= (len / 2); i--)
	if (is_white_space((int)f[i]))
	  {
	    form[i] = '.';
	    form[i + 1] = '.';
	    form[i + 2] = '.';
	    form[i + 3] = '"';
	    form[i + 4] = '\0';
	    (*form_len) = i + 4;
	    return(form);
	  }
      i = len - 5;
      if (i > 0)
	{
	  form[i] = '.';
	  form[i + 1] = '.';
	  form[i + 2] = '.';
	  form[i + 3] = '"';
	  form[i + 4] = '\0';
	}
      else
	{
	  if (len >= 2)
	    {
	      form[len - 1] = '"';
	      form[len] = '\0';
	    }
	}
    }
  else
    {
      int i;
      for (i = len - 4; i >= (len / 2); i--)
	if (is_white_space((int)f[i]))
	  {
	    form[i] = '.';
	    form[i + 1] = '.';
	    form[i + 2] = '.';
	    form[i + 3] = '\0';
	    (*form_len) = i + 3;
	    return(form);
	  }
      i = len - 4;
      if (i >= 0)
	{
	  form[i] = '.';
	  form[i + 1] = '.';
	  form[i + 2] = '.';
	  form[i + 3] = '\0';
	}
      else form[len] = '\0';
    }
  return(form);
}


static 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 s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, unsigned int line)
{
  s7_pointer tp;
  if (!is_pair(p)) return(NULL);
  if (has_line_number(p))
    {
      unsigned int x;
      x = (unsigned int)remembered_line_number(pair_line(p));
      if (x > 0)
	{
	  if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */
	    line = x;
	  else
	    {
	      if (x < line)
		return(p);
	    }
	}
    }
  tp = tree_descend(sc, car(p), line);
  if (tp) return(tp);
  return(tree_descend(sc, cdr(p), line));
}

static char *current_input_string(s7_scheme *sc, s7_pointer pt)
{
  /* try to show the current input */
  if ((is_input_port(pt)) &&
      (!port_is_closed(pt)) &&
      (port_data(pt)) &&
      (port_position(pt) > 0))
    {
      const unsigned char *str;
      char *msg;
      int i, j, start;
      start = (int)port_position(pt) - 40;
      if (start < 0) start = 0;
      msg = (char *)malloc(64 * sizeof(char));
      str = (const unsigned char *)port_data(pt);
      for (i = start, j = 0; i < (int)port_position(pt); i++, j++)
	msg[j] = str[i];
      msg[j] = '\0';
      return(msg);
    }
  return(NULL);
}


static s7_pointer missing_close_paren_error(s7_scheme *sc)
{
  int len;
  char *msg, *syntax_msg = NULL;
  s7_pointer pt;

  if ((unchecked_type(sc->envir) != T_LET) &&
      (sc->envir != sc->nil))
    sc->envir = sc->nil;

  pt = sc->input_port;

  /* check *missing-close-paren-hook* */
  if (hook_has_functions(sc->missing_close_paren_hook))
    {
      s7_pointer result;
      if ((port_line_number(pt) > 0) &&
	  (port_filename(pt)))
	{
	  slot_set_value(sc->error_line, make_integer(sc, port_line_number(pt)));
	  slot_set_value(sc->error_file, make_string_wrapper(sc, port_filename(pt)));
	}
      result = s7_call(sc, sc->missing_close_paren_hook, sc->nil);
      if (result != sc->unspecified)
	return(g_throw(sc, list_1(sc, result)));
    }

  if (is_pair(sc->args))
    {
      s7_pointer p;
      p = tree_descend(sc, sc->args, 0);
      if ((p) && (is_pair(p)) &&
	  (has_line_number(p)))
	{
	  int msg_len, form_len;
	  char *form;
	  form = object_to_truncated_string(sc, p, 40);
	  form_len = safe_strlen(form);
	  msg_len = form_len + 128;
	  syntax_msg = (char *)malloc(msg_len * sizeof(char));
	  snprintf(syntax_msg, msg_len, ";  current form awaiting a close paren starts around line %u: %s", remembered_line_number(pair_line(p)), form);
	  free(form);
	}
    }

  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[%u], 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[%u], 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_symbol, set_elist_1(sc, 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_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
    }

  {
    char *str;
    msg = (char *)malloc(128 * sizeof(char));
    str = current_input_string(sc, pt);
    len = snprintf(msg, 128, "missing close paren: %s", str);
    free(str);
    return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
  }

  return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(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_symbol, set_elist_1(sc, make_string_wrapper(sc, "function call is a dotted list?")));
  else s7_error(sc, sc->syntax_error_symbol,
		set_elist_2(sc, make_string_wrapper(sc, "improper list of arguments: ~S"),
				append_in_place(sc, sc->args = 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 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 (owlet) in case we were interrupted and need to see why something was hung */
      slot_set_value(sc->error_type, sc->F);
      slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */
      slot_set_value(sc->error_code, current_code(sc));
      slot_set_value(sc->error_line, sc->F);
      slot_set_value(sc->error_file, sc->F);
#if WITH_HISTORY
      slot_set_value(sc->error_history, sc->F);
#endif
      set_outlet(sc->owlet, 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 */
  return(false);
}

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 = cdr(d);
      set_cdr(p, cons(sc, car(d), cdr(d)));
      if (is_not_null(cdr(d)))
	p = cdr(p);
    }
  set_cdr(p, car(cdr(p)));
  return(q);
}

static s7_pointer apply_list_error(s7_scheme *sc, s7_pointer lst)
{
  return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "apply's last argument should be a proper list: ~S"), lst)));
}

static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
{
  #define H_apply "(apply func ...) applies func to the rest of the arguments"
  #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, sc->is_procedure_symbol, sc->T)

  /* can apply always be replaced with apply values?
   *   (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3)))
   * not if apply* in disguise, I think:
   *   (apply + 1 2 ()) -> 3
   *   (apply + 1 2 (apply values ())) -> error
   */
  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(apply_list_error(sc, args));
	  set_cdr(q, car(p));
	  /* this would work: if (is_c_function(sc->code)) return(c_function_call(sc->code)(sc, cdr(args)));
	   *   but it omits the arg number check
	   */
	  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(apply_list_error(sc, args));
	}
    }

  push_stack(sc, OP_APPLY, sc->args, sc->code);
  return(sc->nil);
}

s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
{
#if DEBUGGING
  {
    s7_pointer p;
    int argnum;
    _NFre(fnc);
    for (argnum = 0, p = _NFre(args); is_pair(p); argnum++, p = _NFre(cdr(p)))
      _NFre(car(p));
  }
#endif

  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);
  /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = c_call(...) where the c_call
   *   happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally.
   */
  return(sc->value);
}


s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e)
{
  declare_jump_info();
#if DEBUGGING
  _NFre(code);
#endif

  store_jump_info(sc);
  set_jump_info(sc, EVAL_SET_JUMP);
  if (jump_loc != NO_JUMP)
    {
      if (jump_loc != ERROR_JUMP)
	eval(sc, sc->op);
    }
  else 
    {
      push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
      sc->code = code;
      if ((e != sc->rootlet) &&
	  (is_let(e)))
	sc->envir = e;
      else sc->envir = sc->nil; 
      eval(sc, OP_EVAL);
    }
  restore_jump_info(sc);

  if (is_multiple_value(sc->value))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
  return(sc->value);
}


static s7_pointer g_eval(s7_scheme *sc, s7_pointer args)
{
  #define H_eval "(eval code (env (curlet))) evaluates code in the environment env. 'env' \
defaults to the curlet; to evaluate something in the top-level environment instead, \
pass (rootlet):\n\
\n\
  (define x 32) \n\
  (let ((x 3))\n\
    (eval 'x (rootlet)))\n\
\n\
  returns 32"
  #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol)

  if (is_not_null(cdr(args)))
    {
      s7_pointer e;
      e = cadr(args);
      if (!is_let(e))
	return(wrong_type_argument_with_type(sc, sc->eval_symbol, 2, e, a_let_string));
      if (e == sc->rootlet)
	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)
{
  /* fprintf(stderr, "%s %s\n", DISPLAY(func), DISPLAY(args)); */
  declare_jump_info();

  if (is_c_function(func))
    return(c_function_call(func)(sc, _NFre(args)));  /* no check for wrong-number-of-args -- is that reasonable? */

  sc->temp1 = _NFre(func); /* this is feeble GC protection */
  sc->temp2 = _NFre(args);

  store_jump_info(sc);
  set_jump_info(sc, S7_CALL_SET_JUMP);
  if (jump_loc != NO_JUMP)
    {
      if (jump_loc != ERROR_JUMP)
	eval(sc, sc->op);

      if ((jump_loc == CATCH_JUMP) &&        /* we're returning (back to eval) from an error in catch */
	  (sc->stack_end == sc->stack_start))
	push_stack(sc, OP_ERROR_QUIT, sc->nil, sc->nil);
    }
  else
    {
#if DEBUGGING
      {
	s7_pointer p;
	int argnum;
	/* incoming args may be non-s7 cells -- check now before they reach the GC */
	for (argnum = 0, p = _NFre(args); is_pair(p); argnum++, p = _NFre(cdr(p)))
	  _NFre(car(p));
      }
#endif
      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);
    }
  restore_jump_info(sc);

  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 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)
   * it should be (((lambda (arg) arg) "hi") 0) -> #\h
   *
   * this applies to non-homogeneous cases, so float|int-vectors don't get here
   */

  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)))
	{
	  if (is_byte_vector(obj))       /* ((vector (byte-vector 1)) 0 0) */
	    return(small_int((unsigned int)(character(string_ref_1(sc, obj, car(indices))))));
	  return(string_ref_1(sc, obj, car(indices)));
	}
      return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, 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:
      return((*(c_object_ref(obj)))(sc, obj, indices));

    case T_LET:
      obj = s7_let_ref(sc, obj, car(indices));
      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)));
    }
}

/* -------------------------------- s7-version -------------------------------- */
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"
  #define Q_s7_version pcl_s
  return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE));
}


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

/* -------------------------------- exit -------------------------------- */
static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args)
{
  #define H_emergency_exit "(emergency-exit obj) exits s7 immediately"
  #define Q_emergency_exit pcl_t

  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"
  #define Q_exit pcl_t

  s7_quit(sc);
  return(g_emergency_exit(sc, args));
}


#if DEBUGGING
static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort();}
#endif



static s7_function all_x_function[OPT_MAX_DEFINED];
#define is_all_x_op(Op) (all_x_function[Op] != NULL)

static bool is_all_x_safe(s7_scheme *sc, s7_pointer p)
{
  return((!is_pair(p)) ||
	 ((car(p) == sc->quote_symbol) && (is_pair(cdr(p)))) ||          /* (if #t (quote . -1)) */
	 ((is_optimized(p)) && (is_all_x_op(optimize_op(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_optimized(car(p))) &&
	(is_all_x_op(optimize_op(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(find_symbol_checked(sc, arg));}
static s7_pointer all_x_u(s7_scheme *sc, s7_pointer arg)    {return(find_symbol_unchecked(sc, arg));}
static s7_pointer all_x_k(s7_scheme *sc, s7_pointer arg)    {return(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_add1(s7_scheme *sc, s7_pointer arg)  
{
  s7_pointer x;
  x = find_symbol_unchecked(sc, cadr(arg));
  if (is_integer(x))
    return(make_integer(sc, integer(x) + 1));
  return(g_add_s1_1(sc, x, arg));
}

static s7_pointer all_x_c_addi(s7_scheme *sc, s7_pointer arg)  
{
  s7_pointer x;
  x = find_symbol_unchecked(sc, cadr(arg));
  if (is_integer(x))
    return(make_integer(sc, integer(x) + integer(caddr(arg))));
  return(g_add_2(sc, set_plist_2(sc, x, caddr(arg))));
}

static s7_pointer all_x_c_char_eq(s7_scheme *sc, s7_pointer arg)  
{
  s7_pointer c;
  c = find_symbol_unchecked(sc, cadr(arg));
  if (c == caddr(arg))
    return(sc->T);
  if (s7_is_character(c))
    return(sc->F);
  method_or_bust(sc, c, sc->char_eq_symbol, set_plist_2(sc, c, caddr(arg)), T_CHARACTER, 1);
}

static s7_pointer all_x_c_q(s7_scheme *sc, s7_pointer arg)
{
  set_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)
{
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(arg)));
  return(c_call(arg)(sc, sc->t1_1));
}

static s7_pointer all_x_c_u(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t1_1, find_symbol_unchecked(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 = find_symbol_checked(sc, cadr(arg));
  return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val)));
}

static s7_pointer all_x_cdr_u(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer val;
  val = find_symbol_unchecked(sc, cadr(arg));
  return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val)));
}

static s7_pointer all_x_car_s(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer val;
  val = find_symbol_checked(sc, cadr(arg));
  return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val)));
}

static s7_pointer all_x_null_s(s7_scheme *sc, s7_pointer arg)
{
  return(make_boolean(sc, is_null(find_symbol_checked(sc, cadr(arg)))));
}

static s7_pointer all_x_c_sc(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t2_2, caddr(arg));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_uc(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(arg)));
  set_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)
{
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
  set_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)
{
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_uu(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(arg)));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_sss(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_3, find_symbol_checked(sc, cadddr(arg)));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_uuu(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_1, find_symbol_unchecked(sc, cadr(arg)));
  set_car(sc->t3_2, find_symbol_unchecked(sc, caddr(arg)));
  set_car(sc->t3_3, find_symbol_unchecked(sc, cadddr(arg)));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_scs(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_3, find_symbol_checked(sc, cadddr(arg)));
  set_car(sc->t3_2, caddr(arg));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_css(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_3, find_symbol_checked(sc, cadddr(arg)));
  set_car(sc->t3_1, cadr(arg));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_csc(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_1, cadr(arg));
  set_car(sc->t3_3, cadddr(arg));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_ssc(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_3, cadddr(arg));
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_sq(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t2_2, cadr(caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opcq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_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);
  set_car(sc->t2_2, c_call(largs)(sc, cdr(largs)));
  set_car(sc->t2_1, find_symbol_checked(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);
  set_car(sc->t2_2, c_call(largs)(sc, cdr(largs)));
  set_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);
  set_car(sc->t2_1, c_call(largs)(sc, cdr(largs)));
  set_car(sc->t2_2, find_symbol_checked(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);
  set_car(sc->t2_1, c_call(largs)(sc, cdr(largs)));
  set_car(sc->t2_2, caddr(arg));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opcq_opcq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, c_call(largs)(sc, cdr(largs)));
  largs = caddr(arg);
  set_car(sc->t2_2, c_call(largs)(sc, cdr(largs)));
  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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_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_not_opsq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  if (c_call(largs)(sc, sc->t1_1) == sc->F)
    return(sc->T);
  return(sc->F);
}

static s7_pointer all_x_c_opuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(largs)));
  set_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_not_opuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(largs)));
  if (c_call(largs)(sc, sc->t1_1) == sc->F)
    return(sc->T);
  return(sc->F);
}

static s7_pointer all_x_c_opssq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(largs)));
  set_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_opuuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(largs)));
  set_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_opscq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, caddr(largs));
  set_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_opsqq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, cadr(caddr(largs)));
  set_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);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opuuq_u(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opssq_c(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_2, 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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opuq_u(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cadr(arg);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_2, find_symbol_unchecked(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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_1, c_call(largs)(sc, sc->t1_1));
  set_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);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_u_opuuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_1, find_symbol_unchecked(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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_u_opuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = caddr(arg);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_1, find_symbol_unchecked(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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t1_1));
  set_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);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(car(largs))));
  sc->temp3 = c_call(car(largs))(sc, sc->t1_1);
  largs = cadr(largs);
  set_car(sc->t1_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_1, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opuq_opuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cdr(arg);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(car(largs))));
  sc->temp3 = c_call(car(largs))(sc, sc->t1_1);
  largs = cadr(largs);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t1_1));
  set_car(sc->t2_1, sc->temp3);
  sc->temp3 = sc->nil;
  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);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(largs))));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(car(largs))));
  sc->temp3 = c_call(car(largs))(sc, sc->t2_1);
  largs = cadr(largs);
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_1, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_opuuq_opuuq(s7_scheme *sc, s7_pointer arg)
{
  s7_pointer largs;
  largs = cdr(arg);
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(car(largs))));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(car(largs))));
  sc->temp3 = c_call(car(largs))(sc, sc->t2_1);
  largs = cadr(largs);
  set_car(sc->t2_1, find_symbol_unchecked(sc, cadr(largs)));
  set_car(sc->t2_2, find_symbol_unchecked(sc, caddr(largs)));
  set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
  set_car(sc->t2_1, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t2_1));
}

static s7_pointer all_x_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code)
{
  s7_pointer arg;
  arg = cadr(cadr(code));
  set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t1_1, c_call(arg)(sc, sc->t2_1));
  set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1));
  set_car(sc->t2_2, caddr(code));
  return(c_call(code)(sc, sc->t2_1));
}

static s7_pointer all_x_c_a(s7_scheme *sc, s7_pointer arg)
{
  set_car(sc->t1_1, c_call(cdr(arg))(sc, cadr(arg))); 
  return(c_call(arg)(sc, sc->t1_1));
}

static s7_pointer all_x_c_ssa(s7_scheme *sc, s7_pointer arg)
{
  sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_3, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_sas(s7_scheme *sc, s7_pointer arg)
{
  sc->temp3 = c_call(cddr(arg))(sc, caddr(arg));
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_3, find_symbol_checked(sc, cadddr(arg)));
  set_car(sc->t3_2, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_sca(s7_scheme *sc, s7_pointer arg)
{
  sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
  set_car(sc->t3_1, find_symbol_checked(sc, cadr(arg)));
  set_car(sc->t3_2, caddr(arg));
  set_car(sc->t3_3, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_csa(s7_scheme *sc, s7_pointer arg)
{
  sc->temp3 = c_call(cdddr(arg))(sc, cadddr(arg));
  set_car(sc->t3_1, cadr(arg));
  set_car(sc->t3_2, find_symbol_checked(sc, caddr(arg)));
  set_car(sc->t3_3, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t3_1));
}

static s7_pointer all_x_c_cas(s7_scheme *sc, s7_pointer arg)
{
  sc->temp3 = c_call(cddr(arg))(sc, caddr(arg));
  set_car(sc->t3_1, cadr(arg));
  set_car(sc->t3_3, find_symbol_checked(sc, cadddr(arg)));
  set_car(sc->t3_2, sc->temp3);
  sc->temp3 = sc->nil;
  return(c_call(arg)(sc, sc->t3_1));
}

static void all_x_function_init(void)
{
  int i;
  for (i = 0; i < OPT_MAX_DEFINED; i++)
    all_x_function[i] = NULL;

  all_x_function[HOP_SAFE_C_C] = all_x_c_c;
  all_x_function[HOP_SAFE_C_Q] = all_x_c_q;
  all_x_function[HOP_SAFE_C_A] = all_x_c_a;
  all_x_function[HOP_SAFE_C_S] = all_x_c_s;

  all_x_function[HOP_SAFE_C_opCq] = all_x_c_opcq;
  all_x_function[HOP_SAFE_C_opSq] = all_x_c_opsq;
  all_x_function[HOP_SAFE_C_opSSq] = all_x_c_opssq;
  all_x_function[HOP_SAFE_C_opSCq] = all_x_c_opscq;
  all_x_function[HOP_SAFE_C_opSQq] = all_x_c_opsqq;

  all_x_function[HOP_SAFE_C_SC] = all_x_c_sc;
  all_x_function[HOP_SAFE_C_CS] = all_x_c_cs;
  all_x_function[HOP_SAFE_C_SQ] = all_x_c_sq;
  all_x_function[HOP_SAFE_C_SS] = all_x_c_ss;

  all_x_function[HOP_SAFE_C_opSq_S] = all_x_c_opsq_s;
  all_x_function[HOP_SAFE_C_opSq_C] = all_x_c_opsq_c;
  all_x_function[HOP_SAFE_C_S_opSq] = all_x_c_s_opsq;
  all_x_function[HOP_SAFE_C_S_opCq] = all_x_c_s_opcq;
  all_x_function[HOP_SAFE_C_opCq_S] = all_x_c_opcq_s;
  all_x_function[HOP_SAFE_C_opCq_C] = all_x_c_opcq_c;
  all_x_function[HOP_SAFE_C_C_opSq] = all_x_c_c_opsq;
  all_x_function[HOP_SAFE_C_C_opCq] = all_x_c_c_opcq;
  all_x_function[HOP_SAFE_C_opSSq_C] = all_x_c_opssq_c;
  all_x_function[HOP_SAFE_C_opSSq_S] = all_x_c_opssq_s;
  all_x_function[HOP_SAFE_C_S_opSSq] = all_x_c_s_opssq;
  all_x_function[HOP_SAFE_C_opSq_opSq] = all_x_c_opsq_opsq;
  all_x_function[HOP_SAFE_C_opCq_opCq] = all_x_c_opcq_opcq;
  all_x_function[HOP_SAFE_C_opSSq_opSSq] = all_x_c_opssq_opssq;
  all_x_function[HOP_SAFE_C_op_opSSq_q_C] = all_x_c_op_opssq_q_c;

  all_x_function[HOP_SAFE_C_CSA] = all_x_c_csa;
  all_x_function[HOP_SAFE_C_CAS] = all_x_c_cas;
  all_x_function[HOP_SAFE_C_SCA] = all_x_c_sca;
  all_x_function[HOP_SAFE_C_SAS] = all_x_c_sas;
  all_x_function[HOP_SAFE_C_SSA] = all_x_c_ssa;
  all_x_function[HOP_SAFE_C_SSC] = all_x_c_ssc;
  all_x_function[HOP_SAFE_C_SSS] = all_x_c_sss;
  all_x_function[HOP_SAFE_C_SCS] = all_x_c_scs;
  all_x_function[HOP_SAFE_C_CSS] = all_x_c_css;
  all_x_function[HOP_SAFE_C_CSC] = all_x_c_csc;
}

static s7_function all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e, safe_sym_t *checker)
{
  /* fprintf(stderr, "all_x_eval: %s %s\n", DISPLAY(arg), DISPLAY(e)); */
  if (is_pair(arg))
    {
      if (is_optimized(arg))
	{
	  switch (optimize_op(arg))
	    {
	    case HOP_SAFE_C_C:
	      if ((c_call(arg) == g_add_cs1) &&
		  (checker(sc, cadr(arg), e)))
		return(all_x_c_add1);
	      if ((c_call(arg) == g_add_si) &&
		  (checker(sc, cadr(arg), e)))
		return(all_x_c_addi);
	      if ((c_call(arg) == g_char_equal_s_ic) &&
		  (checker(sc, cadr(arg), e)))
		return(all_x_c_char_eq);
	      return(all_x_c_c);

	    case HOP_SAFE_C_S:
	      if (car(arg) == sc->cdr_symbol)
		{
		  if (checker(sc, cadr(arg), e))
		    return(all_x_cdr_u);
		  return(all_x_cdr_s);
		}
	      if (car(arg) == sc->car_symbol) return(all_x_car_s);
	      if (car(arg) == sc->is_null_symbol) return(all_x_null_s);
	      if (checker(sc, cadr(arg), e)) /* all we want here is assurance it's not going to be unbound */
		return(all_x_c_u);
	      return(all_x_c_s);

	    case HOP_SAFE_C_SS:
	      if ((checker(sc, cadr(arg), e)) &&
		  (checker(sc, caddr(arg), e)))
		return(all_x_c_uu);
	      return(all_x_c_ss);

	    case HOP_SAFE_C_SSS:
	      if ((checker(sc, cadr(arg), e)) &&
		  (checker(sc, caddr(arg), e)) &&
		  (checker(sc, cadddr(arg), e)))
		return(all_x_c_uuu);
	      return(all_x_c_sss);

	    case HOP_SAFE_C_SC:
	      if (checker(sc, cadr(arg), e))
		return(all_x_c_uc);
	      return(all_x_c_sc);

	    case HOP_SAFE_C_opSq:
	      if (checker(sc, cadr(cadr(arg)), e))
		{
		  if (car(arg) == sc->not_symbol)
		    return(all_x_c_not_opuq);
		  return(all_x_c_opuq);
		}
	      if (car(arg) == sc->not_symbol)
		return(all_x_c_not_opsq);
	      return(all_x_c_opsq);

	    case HOP_SAFE_C_opSq_opSq:
	      if ((checker(sc, cadr(cadr(arg)), e)) &&
		  (checker(sc, cadr(caddr(arg)), e)))
		return(all_x_c_opuq_opuq);
	      return(all_x_c_opsq_opsq);

	    case HOP_SAFE_C_opSSq_opSSq:
	      if ((checker(sc, cadr(cadr(arg)), e)) &&
		  (checker(sc, caddr(cadr(arg)), e)) &&
		  (checker(sc, cadr(caddr(arg)), e)) &&
		  (checker(sc, caddr(caddr(arg)), e)))
		return(all_x_c_opuuq_opuuq);
	      return(all_x_c_opssq_opssq);

	    case HOP_SAFE_C_opSSq:
	      if ((checker(sc, cadr(cadr(arg)), e)) &&
		  (checker(sc, caddr(cadr(arg)), e)))
		return(all_x_c_opuuq);
	      return(all_x_c_opssq);

	    case HOP_SAFE_C_opSSq_S:
	      if ((checker(sc, cadr(cadr(arg)), e)) &&
		  (checker(sc, caddr(cadr(arg)), e)) &&
		  (checker(sc, caddr(arg), e)))
		return(all_x_c_opuuq_u);
	      return(all_x_c_opssq_s);

	    case HOP_SAFE_C_S_opSq:
	      if ((checker(sc, cadr(arg), e)) &&
		  (checker(sc, cadr(caddr(arg)), e)))
		return(all_x_c_u_opuq);
	      return(all_x_c_s_opsq);

	    case HOP_SAFE_C_S_opSSq:
	      if ((checker(sc, cadr(arg), e)) &&
		  (checker(sc, cadr(caddr(arg)), e)) &&
		  (checker(sc, caddr(caddr(arg)), e)))
		return(all_x_c_u_opuuq);
	      return(all_x_c_s_opssq);

	    case HOP_SAFE_C_opSq_S:
	      if ((checker(sc, cadr(cadr(arg)), e)) &&
		  (checker(sc, caddr(arg), e)))
		return(all_x_c_opuq_u);
	      return(all_x_c_opsq_s);

	    default:
	      /* if (!all_x_function[optimize_op(arg)]) fprintf(stderr, "%s: %s\n", opt_names[optimize_op(arg)], DISPLAY(arg)); */
	      return(all_x_function[optimize_op(arg)]);
	    }
	}
      if (car(arg) == sc->quote_symbol)
	return(all_x_q);
      return(NULL);
    }
  if (is_symbol(arg))
    {
      if (is_keyword(arg))
	return(all_x_k);
      if (checker(sc, arg, e))
	return(all_x_u);
      return(all_x_s);
    }
  return(all_x_c);
}


static s7_function cond_all_x_eval(s7_scheme *sc, s7_pointer arg, s7_pointer e)
{
  if (arg == sc->else_object)
    return(all_x_else);
  return(all_x_eval(sc, arg, e, let_symbol_is_safe));
}


/* ---------------------------------------- for-each ---------------------------------------- */

static s7_pointer make_counter(s7_scheme *sc, s7_pointer iter)
{
  s7_pointer x;
  new_cell(sc, x, T_COUNTER);
  counter_set_result(x, sc->nil);
  counter_set_list(x, iter);     /* iterator -- here it's always either an iterator or a pair */
  counter_set_capture(x, 0);     /* will be capture_let_counter */
  counter_set_let(x, sc->nil);   /* will be the saved env */
  counter_set_slots(x, sc->nil); /* local env slots before body is evalled */
  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, string, vector, hash-table, or any other sequence."
  #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_procedure_symbol, sc->is_sequence_symbol)

  s7_pointer p, f;
  int len;
  bool got_nil = false;

  /* fprintf(stderr, "for-each: %s\n", DISPLAY(args)); */

  /* try the normal case first */
  f = car(args);                                /* the function */
  p = cadr(args);
  if ((is_null(cddr(args))) &&
      (is_pair(p)) &&
      (is_closure(f)) &&                        /* not lambda* that might get confused about arg names */
      (closure_arity_to_int(sc, f) == 1) &&     /* not a rest arg: not is_pair: (lambda (x . args) arg) */
      (!is_immutable_symbol(car(closure_args(f)))))
    {
      s7_pointer c;
      c = make_counter(sc, p);
      counter_set_result(c, p);
      push_stack(sc, OP_FOR_EACH_2, c, f);
      return(sc->unspecified);
    }

  if (!is_applicable(f))
    method_or_bust_with_type(sc, f, sc->for_each_symbol, args, something_applicable_string, 1);

  for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++)
    {
      if ((!is_sequence(car(p))) && (!is_iterator(car(p))))
	return(simple_wrong_type_argument_with_type(sc, sc->for_each_symbol, car(p), a_sequence_string));
      if (is_null(car(p)))
	got_nil = true;
    }

  if (!s7_is_aritable(sc, f, len))
    {
      static s7_pointer for_each_args_error = NULL;
      if (!for_each_args_error)
	for_each_args_error = s7_make_permanent_string("for-each ~A: ~A args?");
      return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, for_each_args_error, f, small_int(len))));
    }

  if (got_nil) return(sc->unspecified);

  sc->temp3 = args;
  sc->z = sc->nil;                                    /* don't use sc->args here -- it needs GC protection until we get the iterators */
  for (p = cdr(args); is_not_null(p); p = cdr(p))
    {
      s7_pointer iter;
      iter = car(p);
      if (!is_iterator(car(p)))
	iter = s7_make_iterator(sc, iter);
      sc->z = cons(sc, iter, sc->z);
    }
  sc->temp3 = sc->nil;

  sc->x = make_list(sc, len, sc->nil);
  sc->z = safe_reverse_in_place(sc, sc->z);
  sc->z = cons(sc, sc->z, sc->x);

  /* if function is safe c func, do the for-each locally */
  if ((is_safe_procedure(f)) &&
      (is_c_function(f)))
    {
      s7_function func;
      s7_pointer iters;
      func = c_function_call(f);
      push_stack(sc, OP_NO_OP, sc->args, sc->z); /* temporary GC protection */
      if (len == 1)
	{
	  s7_pointer x, y;
	  x = caar(sc->z);
	  y = cdr(sc->z);
	  sc->z = sc->nil;
	  while (true)
	    {
	      set_car(y, s7_iterate(sc, x));
	      if (iterator_is_at_end(x))
		{
		  pop_stack(sc);
		  return(sc->unspecified);
		}
	      func(sc, y);
	    }
	}
      iters = sc->z;
      sc->z = sc->nil;
      while (true)
	{
	  s7_pointer x, y;
	  for (x = car(iters), y = cdr(iters); is_pair(x); x = cdr(x), y = cdr(y))
	    {
	      set_car(y, s7_iterate(sc, car(x)));
	      if (iterator_is_at_end(car(x)))
		{

		  pop_stack(sc);
		  return(sc->unspecified);
		}
	    }
	  func(sc, cdr(iters));
	}
    }

  /* if closure call is straightforward, use OP_FOR_EACH_1 */
  if ((len == 1) &&
      (is_closure(f)) &&                        /* not lambda* that might get confused about arg names */
      (closure_arity_to_int(sc, f) == 1) &&     /* not a rest arg: not is_pair: (lambda (x . args) arg) */
      (!is_immutable_symbol(car(closure_args(f)))))
    {
      s7_pointer body, expr;
      body = closure_body(f);
      expr = car(body);
      if ((is_null(cdr(body))) &&
	  (is_optimized(expr)) &&
	  (is_all_x_op(optimize_op(expr))))
	{
	  s7_function func;
	  s7_pointer slot, iter;
	  
	  iter = caar(sc->z);
	  sc->z = sc->nil;
	  push_stack(sc, OP_NO_OP, iter, f);
	  sc->envir = new_frame_in_env(sc, sc->envir);
	  slot = make_slot_1(sc, sc->envir, car(closure_args(f)), sc->F);
	  func = all_x_eval(sc, expr, sc->envir, let_symbol_is_safe);
	  if (func == all_x_c_c)
	    {
	      func = c_callee(expr);
	      expr = cdr(expr);
	    }
	  while (true)
	    {
	      slot_set_value(slot, s7_iterate(sc, iter));
	      if (iterator_is_at_end(iter))
		{
		  pop_stack(sc);
		  return(sc->unspecified);
		}
	      func(sc, expr);
	    }
	}
      push_stack(sc, OP_FOR_EACH_1, make_counter(sc, caar(sc->z)), f);
      sc->z = sc->nil;
      return(sc->unspecified);
    }
  push_stack(sc, OP_FOR_EACH, sc->z, f);
  sc->z = sc->nil;
  return(sc->unspecified);
}


/* ---------------------------------------- map ---------------------------------------- */

static s7_pointer g_map(s7_scheme *sc, s7_pointer args)
{
  #define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \
a list of the results.  Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects."
  #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)

  s7_pointer p, f;
  int len;
  bool got_nil = false;

  f = car(args);                               /* the function */
  if (!is_applicable(f))
    method_or_bust_with_type(sc, f, sc->map_symbol, args, something_applicable_string, 1);

  for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++)
    {
      if ((!is_sequence(car(p))) && (!is_iterator(car(p))))
	return(simple_wrong_type_argument_with_type(sc, sc->map_symbol, car(p), a_sequence_string));
      if (is_null(car(p)))
	got_nil = true;
    }

  if ((!is_pair(f)) &&
      (!s7_is_aritable(sc, f, len)))
    {
      static s7_pointer map_args_error = NULL;
      if (!map_args_error)
	map_args_error = s7_make_permanent_string("map ~A: ~A args?");
      return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, map_args_error, f, small_int(len))));
    }

  if (got_nil) return(sc->nil);

  if ((f == slot_value(global_slot(sc->values_symbol))) &&
      (is_null(cddr(args))) &&
      (!has_methods(cadr(args))))
    {
      p = object_to_list(sc, cadr(args));
      if (p != cadr(args))
	return(p);
    }

  sc->temp3 = args;
  sc->z = sc->nil;                                    /* don't use sc->args here -- it needs GC protection until we get the iterators */
  for (p = cdr(args); is_not_null(p); p = cdr(p))
    {
      s7_pointer iter;
      iter = car(p);
      if (!is_iterator(car(p)))
	iter = s7_make_iterator(sc, iter);
      sc->z = cons(sc, iter, sc->z);
    }
  sc->z = safe_reverse_in_place(sc, sc->z);
  sc->temp3 = sc->nil;

  /* if function is safe c func, do the map locally */
  if ((is_safe_procedure(f)) &&
      (is_c_function(f)))
    {
      s7_function func;
      s7_pointer val, val1, old_args, iter_list;

      val1 = cons(sc, sc->z, make_list(sc, len, sc->nil));
      iter_list = sc->z;
      old_args = sc->args;
      func = c_function_call(f);
      push_stack(sc, OP_NO_OP, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */
      sc->z = sc->nil;

      while (true)
	{
	  s7_pointer x, y, z;
	  for (x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y))
	    {
	      set_car(y, s7_iterate(sc, car(x)));
	      if (iterator_is_at_end(car(x)))
		{
		  pop_stack(sc);
		  sc->args = old_args;
		  return(safe_reverse_in_place(sc, car(val))); 
		}
	    }
	  z = func(sc, cdr(val1)); /* can this contain multiple-values? */
	  if (z != sc->no_value)
	    set_car(val, cons(sc, z, car(val)));

	  /* to mimic map values handling elsewhere:
	   *   ((lambda args (format *stderr* "~A~%" (map values args))) (values)):   ()
	   *   ((lambda args (format *stderr* "~A~%" (map values args))) (values #<unspecified>)): #<unspecified> etc
	   */
	}
    }

  /* if closure call is straightforward, use OP_MAP_1 */
  if ((len == 1) &&
      (is_closure(f)) &&                        /* not lambda* that might get confused about arg names */
      (closure_arity_to_int(sc, f) == 1) &&     /* not a rest arg: not is_pair: (lambda (x . args) arg) */
      (!is_immutable_symbol(car(closure_args(f)))))
    {
      s7_pointer body, expr;
      body = closure_body(f);
      expr = car(body);
      if ((is_null(cdr(body))) &&
	  (is_optimized(expr)) &&
	  (is_all_x_op(optimize_op(expr))))
	{
	  s7_function func;
	  s7_pointer slot, iter, val, z;
	  
	  iter = car(sc->z);
	  push_stack(sc, OP_NO_OP, sc->args, val = cons(sc, sc->nil, cons(sc, f, iter))); /* second cons is GC protection */
	  sc->envir = new_frame_in_env(sc, sc->envir);
	  slot = make_slot_1(sc, sc->envir, car(closure_args(f)), sc->F);
	  func = all_x_eval(sc, expr, sc->envir, let_symbol_is_safe);
	  sc->z = sc->nil;
	  if (func == all_x_c_c)
	    {
	      func = c_callee(expr);
	      expr = cdr(expr);
	    }
	  while (true)
	    {
	      slot_set_value(slot, s7_iterate(sc, iter));
	      if (iterator_is_at_end(iter))
		{
		  pop_stack(sc);
		  return(safe_reverse_in_place(sc, car(val)));
		}
	      z = func(sc, expr);
	      if (z != sc->no_value)
		set_car(val, cons(sc, z, car(val)));
	    }
	}

      push_stack(sc, OP_MAP_1, make_counter(sc, car(sc->z)), f);
      sc->z = sc->nil;
      return(sc->nil);
    }
  push_stack(sc, OP_MAP, make_counter(sc, sc->z), f);
  sc->z = sc->nil;
  return(sc->nil);
}


/* -------------------------------- multiple-values -------------------------------- */

static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
{
  int top;
  s7_pointer x;
  top = s7_stack_top(sc) - 1; /* stack_end - stack_start: if this is negative, we're in big trouble */

  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 blithely 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_SAFE_C_SSZ_1:
    case OP_EVAL_ARGS_SSP_1:
      vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_ARGS_SSP_MV;
      return(args);
      
    case OP_SAFE_C_SZ_1:
    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_SAFE_C_ZC_1:
    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_SAFE_CLOSURE_P_1:
    case OP_CLOSURE_P_1:
      vector_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_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);
      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);
      eval_error(sc, "too many values to set! ~S", args);
      
    case OP_LET1:                                             /* (let ((var (values 1 2 3))) ...) */
    case OP_LET_ONE_1:
    case OP_LET_Z_1:
      set_multiple_value(args);
      eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->let_symbol, args);
      /* "some variable" is ugly, but the actual name is tricky to find at this point --
       *   it's in main_stack_args, but finding the right one is a mess.  It's isn't sc->code.
       */
      
    case OP_LET_STAR1:
      set_multiple_value(args);
      eval_error_with_caller(sc, "~A: can't bind some variable to ~S", sc->let_star_symbol, args);
      
    case OP_LETREC1:
    case OP_LETREC_STAR1:
      set_multiple_value(args);
      eval_error_with_caller(sc, "~A: can't bind some variable to ~S", (sc->op == OP_LETREC1) ? sc->letrec_symbol : sc->letrec_star_symbol, args);
      
      /* 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:
      /* here we have a values call with nothing to splice into.  So flush it...
       *   otherwise the multiple-values bit gets set in some innocent list and never unset:
       *   :(let ((x '((1 2)))) (eval `(apply apply values x)) x)
       *   ((values 1 2))
       * other cases: (+ 1 (begin (values 5 6) (values 2 3)) 4) -> 10 -- the (5 6) is dropped
       *              (let () (values 1 2 3) 4) but (+ (let () (values 1 2))) -> 3
       */
      return(args);
      
    case OP_CATCH:
    case OP_CATCH_1:
    case OP_CATCH_2:
      /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */
      pop_stack(sc);
      return(splice_in_values(sc, args));
      
    case OP_EXPANSION:
      /* we get here if a reader-macro (define-expansion) returned multiple values.
       *    these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack.
       *    and that it will be expecting the next arg entry in sc->value).
       */
      pop_stack(sc);
      top -= 4;
      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));              /* sc->value from OP_READ_LIST point of view */
      
    default:
      break;
    }

  /* let it meander back up the call chain until someone knows where to splice it */
  set_multiple_value(args);
  return(args);
}


s7_pointer s7_values(s7_scheme *sc, s7_pointer args)
{
  #define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')"
  #define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)

  if (is_null(args))         /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */
    return(sc->no_value);

  /* 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 (is_null(cdr(args)))
    return(car(args));

  return(splice_in_values(sc, args));
}

#define g_values s7_values


/* -------------------------------- 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)"
  #define Q_qq_list s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T)

  s7_pointer x, y, px;

  if (sc->no_values == 0)
    return(args);

  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)
   *   ({list} ({apply_values} ())) -> (), also ({list} ({apply_values})) -> ()
   */
  px = sc->nil;
  for (x = args, y = args; is_pair(y); y = cdr(y))
    if (car(y) != sc->no_value)
      {
	set_car(x, car(y));
	px = x;
	x = cdr(x);
      }

  if ((is_not_null(y)) &&
      (y != sc->no_value))
    set_cdr(x, cdr(y));
  else
    {
      sc->no_values--;
      if (is_null(px))
	return(sc->nil);
      set_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."
  #define Q_apply_values pcl_t
  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(apply_list_error(sc, 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 ((tmp == car(tmp)) || /* try to protect against #1=(#1) -- do we actually need cyclic_sequences here? */
	    (!is_simple_code(sc, car(tmp))))
	  return(false);
      }
    else
      {
	if ((car(tmp) == sc->unquote_symbol) ||
	    ((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 (\"apply values\") to pre-evaluate portions of the list. \
unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \
and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)."
  #define Q_quasiquote pcl_t

  if (!is_pair(form))
    {
      if ((is_symbol(form)) &&
	  (!is_keyword(form)))
	return(list_2(sc, sc->quote_symbol, form));
      /* things that evaluate to themselves don't need to be quoted. */
      return(form);
    }

  if (car(form) == sc->unquote_symbol)
    {
      if (is_not_null(cddr(form)))
	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_symbol, form));

  {
    int len, i, loc;
    s7_pointer orig, bq, old_scw;
    bool dotted = false;

    len = s7_list_length(sc, form);
    if (len == 0)
      {
	/* a circular form, apparently */
	return(list_2(sc, sc->quote_symbol, 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);

    set_car(sc->w, sc->qq_list_function);

    if (!dotted)
      {
	for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq))
	  {
	    if ((is_pair(cdr(orig))) &&            /* this was is_pair(orig) which seems to be always the case */
		(cadr(orig) == sc->unquote_symbol))
	      {
		/* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2)
		 * `(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)))
		 */
		set_car(bq, g_quasiquote_1(sc, car(orig)));
		set_cdr(bq, sc->nil);
		sc->w = list_3(sc, sc->qq_append_function, sc->w, caddr(orig));
		break;
	      }
	    else set_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))
	  set_car(bq, g_quasiquote_1(sc, car(orig)));
	set_car(bq, g_quasiquote_1(sc, car(orig)));

	sc->w = list_3(sc, sc->qq_append_function, 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);
    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_BYTE_VECTOR))
    {
      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_symbol, set_elist_1(sc, make_string_wrapper(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 d, loc = 0;
	sc->strbuf[loc++] = c;
	dims = digits[c];

	while (true)
	  {
	    s7_int dig;
	    d = inchar(pt);
	    if (d == EOF)
	      s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(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_symbol, set_elist_2(sc, make_string_wrapper(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_symbol, set_elist_1(sc, make_string_wrapper(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_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u...")));
	if (d == '8')
	  {
	    d = inchar(pt);
	    if (d == EOF)
	      s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #u8...")));
	    if (d == '(')
	      return(TOKEN_BYTE_VECTOR);
	    backchar(d, pt);
	    backchar('8', pt);
	  }
	else backchar(d, pt);
      }
      break;

    case ':':  /* turn #: into : -- this is for compatibility with Guile, sigh.
		*   I just noticed that Rick is using this -- I'll just leave it alone.
		*   but that means : readers need to handle this case specially.
		* I don't think #! is special anymore -- maybe remove that code?
		*/
      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)
      * but very often the closing !# is omitted which is too bad
      */
    case '!':
      {
	char last_char;
	s7_pointer reader;
	
	/* make it possible to override #! handling */
	for (reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader))
	  if (s7_character(caar(reader)) == '!')
	    {
	      sc->strbuf[0] = c;
	      return(TOKEN_SHARP_CONST); /* next stage notices any errors */
	    }

	/* not #! as block comment (for Guile I guess) */
	last_char = ' ';
	while ((c = inchar(pt)) != EOF)
	  {
	    if ((c == '#') &&
		(last_char == '!'))
	      break;
	    last_char = c;
	  }
	if (c == EOF)
	  s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(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 '|':
      {
	if (is_file_port(pt))
	  {
	    char last_char;
	    last_char = ' ';
	    while (true)
	      {
		c = fgetc(port_file(pt));
		if (c == EOF)
		  s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(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_data(pt) + port_position(pt));
	    pend = (const char *)(port_data(pt) + port_data_size(pt));
	    str = orig_str;

	    while (true)
	      {
		p = strchr(str, (int)'|');
		if ((!p) || (p >= pend))
		  {
		    port_position(pt) = port_data_size(pt);
		    s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_wrapper(sc, "unexpected end of input while reading #|")));
		  }
		if (p[1] == '#')
		  break;
		str = (const char *)(p + 1);
	      }
	    port_position(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 "@":
     :(define-macro (hi @foo) `(+ ,@foo 1))
     hi
     :(hi 2)
     ;foo: unbound variable
     but
     :(define-macro (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;
  c = port_read_white_space(sc->input_port)(sc, sc->input_port);
  switch (c)
    {
    case '(':  return(TOKEN_LEFT_PAREN);
    case ')':  return(TOKEN_RIGHT_PAREN);
    case '.':  return(read_dot(sc, sc->input_port));
    case '\'': return(TOKEN_QUOTE);
    case ';':  return(port_read_semicolon(sc->input_port)(sc, sc->input_port));
    case '"':  return(TOKEN_DOUBLE_QUOTE);
    case '`':  return(TOKEN_BACK_QUOTE);
    case ',':  return(read_comma(sc, sc->input_port));
    case '#':  return(read_sharp(sc, sc->input_port));
    case '\0':
    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, c;

  c = inchar(pt);
  if (c == EOF)
    return(NOT_AN_X_CHAR);

  d1 = digits[c];
  if (d1 < 16)
    {
      int d2;
      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 unknown_string_constant(s7_scheme *sc, int c)
{
  /* check *read-error-hook* */
  if (hook_has_functions(sc->read_error_hook))
    {
      s7_pointer result;
      result = s7_call(sc, sc->read_error_hook, list_2(sc, sc->F, s7_make_character(sc, (unsigned char)c)));
      if (s7_is_character(result))
	return(result);
    }
  return(sc->T);
}

static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt)
{
  /* sc->F => error
   *   no check needed here for bad input port and so on
   */
  unsigned int i = 0;

  if (is_string_port(pt))
    {
      /* try the most common case first */
      char *s, *start, *end;
      start = (char *)(port_data(pt) + port_position(pt));
      if (*start == '"')
	{
	  port_position(pt)++;
	  return(make_empty_string(sc, 0, 0));
	}

      end = (char *)(port_data(pt) + port_data_size(pt));
      s = strpbrk(start, "\"\n\\");
      if ((!s) || (s >= end))                     /* can this read a huge string constant from a file? */
	{
	  if (start == end)
	    sc->strbuf[0] = '\0';
	  else memcpy((void *)(sc->strbuf), (void *)start, (end - start > 8) ? 8 : (end - start));
	  sc->strbuf[8] = '\0';
	  return(sc->F);
	}
      if (*s == '"')
	{
	  int len;
	  len = s - start;
	  port_position(pt) += (len + 1);
	  return(s7_make_string_with_length(sc, start, len));
	}

      for (; s < end; s++)
	{
	  if (*s == '"')                         /* switch here no faster */
	    {
	      int len;
	      len = s - start;
	      port_position(pt) += (len + 1);
	      return(s7_make_string_with_length(sc, start, len));
	    }
	  else
	    {
	      if (*s == '\\')
		{
		  /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */
		  unsigned int len;
		  len = (unsigned int)(s - start);
		  if (len > 0)
		    {
		      if (len >= sc->strbuf_size)
			resize_strbuf(sc, len);
		      /* for (i = 0; i < len; i++) sc->strbuf[i] = port_data(pt)[port_position(pt)++]; */
		      memcpy((void *)(sc->strbuf), (void *)(port_data(pt) + port_position(pt)), len);
		      port_position(pt) += len;
		    }
		  i = len;
		  break;
		}
	      else
		{
		  if (*s == '\n')
		    port_line_number(pt)++;
		}
	    }
	}
    }

  while (true)
    {
      /* splitting this check out and duplicating the loop was slower?!? */
      int c;
      c = port_read_character(pt)(sc, pt);

      switch (c)
	{
	case '\n':
	  port_line_number(pt)++;
	  sc->strbuf[i++] = c;
	  break;

	case EOF:
	  sc->strbuf[(i > 8) ? 8 : i] = '\0';
	  return(sc->F);

	case '"':
	  return(s7_make_string_with_length(sc, sc->strbuf, i));

	case '\\':
	  c = inchar(pt);

	  if (c == EOF)
	    {
	      sc->strbuf[(i > 8) ? 8 : i] = '\0';
	      return(sc->F);
	    }

	  if ((c == '\\') || (c == '"') || (c == '|'))
	    sc->strbuf[i++] = c;
	  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)
			    {
			      s7_pointer result;
			      result = unknown_string_constant(sc, c);
			      if (s7_is_character(result))
				sc->strbuf[i++] = character(result);
			      else return(result);
			    }
			  sc->strbuf[i++] = (unsigned char)c;
			}
		      else
			{
			  /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */
			  if ((c != '\n') && (c != '\r'))
			    {
			      s7_pointer result;
			      result = unknown_string_constant(sc, c);
			      if (s7_is_character(result))
				sc->strbuf[i++] = character(result);
			      else return(result);
			    }
			  /* #f here would give confusing error message "end of input", so return #t=bad backslash.
			   *     this is not optimal. It's easy to forget that backslash needs to be backslashed.
			   *
			   * the white_space business half-implements Scheme's \<newline>...<eol>... or \<space>...<eol>...
			   *   feature -- the characters after \ are flushed if they're all white space and include a newline.
			   *   (string->number "1\   2") is 12??  Too bizarre.
			   */
			}
		    }
		}
	    }
	  break;

	default:
	  sc->strbuf[i++] = c;
	  break;
	}

      if (i >= sc->strbuf_size)
	resize_strbuf(sc, i);
    }
}


static s7_pointer read_expression(s7_scheme *sc)
{
  while (true)
    {
      int c;
      switch (sc->tok)
	{
	case TOKEN_EOF:
	  return(sc->eof_object);

	case TOKEN_BYTE_VECTOR:
	  push_stack_no_code(sc, OP_READ_BYTE_VECTOR, 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);
	  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);
	  switch (sc->tok)
	    {
	    case TOKEN_EOF: 
	      pop_stack(sc);
	      return(read_error(sc, "stray comma at the end of the input?")); 

	    case TOKEN_RIGHT_PAREN:
	      pop_stack(sc);
	      {
		char *str;
		str = current_input_string(sc, sc->input_port);
		if (str)
		  {
		    char *msg;
		    int len;
		    msg = (char *)malloc(128 * sizeof(char));
		    len = snprintf(msg, 128, "at \"...%s...\", stray comma before ')'?", str);
		    free (str);
		    return(s7_error(sc, sc->read_error_symbol, set_elist_1(sc, make_string_uncopied_with_length(sc, msg, len))));
		  }
		return(read_error(sc, "stray comma before ')'?"));         /* '("a" "b",) */
	      }

	    default:
	      break;
	    }
	  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));
	  /* 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(string_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_sharp(sc->input_port)(sc, sc->input_port);

	  /* 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 (local_strcmp(file, string_value(caar(p))))
      return(cdar(p));
  return(sc->nil);
}

static s7_pointer find_closure_let(s7_scheme *sc, s7_pointer cur_env)
{
  s7_pointer e;
  for (e = cur_env; is_let(e); e = outlet(e))
    if (is_function_env(e))
      return(e);
  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 (has_ref_fallback(sc->envir)) /* an experiment -- see s7test (with-let *db* (+ int (length str))) */
    check_method(sc, sc->envir, sc->let_ref_fallback_symbol, sc->w = list_2(sc, sc->envir, sym));
  /* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */

  if (sym == sc->unquote_symbol)
    eval_error(sc, "unquote (',') occurred outside quasiquote: ~S", current_code(sc));

  if (sym == sc->__func___symbol) /* __func__ is a sort of symbol macro */
    {
      s7_pointer env;
      env = find_closure_let(sc, sc->envir);
      if (is_let(env))
	{
	  /* for C-defined things like hooks and dilambda, let_file and let_line are 0 */
	  if ((let_file(env) > 0) && 
	      (let_file(env) < (s7_int)sc->file_names_top) && /* let_file(env) might be > int */
	      (let_line(env) > 0))
	    return(list_3(sc, funclet_function(env), sc->file_names[let_file(env)], make_integer(sc, let_line(env))));
	  return(funclet_function(env));
	}
      return(sc->undefined);
    }

  if (safe_strcmp(symbol_name(sym), "|#"))
    return(read_error(sc, "unmatched |#"));

  /* check *autoload*, autoload_names, then *unbound-variable-hook*
   */
  if ((sc->autoload_names) ||
      (is_hash_table(sc->autoload_table)) ||
      (hook_has_functions(sc->unbound_variable_hook)))
    {
      s7_pointer result, cur_code, value, code, args, cur_env, x, z;
      /* sc->args and sc->code are pushed on the stack by s7_call, then
       *   restored by eval, so they are normally protected, but sc->value and current_code(sc) are
       *   not protected (yet).  We need current_code(sc) so that the possible eventual error
       *   call can tell where the error occurred, and we need sc->value because it might
       *   be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered
       *   by the hook function.  (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value
       *   is not protected.  We also need to save/restore sc->envir in case s7_load is called.
       */

      args = sc->args;
      code = sc->code;
      value = sc->value;
      cur_code = current_code(sc);
      cur_env = sc->envir;
      result = sc->undefined;
      x = sc->x;
      z = sc->z;
      sc->temp7 = cons(sc, code, cons(sc, args, cons(sc, value, cons(sc, cur_code, cons(sc, x, cons(sc, z, sc->nil)))))); /* not s7_list (debugger checks) */

      if (!is_pair(cur_code))
	{
	  /* isolated typo perhaps -- no pair to hold the position info, so make one.
	   *   current_code(sc) is GC-protected, so this should be safe.
	   */
	  cur_code = cons(sc, sym, sc->nil);     /* the error will say "(sym)" which is not too misleading */
	  pair_set_line(cur_code, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
	  set_has_line_number(cur_code);
	}

#if (!DISABLE_AUTOLOAD)
      /* check sc->autoload_names */
      if (sc->autoload_names)
	{
	  const char *file;
	  bool loaded = false;
	  file = find_autoload_name(sc, sym, &loaded, true);
	  if ((file) && (!loaded))
	    {
	      s7_pointer e;
	      /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...]
	       * here it was possible to get caught in a loop:
	       *   change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*)
	       *   so the "loaded" arg tries to catch such cases
	       */
	      e = loaded_library(sc, file);
	      if (!is_let(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_let(e)))
		{
		  result = s7_let_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);
		}
	    }
	}
#endif

      if (result == sc->undefined)
	{
#if (!DISABLE_AUTOLOAD)
	  /* 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 */
	    }
#endif

	  /* check *unbound-variable-hook* */
	  if ((result == sc->undefined) &&
	      (hook_has_functions(sc->unbound_variable_hook)))
	    {
	      /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */
	      s7_pointer old_hook;

	      old_hook = sc->unbound_variable_hook;
	      set_car(sc->z2_1, old_hook);
	      sc->unbound_variable_hook = sc->error_hook;      /* avoid the infinite loop mentioned above */
	      result = s7_call(sc, old_hook, list_1(sc, sym)); /* not s7_apply_function */
	      sc->unbound_variable_hook = old_hook;
	    }
	}

      sc->value = _NFre(value);
      set_current_code(sc, cur_code);
      sc->args = args;
      sc->code = code;
      sc->envir = cur_env;
      sc->x = x;
      sc->z = z;
      sc->temp7 = sc->nil;

      if ((result != sc->undefined) &&
	  (result != sc->unspecified))
	return(result);
    }
  eval_error(sc, "~A: unbound variable", sym);
}


static s7_pointer assign_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc)
{
  s7_pointer x, syn;
  unsigned long long int hash;
  unsigned int loc;

  hash = raw_string_hash((const unsigned char *)name, safe_strlen(name));
  loc = hash % SYMBOL_TABLE_SIZE;
  x = new_symbol(sc, name, safe_strlen(name), hash, loc);

  syn = alloc_pointer();
  unheap(syn);
  set_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS);
  syntax_opcode(syn) = op;
  syntax_set_symbol(syn, x);
  syntax_min_args(syn) = integer(min_args);
  syntax_max_args(syn) = ((max_args == max_arity) ? -1 : integer(max_args));
  syntax_documentation(syn) = s7_make_permanent_string(doc);
  syntax_rp(syn) = NULL;
  syntax_ip(syn) = NULL;
  syntax_pp(syn) = NULL;

  set_global_slot(x, permanent_slot(x, syn));
  set_initial_slot(x, permanent_slot(x, syn));
  typeflag(x) = SYNTACTIC_TYPE;
  symbol_set_local(x, 0LL, sc->nil);
  symbol_syntax_op(x) = op;
  return(x);
}

static s7_pointer assign_internal_syntax(s7_scheme *sc, const char *name, opcode_t op)
{
  s7_pointer x, str, syn;
  s7_pointer symbol, old_syn;

  symbol = s7_make_symbol(sc, name);
  old_syn = slot_value(global_slot(symbol));
  str = s7_make_permanent_string(name);

  x = alloc_pointer();
  unheap(x);
  set_type(x, T_SYMBOL);
  symbol_set_name_cell(x, str);
  symbol_set_local(x, 0LL, sc->nil);
  symbol_syntax_op(x) = op;

  syn = alloc_pointer();
  heap_location(syn) = heap_location(old_syn);
  set_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS);
  syntax_opcode(syn) = op;
  syntax_set_symbol(syn, symbol);
  syntax_min_args(syn) = syntax_min_args(old_syn);
  syntax_max_args(syn) = syntax_max_args(old_syn);
  syntax_documentation(syn) = syntax_documentation(old_syn);
  syntax_rp(syn) = syntax_rp(old_syn);
  syntax_ip(syn) = syntax_ip(old_syn);
  syntax_pp(syn) = syntax_pp(old_syn);

  set_global_slot(x, permanent_slot(x, syn));
  set_initial_slot(x, permanent_slot(x, syn));
  typeflag(x) = SYNTACTIC_TYPE;
  return(x);
}


static s7_int c_pair_line_number(s7_scheme *sc, s7_pointer p)
{
  if (!is_pair(p))
    int_method_or_bust(sc, p, sc->pair_line_number_symbol, set_plist_1(sc, p), T_PAIR, 0);

  if (has_line_number(p))
    {
      unsigned int x;
      x = pair_line(p);
      return(remembered_line_number(x));
    }
  return(0);
}

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'"
  #define Q_pair_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol)
  return(make_integer(sc, c_pair_line_number(sc, car(args))));
}

PF_TO_IF(pair_line_number, c_pair_line_number)


static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args)
{
  #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'"
  #define Q_pair_filename s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_pair_symbol)
  s7_pointer p;
  p = car(args);

  if (!is_pair(p))
    {
      check_method(sc, p, sc->pair_filename_symbol, args);
      return(simple_wrong_type_argument(sc, sc->pair_filename_symbol, p, T_PAIR));	
    }
  if (has_line_number(p))
    {
      int x;
      x = pair_line(p);
      return(remembered_file_name(x));
    }
  return(sc->F);
}


static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
{
  s7_pointer x;

  for (x = let_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_slot(x))
	  set_checked_slot(x); /* this is a special use of this bit, I think */
	else return(s7_error(sc, sc->wrong_type_arg_symbol,
			     set_elist_4(sc, make_string_wrapper(sc, "~A: parameter set twice, ~S in ~S"), closure_name(sc, sc->code), sym, 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 :rest bind the next arg to the trailing args at this point.
   *   All args can be accessed by their name as a keyword.
   *
   * 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.
   */

  bool allow_other_keys;
  s7_pointer lx, cx, zx;

  /* get the current args, re-setting args that have explicit values */
  cx = closure_args(sc->code);
  allow_other_keys = ((is_pair(cx)) && (allows_other_keys(cx)));
  lx = sc->args;

  zx = sc->nil;
  while ((is_pair(cx)) &&
	 (is_pair(lx)))
    {
      if (car(cx) == sc->key_rest_symbol)           /* the rest arg */
	{
	  /* next arg is bound to trailing args from this point as a list */
	  zx = sc->key_rest_symbol;
	  cx = cdr(cx);
	  lambda_star_argument_set_value(sc, car(cx), lx); /* default arg not allowed here (see check_lambda_star_args) */
	  lx = cdr(lx);
	  cx = cdr(cx);
	}
      else
	{
	  /* mock-symbols introduce an ambiguity here; if the object's value is a keyword, is that
	   *   intended to be used as an argument name or value?
	   */
	  s7_pointer car_lx;
	  car_lx = car(lx);
	  if (has_methods(car_lx))
	    car_lx = check_values(sc, car_lx, lx);
	  if ((is_pair(cdr(lx))) &&
	      (is_keyword(car_lx)))
	    {
	      /* char *name; */                      /* found a keyword, check the lambda args via the corresponding symbol */
	      s7_pointer sym;
	      sym = keyword_symbol(car_lx);
	      
	      if (lambda_star_argument_set_value(sc, sym, car(cdr(lx))) == sc->no_value)
		{
		  /* if default value is a key, go ahead and use this value.
		   *    (define* (f (a :b)) a) (f :c)
		   * this has become much trickier than I anticipated...
		   */
		  if (allow_other_keys)
		    {
		      /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3
		       * in s7: (define* (hi (a 1) :allow-other-keys) a)    (hi :b :a :a 3) -> 3
		       */
		      lx = cddr(lx);
		      continue;
		    }
		  else
		    {
		      if ((is_pair(car(cx))) &&
			  (is_keyword(cadar(cx))))
			{
			  /* cx is the closure args list, not the copy of it in the curlet */
			  s7_pointer x;
			  
			  x = find_symbol(sc, caar(cx));
			  if (is_slot(x))
			    {
			      if (is_not_checked_slot(x))
				{
				  set_checked_slot(x);
				  slot_set_value(x, car(lx));
				}
			      else
				{
				  /* this case is not caught yet: ((lambda* (a b :allow-other-keys ) a) :b 1 :c :a :a ) */
				  return(s7_error(sc, sc->wrong_type_arg_symbol,
						  set_elist_4(sc, make_string_wrapper(sc, "~A: parameter set twice, ~S in ~S"),
							      closure_name(sc, sc->code), lx, sc->args)));
				}
			    }
			  else
			    {
			      return(s7_error(sc, sc->wrong_type_arg_symbol,
					      set_elist_4(sc, make_string_wrapper(sc, "~A: unknown key: ~S in ~S"),
							  closure_name(sc, sc->code), lx, sc->args)));
			    }
			  /* (define* (f a (b :c)) b) (f :b 1 :d) */
			}
		      else
			{
			  return(s7_error(sc, sc->wrong_type_arg_symbol,
					  set_elist_4(sc, make_string_wrapper(sc, "~A: unknown key: ~S in ~S"),
						      closure_name(sc, sc->code), lx, sc->args)));
			}
		    }
		}
	      lx = cdr(lx);
	      if (is_pair(lx)) lx = cdr(lx);
	    }
	  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(cx)))
		lambda_star_argument_set_value(sc, caar(cx), car(lx));
	      else lambda_star_argument_set_value(sc, car(cx), car(lx));
	      
	      lx = cdr(lx);
	    }
	  cx = cdr(cx);
	}
    }

  /* (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(lx))
    {
      if ((is_not_null(cx)) ||
	  (zx == sc->key_rest_symbol))
	{
	  if (is_symbol(cx))
	    make_slot_1(sc, sc->envir, cx, lx);
	}
      else
	{
	  if (!allow_other_keys)                       /* ((lambda* (a) a) :a 1 2) */
	    return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, 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(lx))
		{
		  if ((!is_keyword(car(lx))) ||     /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */
		      (!is_pair(cdr(lx))))          /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */
		    return(s7_error(sc, sc->wrong_type_arg_symbol,
				    set_elist_3(sc, make_string_wrapper(sc, "~A: not a key/value pair: ~S"), closure_name(sc, sc->code), lx)));
		  /* errors not caught?
		   *    ((lambda* (a :allow-other-keys) a) :a 1 :a 2)
		   *    ((lambda* (:allow-other-keys ) #f) :b :a :a :b)
		   */
		  lx = cddr(lx);
		}
	    }
	}
    }
  return(sc->nil);
}


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 = find_symbol_checked(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, set_plist_1(sc, val)))));
  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 = find_symbol_checked(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_pair(sc, list_1(sc, g_cdr(sc, set_plist_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 = find_symbol_checked(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_pair(sc, list_1(sc, g_cadr(sc, set_plist_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))) &&
      (optimize_op(cadr(expr)) == HOP_SAFE_C_S))
    {
      s7_function g;
      g = c_callee(cadr(expr));
      if (g == g_car)
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(is_pair_car);
	}
      if (g == g_cdr)
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(is_pair_cdr);
	}
      if (g == g_cadr)
	{
	  set_optimize_op(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 = find_symbol_checked(sc, cadar(args));
  if (!is_pair(val))
    return(g_is_null(sc, list_1(sc, g_cdr(sc, set_plist_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_h_safe_c_s(cadr(expr)))
    {
      s7_function g;
      g = c_callee(cadr(expr));
      if (g == g_cdr)
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(is_null_cdr);
	}
    }
  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));
}

static s7_pointer g_format_just_newline(s7_scheme *sc, s7_pointer args)
{
  s7_pointer pt, str;

  pt = car(args);
  str = cadr(args);

  if (pt == sc->F)
    return(s7_make_string_with_length(sc, string_value(str), string_length(str)));

  if (pt == sc->T)
    {
      if (sc->output_port != sc->F)
	port_write_string(sc->output_port)(sc, string_value(str), string_length(str), sc->output_port);
      return(s7_make_string_with_length(sc, string_value(str), string_length(str)));
    }

  if ((!is_output_port(pt)) ||
      (port_is_closed(pt)))
    method_or_bust_with_type(sc, pt, sc->format_symbol, args, a_format_port_string, 1);

  port_write_string(pt)(sc, string_value(str), string_length(str), pt);
  return(sc->F);
}


static s7_pointer g_format_allg_no_column(s7_scheme *sc, s7_pointer args)
{
  s7_pointer pt, str;
  pt = car(args);
  if (is_null(pt)) pt = sc->output_port;

  if (!((s7_is_boolean(pt)) ||
	((is_output_port(pt)) &&             /* (current-output-port) or call-with-open-file arg, etc */
	 (!port_is_closed(pt)))))
    method_or_bust_with_type(sc, pt, sc->format_symbol, args, a_format_port_string, 1);

  str = cadr(args);
  sc->format_column = 0;
  return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt,
			  string_value(str), cddr(args), NULL,
			  !is_output_port(pt),   /* i.e. is boolean port so we're returning a string */
			  false,                 /* we checked in advance that it is not columnized */
			  string_length(str),
			  str));
}


static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  s7_pointer port, str_arg;
  port = cadr(expr);
  str_arg = caddr(expr);
  if ((args > 1) &&
      (!is_string(port)) &&
      (is_string(str_arg)))
    {
      if (args == 2)
	{
	  int len;
	  char *orig;
	  const char *p;

	  orig = string_value(str_arg);
	  p = strchr((const char *)orig, (int)'~');
	  if (!p)
	    {
	      if (s7_is_boolean(port))
		set_optimize_op(expr, HOP_SAFE_C_C);
	      return(format_just_newline); /* "just_newline" actually just outputs the control string -- see fixup below */
	    }

	  len = string_length(str_arg);
	  if ((len > 1) &&
	      (orig[len - 1] == '%') &&
	      ((p - orig) == len - 2))
	    {
	      orig[len - 2] = '\n';
	      orig[len - 1] = '\0';
	      string_length(str_arg) = len - 1;
	      if (s7_is_boolean(port))
		set_optimize_op(expr, HOP_SAFE_C_C);
	      return(format_just_newline);
	    }
	}

      /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */
      if (!is_columnizing(string_value(str_arg)))
	return(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 = find_symbol_checked(sc, cadar(args));
  val = find_symbol_checked(sc, cadr(args));
  if (!is_pair(lst))
    return(g_is_eq(sc, set_plist_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 = find_symbol_checked(sc, cadar(args));
  if (!is_pair(lst))
    return(g_is_eq(sc, set_plist_2(sc, g_car(sc, set_plist_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)
{
  /* (eq? (caar x) 'y), but x is not guaranteed to be list(list) */
  s7_pointer lst;
  lst = find_symbol_checked(sc, cadar(args));
  if ((!is_pair(lst)) || (!is_pair(car(lst))))
    return(g_is_eq(sc, set_plist_2(sc, g_caar(sc, set_plist_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_h_safe_c_s(cadr(expr)))
    {
      if ((is_symbol(caddr(expr))) &&
	  (c_callee(cadr(expr)) == g_car))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(is_eq_car);
	}
      if ((is_pair(caddr(expr))) &&
	  (caaddr(expr) == sc->quote_symbol))
	{
	  if (c_callee(cadr(expr)) == g_car)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(is_eq_car_q);
	    }
	  if (c_callee(cadr(expr)) == g_caar)
	    {
	      set_optimize_op(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;
static s7_pointer not_is_char, not_is_string, not_is_zero, not_is_eq_sq, not_is_eq_ss;

static s7_pointer g_not_is_pair(s7_scheme *sc, s7_pointer args)     {check_boolean_not_method(sc, is_pair,         sc->is_pair_symbol, args);}
static s7_pointer g_not_is_null(s7_scheme *sc, s7_pointer args)     {check_boolean_not_method(sc, is_null,         sc->is_null_symbol, args);}
static s7_pointer g_not_is_symbol(s7_scheme *sc, s7_pointer args)   {check_boolean_not_method(sc, is_symbol,       sc->is_symbol_symbol, args);}
static s7_pointer g_not_is_number(s7_scheme *sc, s7_pointer args)   {check_boolean_not_method(sc, s7_is_number,    sc->is_number_symbol, args);}
static s7_pointer g_not_is_char(s7_scheme *sc, s7_pointer args)     {check_boolean_not_method(sc, s7_is_character, sc->is_char_symbol, args);}
static s7_pointer g_not_is_string(s7_scheme *sc, s7_pointer args)   {check_boolean_not_method(sc, is_string,       sc->is_string_symbol, args);}
static s7_pointer g_not_is_zero(s7_scheme *sc, s7_pointer args)     {check_boolean_not_method(sc, s7_is_zero,      sc->is_zero_symbol, args);}
static s7_pointer g_not_is_list(s7_scheme *sc, s7_pointer args)     {check_boolean_not_method(sc, opt_is_list,     sc->is_list_symbol, args);}

/* eq? does not check for methods */
static s7_pointer g_not_is_eq_sq(s7_scheme *sc, s7_pointer args)
{
  return(make_boolean(sc, find_symbol_checked(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, find_symbol_checked(sc, cadr(car(args))) != find_symbol_checked(sc, caddr(car(args)))));
}

/* here the method finder is in either car or cdr */
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 = find_symbol_checked(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, set_plist_1(sc, val)))))));
  return(make_boolean(sc, !is_pair(car(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_op(cadr(expr)) == HOP_SAFE_C_S)
	{
	  s7_function f;
	  f = c_callee(cadr(expr));

	  if (f == g_is_pair)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_pair);
	    }
	  if (f == g_is_null)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_null);
	    }
	  if (f == g_is_symbol)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_symbol);
	    }
	  if (f == g_is_list)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_list);
	    }
	  /* g_is_number is c_function_call(slot_value(global_slot(sc->is_number_symbol)))
	   *   so if this is changed (via openlet??) 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_op(expr, HOP_SAFE_C_C);
	      return(not_is_number);
	    }

	  if (f == g_is_zero)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_zero);
	    }
	  if (f == g_is_char)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_char);
	    }
	  if (f == g_is_string)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_string);
	    }
	}
      if ((optimize_op(cadr(expr)) == HOP_SAFE_C_SQ) &&
	  (c_callee(cadr(expr)) == g_is_eq))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(not_is_eq_sq);
	}

      if (optimize_op(cadr(expr)) == HOP_SAFE_C_SS)
	{
	  if (c_callee(cadr(expr)) == g_is_eq)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(not_is_eq_ss);
	    }
	}

      if (optimize_op(cadr(expr)) == HOP_SAFE_C_C)
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  if (c_callee(cadr(expr)) == g_is_pair_car)
	    return(not_is_pair_car);
	  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)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);
      if (is_symbol(arg1))
	{
	  if ((s7_is_integer(arg2)) &&
	      (s7_integer(arg2) >= 0))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      switch (s7_integer(arg2)) /* (might be big int) */
		{
		case 0: return(vector_ref_ic_0);
		case 1: return(vector_ref_ic_1);
		case 2: return(vector_ref_ic_2);
		case 3: return(vector_ref_ic_3);
		default: return(vector_ref_ic);
		}
	    }

	  if (is_global(arg1))
	    {
	      if (is_symbol(arg2))
		{
		  set_optimize_op(expr, HOP_SAFE_C_C);
		  if (is_immutable_symbol(arg1))
		    {
		      s7_pointer vect;
		      vect = slot_value(global_slot(arg1));
		      if ((is_normal_vector(vect)) &&
			  (vector_rank(vect) == 1))
			{
			  set_opt_vector(cdr(expr), vect);
			  return(constant_vector_ref_gs);
			}
		    }
		  return(vector_ref_gs);
		}
	    }

	  if ((is_pair(arg2)) &&
	      (is_safely_optimized(arg2)) &&
	      (c_callee(arg2) == g_add_cs1))
	    {
	      set_optimize_op(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_op(expr, HOP_SAFE_C_C);
	      return(vector_set_ic);
	    }
	  if (is_symbol(arg2))
	    {
	      if ((is_pair(arg3)) &&
		  (is_safely_optimized(arg3)))
		{
		  if ((c_callee(arg3) == g_vector_ref_2) &&
		      (arg1 == cadr(arg3)) &&
		      (is_symbol(caddr(arg3))))
		    {
		      set_optimize_op(expr, HOP_SAFE_C_C);
		      return(vector_set_vref);
		    }
		  if (((c_callee(arg3) == g_add_2) || (c_callee(arg3) == g_subtract_2)) &&
		      (is_symbol(caddr(arg3))) &&
		      (is_optimized(cadr(arg3))) &&
		      (c_callee(cadr(arg3)) == g_vector_ref_2) &&
		      (cadr(cadr(arg3)) == arg1))
		    {
		      set_optimize_op(expr, HOP_SAFE_C_C);
		      return(vector_set_vector_ref);
		    }
		}
	    }
	}
      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)) < sc->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)) < sc->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_op(expr, HOP_SAFE_C_C);
	  return(hash_table_ref_ss);
	}
      if ((is_symbol(cadr(expr))) &&
	  (is_h_safe_c_s(caddr(expr))) &&
	  (c_callee(caddr(expr)) == g_car))
	{
	  set_optimize_op(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_op(expr, HOP_SAFE_C_C);
      return(mod_si);
    }
  return(f);
}
#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 (!WITH_GMP)
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);

      if (arg1 == small_int(1))
	return(add_1s);

      if (arg2 == small_int(1))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(add_cs1);
	    }
	  return(add_s1);
	}
#if HAVE_OVERFLOW_CHECKS
      if (s7_is_integer(arg2))
#else
      if ((s7_is_integer(arg2)) &&
	  (integer_length(integer(arg2)) < 31))
#endif
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(add_si);
	    }
	}

      if ((is_t_real(arg2)) &&
	  (is_symbol(arg1)))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(add_sf);
	}

      if (is_t_real(arg1))
	{
	  if (is_symbol(arg2))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(add_fs);
	    }
	  if ((is_h_safe_c_c(arg2)) &&
	      (c_callee(arg2) == g_multiply_sf))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(add_f_sf);
	    }
	}
      if ((is_optimized(arg1)) &&
	  (is_optimized(arg2)))
	{
	  if ((optimize_op(arg1) == HOP_SAFE_C_SS) &&
	      (optimize_op(arg2) == HOP_SAFE_C_C) &&
	      (c_callee(arg1) == g_multiply_2) &&
	      (c_callee(arg2) == g_mul_1ss) &&
	      (cadr(arg1) == caddr(cadr(arg2))))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      set_opt_sym1(cdr(expr), caddr(arg1));
	      set_opt_sym2(cdr(expr), caddr(arg2));
	      return(add_ss_1ss);
	    }
	}
      return(add_2);
    }
#endif
  return(f);
}


static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
#if (!WITH_GMP)
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);

      if (is_symbol(arg1))
	{
#if HAVE_OVERFLOW_CHECKS
	  if (s7_is_integer(arg2))
#else
	  if ((s7_is_integer(arg2)) &&
	      (integer_length(integer(arg2)) < 31))
#endif
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(multiply_si);
	    }
	  if (arg1 == arg2)
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(sqr_ss);
	    }
	  if (is_t_real(arg2))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(multiply_sf);
	    }
	}

      if (is_symbol(arg2))
	{
#if HAVE_OVERFLOW_CHECKS
	  if (s7_is_integer(arg1))
#else
	  if ((s7_is_integer(arg1)) &&
	      (integer_length(integer(arg1)) < 31))
#endif
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(multiply_is);
	    }
	  if (is_t_real(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(multiply_fs);
	    }
	}
      if ((is_pair(arg1)) &&
	  (is_symbol(arg2)) &&
	  (car(arg1) == sc->subtract_symbol) &&
	  (is_t_real(cadr(arg1))) &&
	  (real(cadr(arg1)) == 1.0) &&
	  (is_symbol(caddr(arg1))) &&
	  (is_null(cdddr(arg1))))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(mul_1ss);
	}

      if ((is_symbol(arg1)) &&
	  (is_optimized(arg2)) &&
	  ((car(arg2) == sc->sin_symbol) || (car(arg2) == sc->cos_symbol)) &&
	  (is_symbol(cadr(arg2))))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  clear_unsafe(expr);
	  if (car(arg2) == sc->sin_symbol)
	    return(mul_s_sin_s);
	  return(mul_s_cos_s);
	}

      return(multiply_2);
    }

  if (args == 3)
    {
      s7_pointer arg1, arg2, arg3;
      arg1 = cadr(expr);
      arg2 = caddr(expr);
      arg3 = cadddr(expr);

      if ((is_t_real(arg1)) &&
	  (is_symbol(arg2)) &&
	  (is_pair(arg3)) &&
	  (car(arg3) == sc->cos_symbol) &&
	  (is_symbol(cadr(arg3))))
	{
	  set_optimize_op(expr, HOP_SAFE_C_C);
	  return(multiply_cs_cos);
	}
    }

#endif
  return(f);
}


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_op(expr, HOP_SAFE_C_C);
	      return(subtract_cs1);
	    }
	  return(subtract_s1);
	}

      if (is_t_real(arg2))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(subtract_sf);
	    }
	  if ((is_pair(arg1)) &&
	      (is_safely_optimized(arg1)))
	    {
	      if (c_callee(arg1) == g_random_rc)
		{
		  set_optimize_op(expr, HOP_SAFE_C_C);
		  return(sub_random_rc);
		}
	    }
	}

      if (is_t_real(arg1))
	{
	  if (is_symbol(arg2))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(subtract_fs);
	    }
	  if ((is_h_safe_c_c(arg2)) &&
	      (c_callee(arg2) == g_sqr_ss))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(subtract_f_sqr);
	    }
	}

      if (s7_is_integer(arg2))
	{
	  if (is_symbol(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(subtract_csn);
	    }
	  if ((is_safely_optimized(arg1)) &&
	      (c_callee(arg1) == g_random_ic))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(sub_random_ic);
	    }
	}

      if (is_t_real(arg2))
	return(subtract_2f);

      return(subtract_2);
    }
#endif
  return(f);
}


static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
#if (!WITH_GMP)
  if (args == 1)
    return(invert_1);

  if (args == 2)
    {
      s7_pointer arg1;
      arg1 = cadr(expr);
      if ((is_t_real(arg1)) &&
	  (real(arg1) == 1.0))
	return(divide_1r);
    }
#endif
  return(f);
}

#if (!WITH_GMP)
static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if ((args == 2) &&
      (is_t_real(cadr(expr))) &&
      (!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) &&
      (is_t_real(cadr(expr))) &&
      (!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 ((args == 1) &&
      (is_safely_optimized(cadr(expr))) &&
      (optimize_op(cadr(expr)) == HOP_SAFE_C_C) &&
      (c_callee(cadr(expr)) == g_mod_si))
    {
      set_optimize_op(expr, HOP_SAFE_C_C);
      return(mod_si_is_zero);
    }
  return(f);
}


static s7_pointer equal_chooser(s7_scheme *sc, s7_pointer ur_f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);

      if (s7_is_integer(arg2))
	{
	  if (is_safely_optimized(arg1))
	    {
	      s7_function f;
	      f = c_callee(arg1);
	      if (f == g_length)
		{
		  if (optimize_op(arg1) == HOP_SAFE_C_S)
		    {
		      set_optimize_op(expr, HOP_SAFE_C_C);
		      return(equal_length_ic);
		    }
		}
	      if ((f == g_mod_si) &&
		  (integer(arg2) == 0))
		{
		  set_optimize_op(expr, HOP_SAFE_C_C);
		  return(mod_si_is_zero);
		}
	    }
	  if (is_symbol(arg1))
	    {
	      set_optimize_op(expr, HOP_SAFE_C_C);
	      return(equal_s_ic);
	    }
	}
      return(equal_2);
    }
  return(ur_f);
}

static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      s7_pointer arg2;
      arg2 = caddr(expr);
      if (is_integer(arg2))
	{
	  if (is_h_safe_c_s(cadr(expr)))
	    {
	      s7_function f;
	      f = c_callee(cadr(expr));
	      if (f == g_length)
		{
		  set_optimize_op(expr, HOP_SAFE_C_C);
		  return(less_length_ic);
		}
	    }
	  if (integer(arg2) == 0)
	    return(less_s0);

	  if ((integer(arg2) < s7_int32_max) &&
	      (integer(arg2) > s7_int32_min))
	    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)
    {
      s7_pointer arg2;
      arg2 = caddr(expr);
      if ((is_integer(arg2)) &&
	  (integer(arg2) < s7_int32_max) &&
	  (integer(arg2) > s7_int32_min))
	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)
    {
      s7_pointer arg2;
      arg2 = caddr(expr);

      if ((is_integer(arg2)) &&
	  (integer(arg2) < s7_int32_max) &&
	  (integer(arg2) > s7_int32_min))
	return(greater_s_ic);

      if ((is_t_real(arg2)) &&
	  (real(arg2) < s7_int32_max) &&
	  (real(arg2) > s7_int32_min))
	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)
    {
      s7_pointer arg2;
      arg2 = caddr(expr);
      if (is_integer(arg2))
	{
	  if (is_h_safe_c_s(cadr(expr)))
	    {
	      s7_function f;
	      f = c_callee(cadr(expr));
	      if (f == g_length)
		{
		  set_optimize_op(expr, HOP_SAFE_C_C);
		  return(geq_length_ic);
		}
	    }
	  if ((integer(arg2) < s7_int32_max) &&
	      (integer(arg2) > s7_int32_min))
	    return(geq_s_ic);
	}
      if ((is_t_real(arg2)) &&
	  (real(arg2) < s7_int32_max) &&
	  (real(arg2) > s7_int32_min))
	return(geq_s_fc);

      return(geq_2);
    }
  return(f);
}
#endif
/* end (!WITH_GMP) */

static bool returns_char(s7_scheme *sc, s7_pointer arg)
{
  /* also if arg is immutable symbol + value is char */
  if (s7_is_character(arg)) return(true);
  if ((is_h_optimized(arg)) &&
      (is_c_function(opt_cfunc(arg))))
    {
      s7_pointer sig;
      sig = c_function_signature(opt_cfunc(arg));
      return((sig) && 
	     (is_pair(sig)) &&
	     (car(sig) == sc->is_char_symbol));
    }
  return(false);
}

static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (args == 2)
    {
      s7_pointer arg1, arg2;
      arg1 = cadr(expr);
      arg2 = caddr(expr);
      if ((returns_char(sc, arg1)) && (returns_char(sc, arg2)))
	return(simple_char_eq);
      if ((is_symbol(arg1)) &&
	  (s7_is_character(arg2)))
	{
	  set_optimize_op(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 void check_for_substring_temp(s7_scheme *sc, s7_pointer expr)
{
  s7_pointer p, np = NULL, ap = NULL, sp = NULL, arg;
  int pairs = 0;
  /* a bit tricky -- accept temp only if there's just one inner expression and it calls substring */
  for (p = cdr(expr); is_pair(p); p = cdr(p))
    {
      arg = car(p);
      if (is_pair(arg))
	{
	  pairs++;
	  if ((is_symbol(car(arg))) &&
	      (is_safely_optimized(arg)))
	    {
	      if (c_callee(arg) == g_substring)
		np = arg;
	      else
		{
		  if (c_callee(arg) == g_number_to_string)
		    sp = arg;
		  else
		    {
		      if (c_callee(arg) == g_string_append)
			ap = arg;
		      else
			{
			  if (c_callee(arg) == g_symbol_to_string)
			    set_c_function(arg, symbol_to_string_uncopied);
			  else
			    {
			      if ((c_callee(arg) == g_read_line) &&
				  (is_pair(cdr(arg))))
				set_c_function(arg, read_line_uncopied);
			    }}}}}}}
  if (pairs == 1)
    {
      if (np)
	set_c_function(np, substring_to_temp);
      else
	{
	  if (sp)
	    set_c_function(sp, number_to_string_temp);
	  else
	    {
	      if (ap)
		{
		  for (p = ap; is_pair(p); p = cdr(p))
		    {
		      /* make sure there are no embedded uses of the temp string */
		      arg = car(p);
		      if ((is_pair(arg)) &&
			  (is_safely_optimized(arg)))
			{
			  if (c_callee(arg) == g_substring_to_temp)
			    set_c_function(arg, slot_value(global_slot(sc->substring_symbol)));
			  else
			    {
			      if (c_callee(arg) == g_string_append_to_temp)
				set_c_function(arg, slot_value(global_slot(sc->string_append_symbol)));
			    }
			}
		    }
		  set_c_function(ap, string_append_to_temp);
		}
	    }
	}
    }
}

static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  if (((args == 2) || (args == 3)) &&
      (s7_is_character(cadr(expr))))
     return(char_position_csi);
  return(f);
}

static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, 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, expr);
  if (args == 2)
    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, expr);
  if (args == 2)
    return(string_greater_2);
  return(f);
}

static s7_pointer string_to_symbol_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return(f);
}


static s7_pointer string_ref_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return(f);
}

static s7_pointer string_set_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  return(f);
}

static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int args, s7_pointer expr)
{
  check_for_substring_temp(sc, expr);
  return(f);
}


static s7_pointer or_direct;
static s7_pointer g_or_direct(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer x;
      x = car(p);
      if (is_symbol(x))
	x = find_symbol_checked(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 = find_symbol_checked(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 = find_symbol_checked(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(find_symbol_checked(sc, p));
  return(p);
}


static s7_pointer or_all_x, or_all_x_2, or_all_x_2s;
static s7_pointer g_or_all_x(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer x;
      x = c_call(p)(sc, car(p));
      if (is_true(sc, x))
	return(x);
    }
  return(sc->F);
}

static s7_pointer g_or_all_x_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  p = c_call(args)(sc, car(args));
  if (p != sc->F) return(p);
  p = cdr(args);
  return(c_call(p)(sc, car(p)));
}

static s7_pointer g_or_all_x_2s(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  p = car(args);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(p)));
  p = c_call(p)(sc, sc->t1_1);
  if (p != sc->F) return(p);
  p = cadr(args);
  set_car(sc->t1_1, find_symbol_unchecked(sc, cadr(p)));
  return(c_call(p)(sc, sc->t1_1));
}


static s7_pointer and_all_x, and_all_x_2;
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 = c_call(p)(sc, car(p));
      if (is_false(sc, x))
	return(x);
    }
  return(x);
}

static s7_pointer g_and_all_x_2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  p = c_call(args)(sc, car(args));
  if (p == sc->F) return(p);
  p = cdr(args);
  return(c_call(p)(sc, car(p)));
}


static s7_pointer if_all_x1;
static s7_pointer g_if_all_x1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  if (is_true(sc, c_call(args)(sc, car(args))))
    p = cdr(args);
  else return(sc->unspecified);
  return(c_call(p)(sc, car(p)));
}

static s7_pointer if_all_x2;
static s7_pointer g_if_all_x2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  if (is_true(sc, c_call(args)(sc, car(args))))
    p = cdr(args);
  else p = cddr(args);
  return(c_call(p)(sc, car(p)));
}


static s7_pointer if_all_not_x1;
static s7_pointer g_if_all_not_x1(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  if (is_false(sc, c_call(args)(sc, cadar(args))))
    p = cdr(args);
  else return(sc->unspecified);
  return(c_call(p)(sc, car(p)));
}

static s7_pointer if_all_not_x2;
static s7_pointer g_if_all_not_x2(s7_scheme *sc, s7_pointer args)
{
  s7_pointer p;
  if (is_false(sc, c_call(args)(sc, cadar(args))))
    p = cdr(args);
  else p = cddr(args);
  return(c_call(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, c_call(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, c_call(args)(sc, car(args))))
    return(cadr(cadr(args)));
  return(c_call(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;
  set_car(sc->t1_1, find_symbol_checked(sc, cadar(args)));
  for (p = args; is_pair(p); p = cdr(p))
    {
      s7_pointer x;
      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;
  set_car(sc->t1_1, find_symbol_checked(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;
  set_car(sc->t1_1, find_symbol_checked(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));
}


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;
  /* the "safe_function" business here doesn't matter -- this is after the optimizer decides what is safe */
  uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, doc);
  s7_function_set_class(uf, cls);
  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));
#ifndef WITHOUT_CHOOSERS
  c_function_chooser(f) = chooser;
#endif
  return(f);
}


static void init_choosers(s7_scheme *sc)
{
  s7_pointer f;

#if (!WITH_GMP)
  s7_if_set_function(slot_value(global_slot(sc->modulo_symbol)), modulo_if);
  s7_rf_set_function(slot_value(global_slot(sc->modulo_symbol)), modulo_rf);
  s7_rf_set_function(slot_value(global_slot(sc->remainder_symbol)), remainder_rf);
  s7_if_set_function(slot_value(global_slot(sc->remainder_symbol)), remainder_if);
  s7_rf_set_function(slot_value(global_slot(sc->quotient_symbol)), quotient_rf);
  s7_if_set_function(slot_value(global_slot(sc->quotient_symbol)), quotient_if);
  s7_if_set_function(slot_value(global_slot(sc->numerator_symbol)), numerator_if);
  s7_if_set_function(slot_value(global_slot(sc->denominator_symbol)), denominator_if);
  s7_rf_set_function(slot_value(global_slot(sc->real_part_symbol)), real_part_rf);
  s7_rf_set_function(slot_value(global_slot(sc->imag_part_symbol)), imag_part_rf);
  s7_gf_set_function(slot_value(global_slot(sc->rationalize_symbol)), rationalize_pf);

  s7_if_set_function(slot_value(global_slot(sc->ceiling_symbol)), ceiling_if);
  s7_if_set_function(slot_value(global_slot(sc->truncate_symbol)), truncate_if);
  s7_if_set_function(slot_value(global_slot(sc->round_symbol)), round_if);
  s7_if_set_function(slot_value(global_slot(sc->floor_symbol)), floor_if);
  s7_if_set_function(slot_value(global_slot(sc->logior_symbol)), logior_if);
  s7_if_set_function(slot_value(global_slot(sc->logand_symbol)), logand_if);
  s7_if_set_function(slot_value(global_slot(sc->logxor_symbol)), logxor_if);
  s7_if_set_function(slot_value(global_slot(sc->lognot_symbol)), lognot_if);
  s7_if_set_function(slot_value(global_slot(sc->ash_symbol)), ash_if);
  s7_if_set_function(slot_value(global_slot(sc->gcd_symbol)), gcd_if);
  s7_if_set_function(slot_value(global_slot(sc->lcm_symbol)), lcm_if);
  s7_rf_set_function(slot_value(global_slot(sc->max_symbol)), max_rf);
  s7_if_set_function(slot_value(global_slot(sc->max_symbol)), max_if);
  s7_rf_set_function(slot_value(global_slot(sc->min_symbol)), min_rf);
  s7_if_set_function(slot_value(global_slot(sc->min_symbol)), min_if);

  s7_rf_set_function(slot_value(global_slot(sc->divide_symbol)), divide_rf);
  s7_if_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_if);
  s7_rf_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_rf);
  s7_rf_set_function(slot_value(global_slot(sc->add_symbol)), add_rf);
  s7_if_set_function(slot_value(global_slot(sc->add_symbol)), add_if);
  s7_rf_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_rf);
  s7_if_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_if);
#if WITH_ADD_PF
  s7_gf_set_function(slot_value(global_slot(sc->multiply_symbol)), multiply_pf);
  s7_gf_set_function(slot_value(global_slot(sc->add_symbol)), add_pf);
  s7_gf_set_function(slot_value(global_slot(sc->subtract_symbol)), subtract_pf);
#endif

  s7_rf_set_function(slot_value(global_slot(sc->sin_symbol)), sin_rf);
  s7_rf_set_function(slot_value(global_slot(sc->cos_symbol)), cos_rf);
  s7_rf_set_function(slot_value(global_slot(sc->tan_symbol)), tan_rf);
  s7_rf_set_function(slot_value(global_slot(sc->sinh_symbol)), sinh_rf);
  s7_rf_set_function(slot_value(global_slot(sc->cosh_symbol)), cosh_rf);
  s7_rf_set_function(slot_value(global_slot(sc->tanh_symbol)), tanh_rf);
  s7_rf_set_function(slot_value(global_slot(sc->atan_symbol)), atan_rf);
  s7_rf_set_function(slot_value(global_slot(sc->exp_symbol)), exp_rf);

  s7_gf_set_function(slot_value(global_slot(sc->asin_symbol)), asin_pf);
  s7_gf_set_function(slot_value(global_slot(sc->acos_symbol)), acos_pf);
  s7_gf_set_function(slot_value(global_slot(sc->asinh_symbol)), asinh_pf);
  s7_gf_set_function(slot_value(global_slot(sc->acosh_symbol)), acosh_pf);
  s7_gf_set_function(slot_value(global_slot(sc->atanh_symbol)), atanh_pf);

  s7_rf_set_function(slot_value(global_slot(sc->random_symbol)), random_rf);
  s7_if_set_function(slot_value(global_slot(sc->random_symbol)), random_if);

  s7_gf_set_function(slot_value(global_slot(sc->expt_symbol)), expt_pf);
  s7_gf_set_function(slot_value(global_slot(sc->number_to_string_symbol)), number_to_string_pf);
  s7_gf_set_function(slot_value(global_slot(sc->string_to_number_symbol)), string_to_number_pf);

  s7_rf_set_function(slot_value(global_slot(sc->abs_symbol)), fabs_rf);
  s7_if_set_function(slot_value(global_slot(sc->abs_symbol)), abs_if);
#if (!WITH_PURE_S7)
  s7_gf_set_function(slot_value(global_slot(sc->make_rectangular_symbol)), make_complex_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_polar_symbol)), make_polar_pf);
#endif
  s7_rf_set_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_rf);
  s7_if_set_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_if);
  s7_gf_set_function(slot_value(global_slot(sc->complex_symbol)), make_complex_pf); /* actually complex */

  s7_pf_set_function(slot_value(global_slot(sc->eq_symbol)), equal_pf);
  s7_pf_set_function(slot_value(global_slot(sc->lt_symbol)), less_pf);
  s7_pf_set_function(slot_value(global_slot(sc->leq_symbol)), leq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->geq_symbol)), geq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->gt_symbol)), gt_pf);
#endif /* !gmp */

  s7_if_set_function(slot_value(global_slot(sc->pair_line_number_symbol)), pair_line_number_if);
  s7_if_set_function(slot_value(global_slot(sc->hash_table_entries_symbol)), hash_table_entries_if);
#if (!WITH_PURE_S7)
#if (!WITH_GMP)
  s7_if_set_function(slot_value(global_slot(sc->integer_length_symbol)), integer_length_if);
#endif
  s7_if_set_function(slot_value(global_slot(sc->vector_length_symbol)), vector_length_if);
  s7_if_set_function(slot_value(global_slot(sc->string_length_symbol)), string_length_if);

  s7_pf_set_function(slot_value(global_slot(sc->string_fill_symbol)), string_fill_pf);
  s7_pf_set_function(slot_value(global_slot(sc->vector_fill_symbol)), vector_fill_pf);
#endif
  s7_pf_set_function(slot_value(global_slot(sc->length_symbol)), length_pf);
  s7_pf_set_function(slot_value(global_slot(sc->fill_symbol)), fill_pf);
  s7_gf_set_function(slot_value(global_slot(sc->copy_symbol)), copy_pf);
  s7_gf_set_function(slot_value(global_slot(sc->reverse_symbol)), reverse_pf);
  s7_pf_set_function(slot_value(global_slot(sc->not_symbol)), not_pf);

  s7_if_set_function(slot_value(global_slot(sc->char_to_integer_symbol)), char_to_integer_if);
  s7_pf_set_function(slot_value(global_slot(sc->char_eq_symbol)), char_eq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_gt_symbol)), char_gt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_geq_symbol)), char_geq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_lt_symbol)), char_lt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_leq_symbol)), char_leq_pf);

  s7_pf_set_function(slot_value(global_slot(sc->string_eq_symbol)), string_eq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_lt_symbol)), string_lt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_leq_symbol)), string_leq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_gt_symbol)), string_gt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_geq_symbol)), string_geq_pf);

  s7_gf_set_function(slot_value(global_slot(sc->string_upcase_symbol)), string_upcase_pf);
  s7_gf_set_function(slot_value(global_slot(sc->string_downcase_symbol)), string_downcase_pf);
  s7_gf_set_function(slot_value(global_slot(sc->char_position_symbol)), char_position_pf);
  s7_gf_set_function(slot_value(global_slot(sc->string_position_symbol)), string_position_pf);

#if (!WITH_PURE_S7)
  s7_pf_set_function(slot_value(global_slot(sc->char_ci_eq_symbol)), char_ci_eq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_ci_gt_symbol)), char_ci_gt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_ci_geq_symbol)), char_ci_geq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_ci_lt_symbol)), char_ci_lt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_ci_leq_symbol)), char_ci_leq_pf);

  s7_pf_set_function(slot_value(global_slot(sc->string_ci_eq_symbol)), string_ci_eq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_ci_lt_symbol)), string_ci_lt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_ci_leq_symbol)), string_ci_leq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_ci_gt_symbol)), string_ci_gt_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_ci_geq_symbol)), string_ci_geq_pf);
#endif

#if (!WITH_GMP)
  s7_pf_set_function(slot_value(global_slot(sc->is_even_symbol)), is_even_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_odd_symbol)), is_odd_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_nan_symbol)), is_nan_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_infinite_symbol)), is_infinite_pf);
#endif
  s7_pf_set_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_pf);
  s7_pf_set_function(slot_value(global_slot(sc->hash_table_ref_symbol)), hash_table_ref_pf);
  s7_pf_set_function(slot_value(global_slot(sc->hash_table_set_symbol)), hash_table_set_pf);
  s7_pf_set_function(slot_value(global_slot(sc->vector_ref_symbol)), vector_ref_pf);
  s7_pf_set_function(slot_value(global_slot(sc->vector_set_symbol)), vector_set_pf); 
  s7_pf_set_function(slot_value(global_slot(sc->string_ref_symbol)), string_ref_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_set_symbol)), string_set_pf);
  s7_pf_set_function(slot_value(global_slot(sc->list_ref_symbol)), list_ref_pf);
  s7_pf_set_function(slot_value(global_slot(sc->list_set_symbol)), list_set_pf);
  s7_pf_set_function(slot_value(global_slot(sc->let_ref_symbol)), let_ref_pf);
  s7_pf_set_function(slot_value(global_slot(sc->let_set_symbol)), let_set_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_to_byte_vector_symbol)), string_to_byte_vector_pf);

  s7_rf_set_function(slot_value(global_slot(sc->float_vector_ref_symbol)), float_vector_ref_rf);
  s7_rf_set_function(slot_value(global_slot(sc->float_vector_set_symbol)), float_vector_set_rf);

  s7_if_set_function(slot_value(global_slot(sc->int_vector_ref_symbol)), int_vector_ref_if);
  s7_if_set_function(slot_value(global_slot(sc->int_vector_set_symbol)), int_vector_set_if);

  s7_pf_set_function(slot_value(global_slot(sc->caaaar_symbol)), caaaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caaadr_symbol)), caaadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caaar_symbol)), caaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caadar_symbol)), caadar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caaddr_symbol)), caaddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caadr_symbol)), caadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caar_symbol)), caar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cadaar_symbol)), cadaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cadadr_symbol)), cadadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cadar_symbol)), cadar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caddar_symbol)), caddar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cadddr_symbol)), cadddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->caddr_symbol)), caddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cadr_symbol)), cadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->car_symbol)), car_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdaaar_symbol)), cdaaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdaadr_symbol)), cdaadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdaar_symbol)), cdaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdadar_symbol)), cdadar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdaddr_symbol)), cdaddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdadr_symbol)), cdadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdar_symbol)), cdar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cddaar_symbol)), cddaar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cddadr_symbol)), cddadr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cddar_symbol)), cddar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdddar_symbol)), cdddar_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cddddr_symbol)), cddddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdddr_symbol)), cdddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cddr_symbol)), cddr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cdr_symbol)), cdr_pf);

  s7_pf_set_function(slot_value(global_slot(sc->set_car_symbol)), set_car_pf);
  s7_pf_set_function(slot_value(global_slot(sc->set_cdr_symbol)), set_cdr_pf);
  s7_pf_set_function(slot_value(global_slot(sc->list_tail_symbol)), list_tail_pf);
  s7_pf_set_function(slot_value(global_slot(sc->assoc_symbol)), assoc_pf);
  s7_pf_set_function(slot_value(global_slot(sc->member_symbol)), member_pf);

  s7_gf_set_function(slot_value(global_slot(sc->cons_symbol)), cons_pf);
  s7_gf_set_function(slot_value(global_slot(sc->list_symbol)), list_pf);
  s7_gf_set_function(slot_value(global_slot(sc->int_vector_symbol)), int_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->float_vector_symbol)), float_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->vector_symbol)), vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->c_pointer_symbol)), c_pointer_pf);
  s7_gf_set_function(slot_value(global_slot(sc->vector_dimensions_symbol)), vector_dimensions_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_shared_vector_symbol)), make_shared_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_vector_symbol)), make_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_float_vector_symbol)), make_float_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_int_vector_symbol)), make_int_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_list_symbol)), make_list_pf);
  s7_gf_set_function(slot_value(global_slot(sc->make_string_symbol)), make_string_pf);

  s7_pf_set_function(slot_value(global_slot(sc->memq_symbol)), memq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->memv_symbol)), memv_pf);
  s7_pf_set_function(slot_value(global_slot(sc->assq_symbol)), assq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->assv_symbol)), assv_pf);
#if (!WITH_PURE_S7)
  s7_gf_set_function(slot_value(global_slot(sc->list_to_vector_symbol)), list_to_vector_pf);
  s7_gf_set_function(slot_value(global_slot(sc->vector_to_list_symbol)), vector_to_list_pf);
  s7_gf_set_function(slot_value(global_slot(sc->string_to_list_symbol)), string_to_list_pf);
  s7_gf_set_function(slot_value(global_slot(sc->let_to_list_symbol)), let_to_list_pf);
#endif
  s7_gf_set_function(slot_value(global_slot(sc->random_state_to_list_symbol)), random_state_to_list_pf);

  s7_pf_set_function(slot_value(global_slot(sc->is_aritable_symbol)), is_aritable_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_boolean_symbol)), is_boolean_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_byte_vector_symbol)), is_byte_vector_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_char_symbol)), is_char_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_complex_symbol)), is_complex_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_constant_symbol)), is_constant_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_continuation_symbol)), is_continuation_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_c_pointer_symbol)), is_c_pointer_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_dilambda_symbol)), is_dilambda_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_eof_object_symbol)), is_eof_object_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_float_vector_symbol)), is_float_vector_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_gensym_symbol)), is_gensym_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_hash_table_symbol)), is_hash_table_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_input_port_symbol)), is_input_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_integer_symbol)), is_integer_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_int_vector_symbol)), is_int_vector_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_keyword_symbol)), is_keyword_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_let_symbol)), is_let_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_list_symbol)), is_list_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_macro_symbol)), is_macro_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_null_symbol)), is_null_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_number_symbol)), is_number_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_output_port_symbol)), is_output_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_pair_symbol)), is_pair_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_procedure_symbol)), is_procedure_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_provided_symbol)), is_provided_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_random_state_symbol)), is_random_state_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_rational_symbol)), is_rational_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_real_symbol)), is_real_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_string_symbol)), is_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_symbol_symbol)), is_symbol_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_vector_symbol)), is_vector_pf);

  s7_pf_set_function(slot_value(global_slot(sc->is_iterator_symbol)), is_iterator_pf);
  s7_pf_set_function(slot_value(global_slot(sc->iterator_is_at_end_symbol)), iterator_is_at_end_pf);
  s7_pf_set_function(slot_value(global_slot(sc->iterator_sequence_symbol)), iterator_sequence_pf);
  s7_pf_set_function(slot_value(global_slot(sc->iterate_symbol)), iterate_pf);
  s7_gf_set_function(slot_value(global_slot(sc->iterate_symbol)), iterate_gf);
  s7_gf_set_function(slot_value(global_slot(sc->make_iterator_symbol)), make_iterator_pf);
#if (!WITH_GMP)
  s7_gf_set_function(slot_value(global_slot(sc->random_state_symbol)), random_state_pf);
#endif
  s7_pf_set_function(slot_value(global_slot(sc->reverseb_symbol)), reverse_in_place_pf);
  s7_gf_set_function(slot_value(global_slot(sc->sort_symbol)), sort_pf);
  s7_pf_set_function(slot_value(global_slot(sc->provide_symbol)), provide_pf);
  s7_pf_set_function(slot_value(global_slot(sc->symbol_symbol)), symbol_pf);
  s7_pf_set_function(slot_value(global_slot(sc->string_to_symbol_symbol)), string_to_symbol_pf);
  s7_gf_set_function(slot_value(global_slot(sc->symbol_to_string_symbol)), symbol_to_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->make_keyword_symbol)), make_keyword_pf);
  s7_pf_set_function(slot_value(global_slot(sc->keyword_to_symbol_symbol)), keyword_to_symbol_pf);
  s7_pf_set_function(slot_value(global_slot(sc->symbol_to_keyword_symbol)), symbol_to_keyword_pf);
  s7_pf_set_function(slot_value(global_slot(sc->symbol_to_value_symbol)), symbol_to_value_pf);
  s7_gf_set_function(slot_value(global_slot(sc->gensym_symbol)), gensym_pf);
  s7_gf_set_function(slot_value(global_slot(sc->arity_symbol)), arity_pf);

  s7_pf_set_function(slot_value(global_slot(sc->is_openlet_symbol)), is_openlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->curlet_symbol)), curlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->owlet_symbol)), owlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->rootlet_symbol)), rootlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->outlet_symbol)), outlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->openlet_symbol)), openlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->coverlet_symbol)), coverlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->funclet_symbol)), funclet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->cutlet_symbol)), cutlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->varlet_symbol)), varlet_pf);
  s7_pf_set_function(slot_value(global_slot(sc->unlet_symbol)), unlet_pf);
  s7_gf_set_function(slot_value(global_slot(sc->inlet_symbol)), inlet_pf);

  s7_pf_set_function(slot_value(global_slot(sc->gc_symbol)), gc_pf);
  s7_gf_set_function(slot_value(global_slot(sc->help_symbol)), help_pf);
  s7_gf_set_function(slot_value(global_slot(sc->procedure_source_symbol)), procedure_source_pf);
  s7_gf_set_function(slot_value(global_slot(sc->procedure_documentation_symbol)), procedure_documentation_pf);
  s7_gf_set_function(slot_value(global_slot(sc->procedure_signature_symbol)), procedure_signature_pf);

  s7_pf_set_function(slot_value(global_slot(sc->is_char_alphabetic_symbol)), is_char_alphabetic_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_char_lower_case_symbol)), is_char_lower_case_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_char_numeric_symbol)), is_char_numeric_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_char_upper_case_symbol)), is_char_upper_case_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_char_whitespace_symbol)), is_char_whitespace_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_upcase_symbol)), char_upcase_pf);
  s7_pf_set_function(slot_value(global_slot(sc->char_downcase_symbol)), char_downcase_pf);
  s7_pf_set_function(slot_value(global_slot(sc->integer_to_char_symbol)), integer_to_char_pf);

  s7_pf_set_function(slot_value(global_slot(sc->current_input_port_symbol)), current_input_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->current_output_port_symbol)), current_output_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->current_error_port_symbol)), current_error_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->close_input_port_symbol)), close_input_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->close_output_port_symbol)), close_output_port_pf);
  s7_pf_set_function(slot_value(global_slot(sc->flush_output_port_symbol)), flush_output_port_pf);
  s7_gf_set_function(slot_value(global_slot(sc->port_filename_symbol)), port_filename_pf);
  s7_gf_set_function(slot_value(global_slot(sc->port_line_number_symbol)), port_line_number_pf);
  s7_pf_set_function(slot_value(global_slot(sc->with_input_from_file_symbol)), with_input_from_file_pf);
  s7_pf_set_function(slot_value(global_slot(sc->with_input_from_string_symbol)), with_input_from_string_pf);
  s7_gf_set_function(slot_value(global_slot(sc->with_output_to_string_symbol)), with_output_to_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->with_output_to_file_symbol)), with_output_to_file_pf);
  s7_gf_set_function(slot_value(global_slot(sc->call_with_output_string_symbol)), call_with_output_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->call_with_output_file_symbol)), call_with_output_file_pf);
  s7_pf_set_function(slot_value(global_slot(sc->call_with_input_string_symbol)), call_with_input_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->call_with_input_file_symbol)), call_with_input_file_pf);

#if WITH_SYSTEM_EXTRAS
  s7_gf_set_function(slot_value(global_slot(sc->directory_to_list_symbol)), directory_to_list_pf);
#endif
  s7_if_set_function(slot_value(global_slot(sc->write_byte_symbol)), write_byte_if);
  s7_pf_set_function(slot_value(global_slot(sc->write_char_symbol)), write_char_pf);
  s7_pf_set_function(slot_value(global_slot(sc->read_byte_symbol)), read_byte_pf);
  s7_pf_set_function(slot_value(global_slot(sc->read_char_symbol)), read_char_pf);
  s7_pf_set_function(slot_value(global_slot(sc->peek_char_symbol)), peek_char_pf);
  s7_pf_set_function(slot_value(global_slot(sc->newline_symbol)), newline_pf);
  s7_pf_set_function(slot_value(global_slot(sc->write_symbol)), write_pf);
  s7_pf_set_function(slot_value(global_slot(sc->write_string_symbol)), write_string_pf);
  s7_gf_set_function(slot_value(global_slot(sc->read_string_symbol)), read_string_pf);
  s7_pf_set_function(slot_value(global_slot(sc->display_symbol)), display_pf);
  s7_gf_set_function(slot_value(global_slot(sc->read_symbol)), read_pf);
  s7_gf_set_function(slot_value(global_slot(sc->read_line_symbol)), read_line_pf);
  s7_gf_set_function(slot_value(global_slot(sc->object_to_string_symbol)), object_to_string_pf);

  s7_pf_set_function(slot_value(global_slot(sc->is_eq_symbol)), is_eq_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_eqv_symbol)), is_eqv_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_pf);
  s7_pf_set_function(slot_value(global_slot(sc->is_morally_equal_symbol)), is_morally_equal_pf);


  /* + */
  f = set_function_chooser(sc, sc->add_symbol, add_chooser);
  sc->add_class = c_function_class(f);

  add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false, "+ opt");
  add_1s = make_function_with_class(sc, f, "+", g_add_1s, 2, 0, false, "+ opt");
  add_s1 = make_function_with_class(sc, f, "+", g_add_s1, 2, 0, false, "+ opt");
  add_cs1 = make_function_with_class(sc, f, "+", g_add_cs1, 2, 0, false, "+ opt");
  add_si = make_function_with_class(sc, f, "+", g_add_si, 2, 0, false, "+ opt");
  add_sf = make_function_with_class(sc, f, "+", g_add_sf, 2, 0, false, "+ opt");
  add_fs = make_function_with_class(sc, f, "+", g_add_fs, 2, 0, false, "+ opt");
  add_ss_1ss = make_function_with_class(sc, f, "+", g_add_ss_1ss, 2, 0, false, "+ opt");
  add_f_sf = make_function_with_class(sc, f, "+", g_add_f_sf, 2, 0, false, "+ opt");

  /* - */
  f = set_function_chooser(sc, sc->subtract_symbol, subtract_chooser);
  sc->subtract_class = c_function_class(f);
  subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false, "- opt");
  subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false, "- opt");
  subtract_s1 = make_function_with_class(sc, f, "-", g_subtract_s1, 2, 0, false, "- opt");
  subtract_cs1 = make_function_with_class(sc, f, "-", g_subtract_cs1, 2, 0, false, "- opt");
  subtract_csn = make_function_with_class(sc, f, "-", g_subtract_csn, 2, 0, false, "- opt");
  subtract_sf = make_function_with_class(sc, f, "-", g_subtract_sf, 2, 0, false, "- opt");
  subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false, "- opt");
  subtract_fs = make_function_with_class(sc, f, "-", g_subtract_fs, 2, 0, false, "- opt");
  subtract_f_sqr = make_function_with_class(sc, f, "-", g_subtract_f_sqr, 2, 0, false, "- opt");
#if (!WITH_GMP)
  sub_random_ic = make_function_with_class(sc, f, "random", g_sub_random_ic, 2, 0, false, "- opt");
  sub_random_rc = make_function_with_class(sc, f, "random", g_sub_random_rc, 2, 0, false, "- opt");
#endif


  /* * */
  f = set_function_chooser(sc, sc->multiply_symbol, multiply_chooser);
  sc->multiply_class = c_function_class(f);
#if (!WITH_GMP)
  multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false, "* opt");
  multiply_is = make_function_with_class(sc, f, "*", g_multiply_is, 2, 0, false, "* opt");
  multiply_si = make_function_with_class(sc, f, "*", g_multiply_si, 2, 0, false, "* opt");
  multiply_fs = make_function_with_class(sc, f, "*", g_multiply_fs, 2, 0, false, "* opt");
  multiply_sf = make_function_with_class(sc, f, "*", g_multiply_sf, 2, 0, false, "* opt");

  sqr_ss = make_function_with_class(sc, f, "*", g_sqr_ss, 2, 0, false, "* opt");
  mul_1ss = make_function_with_class(sc, f, "*", g_mul_1ss, 2, 0, false, "* opt");
  multiply_cs_cos = make_function_with_class(sc, f, "*", g_multiply_cs_cos, 3, 0, false, "* opt");
  mul_s_sin_s = make_function_with_class(sc, f, "*", g_mul_s_sin_s, 2, 0, false, "* opt");
  mul_s_cos_s = make_function_with_class(sc, f, "*", g_mul_s_cos_s, 2, 0, false, "* opt");
#endif

  /* / */
  f = set_function_chooser(sc, sc->divide_symbol, divide_chooser);
#if (!WITH_GMP)
  invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false, "/ opt");
  divide_1r = make_function_with_class(sc, f, "/", g_divide_1r, 2, 0, false, "/ opt");

  /* modulo */
  f = set_function_chooser(sc, sc->modulo_symbol, modulo_chooser);
  mod_si = make_function_with_class(sc, f, "modulo", g_mod_si, 2, 0, false, "modulo opt");

  /* max */
  f = set_function_chooser(sc, sc->max_symbol, max_chooser);
  max_f2 = make_function_with_class(sc, f, "max", g_max_f2, 2, 0, false, "max opt");

  /* min */
  f = set_function_chooser(sc, sc->min_symbol, min_chooser);
  min_f2 = make_function_with_class(sc, f, "min", g_min_f2, 2, 0, false, "min opt");

  /* zero? */
  set_function_chooser(sc, sc->is_zero_symbol, is_zero_chooser);

  /* = */
  f = set_function_chooser(sc, sc->eq_symbol, equal_chooser);
  sc->equal_class = c_function_class(f);

  equal_s_ic = make_function_with_class(sc, f, "=", g_equal_s_ic, 2, 0, false, "= opt");
  equal_length_ic = make_function_with_class(sc, f, "=", g_equal_length_ic, 2, 0, false, "= opt");
  equal_2 = make_function_with_class(sc, f, "=", g_equal_2, 2, 0, false, "= opt");
  mod_si_is_zero = make_function_with_class(sc, f, "=", g_mod_si_is_zero, 2, 0, false, "= opt");

  /* < */
  f = set_function_chooser(sc, sc->lt_symbol, less_chooser);

  less_s_ic = make_function_with_class(sc, f, "<", g_less_s_ic, 2, 0, false, "< opt");
  less_s0 = make_function_with_class(sc, f, "<", g_less_s0, 2, 0, false, "< opt");
  less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false, "< opt");
  less_length_ic = make_function_with_class(sc, f, "<", g_less_length_ic, 2, 0, false, "< opt");

  /* > */
  f = set_function_chooser(sc, sc->gt_symbol, greater_chooser);
  greater_s_ic = make_function_with_class(sc, f, ">", g_greater_s_ic, 2, 0, false, "> opt");
  greater_s_fc = make_function_with_class(sc, f, ">", g_greater_s_fc, 2, 0, false, "> opt");
  greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false, "> opt");
  greater_2_f = make_function_with_class(sc, f, ">", g_greater_2_f, 2, 0, false, "> opt");

  /* <= */
  f = set_function_chooser(sc, sc->leq_symbol, leq_chooser);
  leq_s_ic = make_function_with_class(sc, f, "<=", g_leq_s_ic, 2, 0, false, "<= opt");
  leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false, "<= opt");

  /* >= */
  f = set_function_chooser(sc, sc->geq_symbol, geq_chooser);
  geq_s_ic = make_function_with_class(sc, f, ">=", g_geq_s_ic, 2, 0, false, ">= opt");
  geq_s_fc = make_function_with_class(sc, f, ">=", g_geq_s_fc, 2, 0, false, ">= opt");
  geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false, ">= opt");
  geq_length_ic = make_function_with_class(sc, f, ">=", g_geq_length_ic, 2, 0, false, ">= opt");

  /* random */
  f = set_function_chooser(sc, sc->random_symbol, random_chooser);
  random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false, "random opt");
  random_ic = make_function_with_class(sc, f, "random", g_random_ic, 1, 0, false, "random opt");
  random_rc = make_function_with_class(sc, f, "random", g_random_rc, 1, 0, false, "random opt");
#endif

  /* list */
  f = set_function_chooser(sc, sc->list_symbol, list_chooser);
  list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false, "list opt");
  list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false, "list opt");
  list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false, "list opt");

  /* aritable? */
  f = set_function_chooser(sc, sc->is_aritable_symbol, is_aritable_chooser);
  is_aritable_ic = make_function_with_class(sc, f, "aritable?", g_is_aritable_ic, 2, 0, false, "aritable? opt");

  /* char=? */
  f = set_function_chooser(sc, sc->char_eq_symbol, char_equal_chooser);
  simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false, "char=? opt");
  char_equal_s_ic = make_function_with_class(sc, f, "char=?", g_char_equal_s_ic, 2, 0, false, "char=? opt");
  char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false, "char=? opt");

  /* char>? */
  f = set_function_chooser(sc, sc->char_gt_symbol, char_greater_chooser);
  char_greater_s_ic = make_function_with_class(sc, f, "char>?", g_char_greater_s_ic, 2, 0, false, "char>? opt");
  char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false, "char>? opt");

  /* char<? */
  f = set_function_chooser(sc, sc->char_lt_symbol, char_less_chooser);
  char_less_s_ic = make_function_with_class(sc, f, "char<?", g_char_less_s_ic, 2, 0, false, "char<? opt");
  char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false, "char<? opt");

  /* char-position */
  f = set_function_chooser(sc, sc->char_position_symbol, char_position_chooser);
  char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false, "char-position opt");

  /* string->symbol */
  set_function_chooser(sc, sc->string_to_symbol_symbol, string_to_symbol_chooser);

  /* string=? */
  f = set_function_chooser(sc, sc->string_eq_symbol, string_equal_chooser);
  string_equal_s_ic = make_function_with_class(sc, f, "string=?", g_string_equal_s_ic, 2, 0, false, "string=? opt");
  string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false, "string=? opt");

  /* substring */
  substring_to_temp = s7_make_function(sc, "substring", g_substring_to_temp, 2, 1, false, "substring opt");
  s7_function_set_class(substring_to_temp, slot_value(global_slot(sc->substring_symbol)));

  /* number->string */
  number_to_string_temp = s7_make_function(sc, "number->string", g_number_to_string_temp, 1, 1, false, "number->string opt");
  s7_function_set_class(number_to_string_temp, slot_value(global_slot(sc->number_to_string_symbol)));

  /* string>? */
  f = set_function_chooser(sc, sc->string_gt_symbol, string_greater_chooser);
  string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false, "string>? opt");

  /* string<? */
  f = set_function_chooser(sc, sc->string_lt_symbol, string_less_chooser);
  string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false, "string<? opt");

  /* string-ref */
  set_function_chooser(sc, sc->string_ref_symbol, string_ref_chooser);

  /* string-set! */
  set_function_chooser(sc, sc->string_set_symbol, string_set_chooser);

  /* string-append */
  f = set_function_chooser(sc, sc->string_append_symbol, string_append_chooser);
  string_append_to_temp = make_function_with_class(sc, f, "string-append", g_string_append_to_temp, 0, 0, true, "string-append opt");

  /* symbol->string */
  f = slot_value(global_slot(sc->symbol_to_string_symbol));
  symbol_to_string_uncopied = s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, "symbol->string opt");
  s7_function_set_class(symbol_to_string_uncopied, f);

  /* vector-ref */
  f = set_function_chooser(sc, sc->vector_ref_symbol, vector_ref_chooser);
  vector_ref_ic = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic, 2, 0, false, "vector-ref opt");
  vector_ref_ic_0 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_0, 1, 0, false, "vector-ref opt");
  vector_ref_ic_1 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_1, 1, 0, false, "vector-ref opt");
  vector_ref_ic_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_2, 1, 0, false, "vector-ref opt");
  vector_ref_ic_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_ic_3, 1, 0, false, "vector-ref opt");
  vector_ref_add1 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_add1, 2, 0, false, "vector-ref opt");
  vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false, "vector-ref opt");
  vector_ref_gs = make_function_with_class(sc, f, "vector-ref", g_vector_ref_gs, 2, 0, false, "vector-ref opt");
  constant_vector_ref_gs = make_function_with_class(sc, f, "vector-ref", g_constant_vector_ref_gs, 2, 0, false, "vector-ref opt");

  /* vector-set! */
  f = set_function_chooser(sc, sc->vector_set_symbol, vector_set_chooser);
  vector_set_ic = make_function_with_class(sc, f, "vector-set!", g_vector_set_ic, 3, 0, false, "vector-set! opt");
  vector_set_vref = make_function_with_class(sc, f, "vector-set!", g_vector_set_vref, 3, 0, false, "vector-set! opt");
  vector_set_vector_ref = make_function_with_class(sc, f, "vector-set!", g_vector_set_vector_ref, 3, 0, false, "vector-set! opt");
  vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false, "vector-set! opt");

  /* list-ref */
  f = set_function_chooser(sc, sc->list_ref_symbol, list_ref_chooser);
  list_ref_ic = make_function_with_class(sc, f, "list-ref", g_list_ref_ic, 2, 0, false, "list-ref opt");

  /* list-set! */
  f = set_function_chooser(sc, sc->list_set_symbol, list_set_chooser);
  list_set_ic = make_function_with_class(sc, f, "list-set!", g_list_set_ic, 3, 0, false, "list-set! opt");

  /* hash-table-ref */
  f = set_function_chooser(sc, sc->hash_table_ref_symbol, 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 opt");
  hash_table_ref_ss = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_ss, 2, 0, false, "hash-table-ref opt");
  hash_table_ref_car = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_car, 2, 0, false, "hash-table-ref opt");

  /* format */
  f = set_function_chooser(sc, sc->format_symbol, format_chooser);
  format_allg = make_function_with_class(sc, f, "format", g_format_allg, 1, 0, true, "format opt");
  format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true, "format opt");
  format_just_newline = make_function_with_class(sc, f, "format", g_format_just_newline, 2, 0, false, "format opt");

  /* not */
  f = set_function_chooser(sc, sc->not_symbol, not_chooser);
  not_is_pair = make_function_with_class(sc, f, "not", g_not_is_pair, 1, 0, false, "not opt");
  not_is_null = make_function_with_class(sc, f, "not", g_not_is_null, 1, 0, false, "not opt");
  not_is_list = make_function_with_class(sc, f, "not", g_not_is_list, 1, 0, false, "not opt");
  not_is_symbol = make_function_with_class(sc, f, "not", g_not_is_symbol, 1, 0, false, "not opt");
  not_is_number = make_function_with_class(sc, f, "not", g_not_is_number, 1, 0, false, "not opt");
  not_is_zero = make_function_with_class(sc, f, "not", g_not_is_zero, 1, 0, false, "not opt");
  not_is_string = make_function_with_class(sc, f, "not", g_not_is_string, 1, 0, false, "not opt");
  not_is_char = make_function_with_class(sc, f, "not", g_not_is_char, 1, 0, false, "not opt");
  not_is_eq_ss = make_function_with_class(sc, f, "not", g_not_is_eq_ss, 1, 0, false, "not opt");
  not_is_eq_sq = make_function_with_class(sc, f, "not", g_not_is_eq_sq, 1, 0, false, "not opt");
  not_is_pair_car = make_function_with_class(sc, f, "not", g_not_is_pair_car, 1, 0, false, "not opt");
  not_c_c = make_function_with_class(sc, f, "not", g_not_c_c, 1, 0, false, "not opt");

  /* pair? */
  f = set_function_chooser(sc, sc->is_pair_symbol, is_pair_chooser);
  is_pair_car = make_function_with_class(sc, f, "pair?", g_is_pair_car, 1, 0, false, "pair? opt");
  is_pair_cdr = make_function_with_class(sc, f, "pair?", g_is_pair_cdr, 1, 0, false, "pair? opt");
  is_pair_cadr = make_function_with_class(sc, f, "pair?", g_is_pair_cadr, 1, 0, false, "pair? opt");

  /* null? */
  f = set_function_chooser(sc, sc->is_null_symbol, is_null_chooser);
  is_null_cdr = make_function_with_class(sc, f, "null?", g_is_null_cdr, 1, 0, false, "null? opt");

  /* eq? */
  f = set_function_chooser(sc, sc->is_eq_symbol, is_eq_chooser);
  is_eq_car = make_function_with_class(sc, f, "eq?", g_is_eq_car, 2, 0, false, "eq? opt");
  is_eq_car_q = make_function_with_class(sc, f, "eq?", g_is_eq_car_q, 2, 0, false, "eq? opt");
  is_eq_caar_q = make_function_with_class(sc, f, "eq?", g_is_eq_caar_q, 2, 0, false, "eq? opt");

  /* member */
  f = set_function_chooser(sc, sc->member_symbol, member_chooser);
  member_ss = make_function_with_class(sc, f, "member", g_member_ss, 2, 0, false, "member opt");
  member_sq = make_function_with_class(sc, f, "member", g_member_sq, 2, 0, false, "member opt");
  member_num_s = make_function_with_class(sc, f, "member", g_member_num_s, 2, 0, false, "member opt");

  /* memq */
  f = set_function_chooser(sc, sc->memq_symbol, memq_chooser);
  /* is pure-s7, use member here */
  memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false, "memq opt");
  memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false, "memq opt");
  memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false, "memq opt");
  memq_car = make_function_with_class(sc, f, "memq", g_memq_car, 2, 0, false, "memq opt");

  /* read-char */
  f = set_function_chooser(sc, sc->read_char_symbol, read_char_chooser);
  read_char_0 = make_function_with_class(sc, f, "read-char", g_read_char_0, 0, 0, false, "read-char opt");
  read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false, "read-char opt");

  /* write-char */
  f = set_function_chooser(sc, sc->write_char_symbol, write_char_chooser);
  write_char_1 = make_function_with_class(sc, f, "write-char", g_write_char_1, 1, 0, false, "write-char opt");

  /* read-line */
  read_line_uncopied = s7_make_function(sc, "read-line", g_read_line_uncopied, 1, 1, false, "read-line opt");
  s7_function_set_class(read_line_uncopied, slot_value(global_slot(sc->read_line_symbol)));

  /* write-string */
  set_function_chooser(sc, sc->write_string_symbol, write_string_chooser);

  /* eval-string */
  set_function_chooser(sc, sc->eval_string_symbol, eval_string_chooser);

  /* or and if simple cases */
  or_direct = s7_make_function(sc, "or", g_or_direct, 0, 0, true, "or opt");
  and_direct = s7_make_function(sc, "and", g_and_direct, 0, 0, true, "and opt");
  if_direct = s7_make_function(sc, "if", g_if_direct, 2, 1, false, "if opt");

  or_all_x = s7_make_function(sc, "or", g_or_all_x, 0, 0, true, "or opt");
  or_all_x_2 = s7_make_function(sc, "or", g_or_all_x_2, 2, 0, false, "or opt");
  or_all_x_2s = s7_make_function(sc, "or", g_or_all_x_2s, 2, 0, false, "or opt");
  and_all_x = s7_make_function(sc, "and", g_and_all_x, 0, 0, true, "and opt");
  and_all_x_2 = s7_make_function(sc, "and", g_and_all_x_2, 2, 0, false, "and opt");
  if_all_x1 = s7_make_function(sc, "if", g_if_all_x1, 2, 0, false, "if opt");
  if_all_x2 = s7_make_function(sc, "if", g_if_all_x2, 3, 0, false, "if opt");
  if_all_not_x1 = s7_make_function(sc, "if", g_if_all_not_x1, 2, 0, false, "if opt");
  if_all_not_x2 = s7_make_function(sc, "if", g_if_all_not_x2, 3, 0, false, "if opt");
  if_all_x_qq = s7_make_function(sc, "if", g_if_all_x_qq, 3, 0, false, "if opt");
  if_all_x_qa = s7_make_function(sc, "if", g_if_all_x_qa, 3, 0, false, "if opt");

  or_s_direct = s7_make_function(sc, "or", g_or_s_direct, 0, 0, true, "or opt");
  and_s_direct = s7_make_function(sc, "and", g_and_s_direct, 0, 0, true, "and opt");
  if_s_direct = s7_make_function(sc, "if", g_if_s_direct, 2, 1, false, "if opt");
}


static s7_pointer collect_collisions(s7_scheme *sc, s7_pointer lst, s7_pointer e)
{
  /* collect local variable names from let/do (pre-error-check) */
  s7_pointer p;
  sc->w = e;
  for (p = lst; is_pair(p); p = cdr(p))
    if ((is_pair(car(p))) &&
	(is_symbol(caar(p))))
      sc->w = cons(sc, add_sym_to_list(sc, caar(p)), sc->w);
  return(sc->w);
}

static s7_pointer collect_collisions_star(s7_scheme *sc, s7_pointer lst, s7_pointer e)
{
  /* collect local variable names from lambda arglists (pre-error-check) */
  s7_pointer p;
  sc->w = e;
  for (p = lst; is_pair(p); p = cdr(p))
    {
      s7_pointer car_p;
      car_p = car(p);
      if (is_pair(car_p))
	car_p = car(car_p);
      if ((is_symbol(car_p)) &&
	  (!is_keyword(car_p)))
	sc->w = cons(sc, add_sym_to_list(sc, car_p), sc->w);
    }
  return(sc->w);
}


#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr))

static bool optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop)
{
  /* fprintf(stderr, "expr: %s, hop: %d\n", DISPLAY(expr), hop); */
  if (is_immutable_symbol(car(expr)))
    hop = 1;
  if (is_closure(func))
    {
      if (is_null(closure_args(func)))                 /* no rest arg funny business */
	{
	  if (is_safe_closure(func))
	    {
	      s7_pointer body;
	      body = closure_body(func);
	      set_unsafe_optimize_op(expr, hop + OP_SAFE_THUNK);
	      if (is_null(cdr(body)))
		{
		  if (is_optimized(car(body)))
		    set_unsafe_optimize_op(expr, hop + OP_SAFE_THUNK_E);
		  else
		    {
		      if ((is_pair(car(body))) &&
			  (is_syntactic(caar(body))))
			{
			  set_optimize_op(expr, hop + OP_SAFE_THUNK_P);
			  if (typesflag(car(body)) != SYNTACTIC_PAIR)
			    {
			      pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
			      set_syntactic_pair(car(body));
			    }
			}
		    }
		}
	    }
	  else set_unsafe_optimize_op(expr, hop + OP_THUNK);
	  set_opt_lambda(expr, func);
	}
      return(false);                                    /* false because currently the C_PP stuff assumes safe procedure calls */
    }

  if (is_c_function(func))
    {
      if (c_function_required_args(func) != 0)
	return(false);

      if ((is_safe_procedure(func)) ||
	  (c_function_call(func) == g_list) ||          /* (list) is safe */
	  (c_function_call(func) == g_values))          /* (values) is safe */
	{
	  set_safe_optimize_op(expr, hop + OP_SAFE_C_C);
	  choose_c_function(sc, expr, func, 0);
	  return(true);
	}
      return(false);
    }

  if (is_closure_star(func))
    {
      if ((is_proper_list(sc, closure_args(func))) &&
	  (has_simple_args(closure_body(func))))
	{
	  set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR : OP_CLOSURE_STAR));
	  set_opt_lambda(expr, func);
	}
    }
  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);

  /* e_c_pp case (1) is slightly different from the others: e2 is not a part of e1
   */
  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_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);
	case OP_SAFE_C_opSq:   return(OP_SAFE_C_op_opSq_q);
	case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSq_q);
	case OP_SAFE_C_A:      return(OP_SAFE_C_opAq);
	case OP_SAFE_C_AA:     return(OP_SAFE_C_opAAq);
	case OP_SAFE_C_AAA:    return(OP_SAFE_C_opAAAq);
	}
      return(OP_SAFE_C_Z); /* this splits out to A in optimize_func_one_arg */

    case E_C_SP:
      switch (op2)
	{
	case OP_SAFE_C_S:
	  set_opt_sym1(cdr(e1), cadr(e2));
	  return(OP_SAFE_C_S_opSq);

	case OP_SAFE_C_C:
	  set_opt_pair1(cdr(e1), cdr(e2));
	  return(OP_SAFE_C_S_opCq);

	case OP_SAFE_C_SC:
	  set_opt_sym1(cdr(e1), cadr(e2));
	  set_opt_con2(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_opt_con1(cdr(e1), cadr(e2));
	  set_opt_sym2(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_S_opCSq);

	case OP_SAFE_C_SS:
	  /* (* a (- b c)) */
	  set_opt_sym1(cdr(e1), cadr(e2));
	  set_opt_sym2(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_opSSq_opSSq:
	  return(OP_SAFE_C_S_op_opSSq_opSSqq);

	case OP_SAFE_C_SZ:
	  return(OP_SAFE_C_S_opSZq);

	case OP_SAFE_C_A:
	  return(OP_SAFE_C_S_opAq);

	case OP_SAFE_C_AA:
	  return(OP_SAFE_C_S_opAAq);

	case OP_SAFE_C_CSA:
	case OP_SAFE_C_CAS:
	case OP_SAFE_C_SCA:
	case OP_SAFE_C_SAS:
	case OP_SAFE_C_SSA:
	case OP_SAFE_C_AAA:
	  return(OP_SAFE_C_S_opAAAq);
	}
      /* fprintf(stderr, "%s: %s\n", opt_names[op2], DISPLAY(e1)); */
      return(OP_SAFE_C_SZ);

    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);
	case OP_SAFE_C_opSq:  return(OP_SAFE_C_op_opSq_q_S);
	case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSq_q_S);
	}
      return(OP_SAFE_C_ZS);

    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_opSq:  return(OP_SAFE_C_op_opSq_q_C);
	case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSq_q_C);
	}
      return(OP_SAFE_C_ZC);

    case E_C_CP:
      switch (op2)
	{
	case OP_SAFE_C_C:
	  set_opt_pair1(cdr(e1), cdr(e2));
	  return(OP_SAFE_C_C_opCq);

	case OP_SAFE_C_S:
	  set_opt_sym1(cdr(e1), cadr(e2));
	  return(OP_SAFE_C_C_opSq);

	case OP_SAFE_C_CS:
	  set_opt_con1(cdr(e1), cadr(e2));
	  set_opt_sym2(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opCSq);

	case OP_SAFE_C_SC:
	  set_opt_sym1(cdr(e1), cadr(e2));
	  set_opt_con2(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opSCq);

	case OP_SAFE_C_SS:
	  set_opt_sym1(cdr(e1), cadr(e2));
	  set_opt_sym2(cdr(e1), caddr(e2));
	  return(OP_SAFE_C_C_opSSq);

	case OP_SAFE_C_S_opCq:
	  return(OP_SAFE_C_C_op_S_opCqq);
	}
      return(OP_SAFE_C_CZ);

    case E_C_PP:
      switch (op2)
	{
	case OP_SAFE_C_S:
	  if (optimize_op_match(e1, OP_SAFE_C_S))
	    return(OP_SAFE_C_opSq_opSq);
	  if (optimize_op_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opSq);
	  break;

	case OP_SAFE_C_C:
	  if (optimize_op_match(e1, OP_SAFE_C_C))
	    return(OP_SAFE_C_opCq_opCq);
	  if (optimize_op_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opCq);
	  break;

	case OP_SAFE_C_SC:
	  if (optimize_op_match(e1, OP_SAFE_C_SC))
	    return(OP_SAFE_C_opSCq_opSCq);
	  break;

	case OP_SAFE_C_SS:
	  if (optimize_op_match(e1, OP_SAFE_C_C))
	    return(OP_SAFE_C_opCq_opSSq);
	  if (optimize_op_match(e1, OP_SAFE_C_SS))
	    return(OP_SAFE_C_opSSq_opSSq);
	  if (optimize_op_match(e1, OP_SAFE_C_S))
	    return(OP_SAFE_C_opSq_opSSq);
	  break;
	}
      return(OP_SAFE_C_ZZ);

    default:
      break;
    }
  return(OP_NO_OP);
}


static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
{
  s7_pointer p;
  for (p = args; is_pair(p); p = cdr(p))
    set_c_call(p, all_x_eval(sc, car(p), e, (s7_is_list(sc, e)) ? pair_symbol_is_safe : let_symbol_is_safe));
}

static void annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e)
{
  /* if sc->envir is sc->nil, we're at the top-level, but the global_slot check should suffice for that */
  set_c_call(arg, all_x_eval(sc, car(arg), e, (s7_is_list(sc, e)) ? pair_symbol_is_safe : let_symbol_is_safe));
}


static void opt_generator(s7_scheme *sc, s7_pointer func, s7_pointer expr, int hop)
{
  /* this is an optimization aimed at generators.  So we might as well go all out... */
  if (is_global(car(expr))) /* not a function argument for example */
    {
      s7_pointer body;
      body = closure_body(func);
      if ((s7_list_length(sc, body) == 2) &&
	  (caar(body) == sc->let_set_symbol) &&
	  (is_optimized(car(body))) &&
	  (optimize_op(car(body)) == HOP_SAFE_C_SQS) &&
	  (caadr(body) == sc->with_let_symbol) &&
	  (is_symbol(cadr(cadr(body)))))
	{
	  s7_pointer args;
	  args = closure_args(func);
	  if ((cadr(cadr(body)) == car(args)) &&
	      (is_pair(cdr(args))) &&
	      (is_pair(cadr(args))) &&
	      (cadddr(car(body)) == caadr(closure_args(func))))
	    {
	      if (is_global(car(expr))) hop = 1; /* it's my party... */
	      set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_S0);
	      set_opt_sym1(cdr(expr), cadr(caddar(body)));
	      set_opt_pair2(cdr(expr), cddadr(body));
	    }
	}
    }
}

static bool is_lambda(s7_scheme *sc, s7_pointer sym)
{
  return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0));
  /* symbol_id==0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */
}


static bool optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs, s7_pointer e)
{
  s7_pointer arg1;
  /* very often, expr is already optimized */

  arg1 = cadr(expr);
  if ((pairs == 0) &&
      (is_immutable_symbol(car(expr))))
    hop = 1;

  if (((is_c_function(func)) &&
       (c_function_required_args(func) <= 1) &&
       (c_function_all_args(func) >= 1)) ||
      ((is_c_function_star(func)) &&
       (c_function_all_args(func) == 1))) /* surely no need to check key here? */
    {
      bool func_is_safe;
      func_is_safe = is_safe_procedure(func);
      if (pairs == 0)
	{
	  if (func_is_safe)                  /* safe c function */
	    {
	      set_safe_optimize_op(expr, 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 arg1.
	       *    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, expr, func, 1);
	      return(true);
	    }
	  else                               /* c function is not safe */
	    {
	      set_unsafely_optimized(expr);
	      if (symbols == 0)
		{
		  set_optimize_op(expr, hop + OP_C_A);
		  annotate_arg(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(1));
		}
	      else
		{
		  if (c_function_call(func) == g_read)
		    set_optimize_op(expr, hop + OP_READ_S);
		  else set_optimize_op(expr, hop + OP_C_S);
		}
	      choose_c_function(sc, expr, func, 1);
	      return(false);
	    }
	}
      else /* pairs == 1 */
	{
	  if (bad_pairs == 0)
	    {
	      if (func_is_safe)
		{
		  int op;
		  op = combine_ops(sc, E_C_P, expr, arg1);
		  set_safe_optimize_op(expr, hop + op);
		  /* fallback is Z */
		  if (!hop)
		    {
		      clear_hop(arg1);
		    }
		  else
		    {
		      if ((op == OP_SAFE_C_Z) &&
			  (is_all_x_op(optimize_op(arg1))))
			{
			  /* this is confusing!  this is much faster than safe_c_z, but
			   *   the parallel let_z|a case seems to claim that z is faster.
			   */
			  set_optimize_op(expr, hop + OP_SAFE_C_A);
			  annotate_arg(sc, cdr(expr), e);
			}
		    }
		  choose_c_function(sc, expr, func, 1);
		  return(true);
		}
	      if (is_all_x_op(optimize_op(arg1)))
		{
		  set_unsafe_optimize_op(expr, hop + OP_C_A);
		  annotate_arg(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(1));
		  choose_c_function(sc, expr, func, 1);
		  return(false);
		}
	    }
	  else /* bad_pairs == 1 */
	    {
	      if (quotes == 1)
		{
		  if (func_is_safe)
		    {
		      set_safe_optimize_op(expr, hop + OP_SAFE_C_Q);
		      choose_c_function(sc, expr, func, 1);
		      return(true);
		    }
		  set_unsafe_optimize_op(expr, hop + OP_C_A);
		  annotate_arg(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(1));
		  choose_c_function(sc, expr, func, 1);
		  return(false);
		}
	      else  /* quotes == 0 */
		{
		  if (!func_is_safe)
		    {
		      s7_pointer lambda_expr;
		      lambda_expr = arg1;
		      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_unsafe_optimize_op(expr, hop + OP_CALL_WITH_EXIT);
			      choose_c_function(sc, expr, func, 1);
			      set_opt_pair2(expr, cdr(lambda_expr));
			      return(false);
			    }
			}
		    }
		  set_unsafe_optimize_op(expr, hop + ((is_h_optimized(arg1)) ? OP_C_Z : OP_C_P));
		  choose_c_function(sc, expr, func, 1);
		  return(false);
		}
	    }
	}

      if (!func_is_safe)
	{
	  set_unsafe_optimize_op(expr, hop + ((is_h_optimized(arg1)) ? OP_C_Z : OP_C_P));
	  choose_c_function(sc, expr, func, 1);
	  return(false);
	}
      return(is_optimized(expr));
    }

  if (is_closure(func))
    {
      bool safe_case, global_case;
      s7_pointer body;

      if (closure_arity_to_int(sc, func) != 1)
	return(false);
      /* this is checking for dotted arglists: boolean=? for example.  To optimize these calls, we need op_closure cases that
       *   bind the dotted name to the remaining args as a list.  This does not happen enough to be worth the trouble.
       */
      safe_case = is_safe_closure(func);
      global_case = is_global(car(expr));
      body = closure_body(func);

      if (pairs == 0)
	{
	  if (is_symbol(arg1))
	    {
	      if (safe_case)
		{
		  set_optimize_op(expr, hop + ((global_case) ? OP_SAFE_GLOSURE_S : OP_SAFE_CLOSURE_S));
		  if (is_null(cdr(body)))
		    {
		      if ((global_case) &&
			  (is_optimized(car(body))))
			set_optimize_op(expr, hop + OP_SAFE_GLOSURE_S_E);
		      else
			{
			  if ((is_pair(car(body))) &&
			      (is_syntactic(caar(body))))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_P);
			      if (typesflag(car(body)) != SYNTACTIC_PAIR)
				{
				  pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
				  set_syntactic_pair(car(body));
				}
			    }
			}
		    }
		}
	      else set_optimize_op(expr, hop + ((global_case) ? OP_GLOSURE_S : OP_CLOSURE_S));
	      set_opt_sym2(expr, arg1);
	    }
	  else 
	    {
	      set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_C : OP_CLOSURE_C));
	      set_opt_con2(expr, arg1);
	    }
	  set_opt_lambda(expr, func);
	  set_unsafely_optimized(expr);
	  return(false);
	}
      else /* pairs == 1 */
	{
	  if (bad_pairs == 0)
	    {
	      if ((is_optimized(arg1)) &&
		  (is_all_x_op(optimize_op(arg1))))
		{
		  set_unsafely_optimized(expr);
		  annotate_arg(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(1));
		  if (safe_case)
		    set_optimize_op(expr, hop + ((global_case) ? OP_SAFE_GLOSURE_A : OP_SAFE_CLOSURE_A));
		  else set_optimize_op(expr, hop + ((global_case) ? OP_GLOSURE_A : OP_CLOSURE_A));
		  set_opt_lambda(expr, func);
		  return(false);
		}
	    }
	  else /* bad_pairs == 1 */
	    {
	      if (quotes == 1)
		{
		  set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_Q : OP_CLOSURE_Q));
		  set_opt_lambda(expr, func);
		  return(false);
		}
	    }
	  if ((quotes == 0) &&
	      (global_case))
	    {
	      set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_GLOSURE_P : OP_GLOSURE_P));
	      set_opt_lambda(expr, func);
	      return(false);
	    }
	}

      if (pairs == (quotes + all_x_count(expr)))
	{
	  set_unsafe_optimize_op(expr, hop + ((safe_case ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)));
	  annotate_arg(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(1));
	  return(false);
	}
      return(is_optimized(expr));
    }

  if (is_closure_star(func))
    {
      bool safe_case;
      if ((!has_simple_args(closure_body(func))) ||
	  (is_null(closure_args(func))))
	return(false);
      safe_case = is_safe_closure(func);

      if ((pairs == 0) &&
	  (symbols == 1))
	{
	  set_unsafely_optimized(expr);
	  if (safe_case)
	    {
	      set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_S);
	      if (closure_star_arity_to_int(sc, func) == 2)
		{
		  s7_pointer defarg2;
		  defarg2 = cadr(closure_args(func));
		  if ((is_pair(defarg2)) &&
		      (s7_is_zero(cadr(defarg2))))
		    opt_generator(sc, func, expr, hop);
		}
	    }
	  else set_optimize_op(expr, hop + OP_CLOSURE_STAR_S);
	  set_opt_lambda(expr, func);
	  set_opt_sym2(expr, arg1);
	  return(false);
	}

      if ((!arglist_has_rest(sc, closure_args(func))) &&
	  (pairs == (quotes + all_x_count(expr))))
	{
	  set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	  annotate_arg(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(1));
	  return(false);
	}
      return(is_optimized(expr));
    }

  if ((pairs == 0) &&
      (s7_is_vector(func)))
    {
      set_safe_optimize_op(expr, hop + ((symbols == 1) ? OP_VECTOR_S : OP_VECTOR_C));
      set_opt_vector(expr, func);
      return(true);
    }
  /* unknown_* is set later */
  return(is_optimized(expr));
}


static bool rdirect_memq(s7_scheme *sc, 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) /* car(nil)=unspec, cdr(unspec)=unspec! This only works for lists known to be undotted and non-circular */
	return(true);
    }
  return(false);
}

static s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
{
  s7_pointer x;
  long long int id;

  if ((symbol_tag(symbol) == sc->syms_tag) &&
      (rdirect_memq(sc, symbol, e)))   /* it's probably a local variable reference */
    return(sc->nil);

  if (is_global(symbol))
    return(global_slot(symbol));

  id = symbol_id(symbol);
  for (x = sc->envir; id < let_id(x); x = outlet(x));
  for (; is_let(x); x = outlet(x))
    {
      s7_pointer y;
      if (let_id(x) == id)
	return(local_slot(symbol));

      for (y = let_slots(x); is_slot(y); y = next_slot(y))
	if (slot_symbol(y) == symbol)
	  return(y);
    }

  return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */
}


static bool unsafe_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer arg1, s7_pointer arg2, s7_pointer arg3, s7_pointer e)
{
  s7_pointer f = NULL;                     /* arg3 if member|assoc */
  if (!arg3) return(true);
  f = arg3;
  if (!is_symbol(f)) return(false);
  f = find_uncomplicated_symbol(sc, f, e); /* form_is_safe -- how to catch local c-funcs here? */
  if (is_slot(f))
    {
      f = slot_value(f);
      return((is_c_function(f)) &&
	     (is_safe_procedure(f)));
    }
  return(false);
}

static bool optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs, s7_pointer e)
{
  s7_pointer arg1, arg2;

  arg1 = cadr(expr);
  arg2 = caddr(expr);
  if ((pairs == 0) &&
      (is_immutable_symbol(car(expr))))
    hop = 1;

  if ((is_c_function(func) &&
       (c_function_required_args(func) <= 2) &&
       (c_function_all_args(func) >= 2)) ||
      ((is_c_function_star(func)) &&
       (c_function_all_args(func) == 2) &&
       (!is_keyword(arg1))))
    {
      /* this is a mess */
      bool func_is_safe;
      func_is_safe = is_safe_procedure(func);
      if (pairs == 0)
	{
	  if ((func_is_safe) ||
	      ((is_possibly_safe(func)) && 
	       (unsafe_is_safe(sc, func, arg1, arg2, NULL, e))))
	    {
	      /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */
	      if (symbols == 0)
		set_optimize_op(expr, hop + OP_SAFE_C_C);
	      else
		{
		  if (symbols == 2)
		    set_optimize_op(expr, hop + OP_SAFE_C_SS); /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */
		  else set_optimize_op(expr, hop + ((is_symbol(arg1)) ? OP_SAFE_C_SC : OP_SAFE_C_CS));
		}
	      set_optimized(expr);
	      choose_c_function(sc, expr, func, 2);
	      return(true);
	    }
	  set_unsafely_optimized(expr);
	  if (symbols == 2)
	    {
	      if (c_function_call(func) == g_apply)
		{
		  set_optimize_op(expr, hop + OP_APPLY_SS);
		  set_opt_cfunc(expr, func);
		  set_opt_sym2(expr, arg2);
		}
	      else
		{
		  set_optimize_op(expr, hop + OP_C_SS);
		  choose_c_function(sc, expr, func, 2);
		}
	    }
	  else
	    {
	      set_optimize_op(expr, hop + OP_C_ALL_X);
	      annotate_args(sc, cdr(expr), e);
	      set_arglist_length(expr, small_int(2));
	      choose_c_function(sc, expr, func, 2);
	      if (is_safe_procedure(opt_cfunc(expr)))
		{
		  clear_unsafe(expr);
		  set_optimized(expr);
		  /* symbols can be 0..2 here, no pairs */
		  if (symbols == 1)
		    {
		      if (is_symbol(arg1))
			set_optimize_op(expr, hop + OP_SAFE_C_SC);
		      else set_optimize_op(expr, hop + OP_SAFE_C_CS);
		    }
		  else
		    {
		      if (symbols == 2)
			set_optimize_op(expr, hop + OP_SAFE_C_SS);
		      else set_optimize_op(expr, hop + OP_SAFE_C_C);
		    }
		  return(true);
		}
	    }
	  return(false);
	}

      /* pairs != 0 */
      if ((bad_pairs == 0) &&
	  (pairs == 2))
	{
	  if ((func_is_safe) ||
	      ((is_possibly_safe(func)) && 
	       (unsafe_is_safe(sc, func, arg1, arg2, NULL, e))))
	    {
	      int op;
	      op = combine_ops(sc, E_C_PP, arg1, arg2);
	      set_safe_optimize_op(expr, hop + op);
	      /* fallback here is ZZ */
	      if (!hop)
		{
		  clear_hop(arg1);
		  clear_hop(arg2);
		}
	      else
		{
		  if (op == OP_SAFE_C_ZZ)
		    {
		      if (is_all_x_safe(sc, arg1))
			{
			  if (is_all_x_safe(sc, arg2))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_AA);
			      annotate_args(sc, cdr(expr), e);
			      set_arglist_length(expr, small_int(2));
			    }
			  else
			    {
			      if (optimize_op(arg1) == HOP_SAFE_C_C)
				set_optimize_op(expr, hop + OP_SAFE_C_opCq_Z);
			      else
				{
				  set_optimize_op(expr, hop + OP_SAFE_C_AZ);
				  annotate_arg(sc, cdr(expr), e);
				  set_arglist_length(expr, small_int(2));
				}
			    }
			}
		      else
			{
			  if (is_all_x_safe(sc, arg2))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_ZA);
			      annotate_arg(sc, cddr(expr), e);
			      set_arglist_length(expr, small_int(2));
			    }
			}
		    }
		}
	      choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */
	      return(true);
	    }
	}

      if ((bad_pairs == 0) &&
	  (pairs == 1))
	{
	  if ((func_is_safe) ||
	      ((is_possibly_safe(func)) && 
	       (unsafe_is_safe(sc, func, arg1, arg2, NULL, e))))
	    {
	      combine_op_t orig_op;
	      int op;

	      if (is_pair(arg1))
		{
		  if (is_symbol(arg2))
		    orig_op = E_C_PS;
		  else orig_op = E_C_PC;
		  op = combine_ops(sc, orig_op, expr, arg1);
		  if (!hop) clear_hop(arg1);
		}
	      else
		{
		  if (is_symbol(arg1))
		    orig_op = E_C_SP;
		  else orig_op = E_C_CP;
		  op = combine_ops(sc, orig_op, expr, arg2);
		  if (!hop) clear_hop(arg2);
		}

	      set_safe_optimize_op(expr, hop + op);
	      choose_c_function(sc, expr, func, 2);
	      return(true);
	    }
	  if (symbols == 1)
	    {
	      if (is_symbol(arg1))
		{
		  if (is_safe_c_s(arg2))
		    {
		      set_unsafe_optimize_op(expr, hop + OP_C_S_opSq);
		      set_opt_sym1(cdr(expr), cadr(arg2));
		      choose_c_function(sc, expr, func, 2);
		      return(false);
		    }
		  if (optimize_op_match(arg2, OP_SAFE_C_C))
		    {
		      set_unsafe_optimize_op(expr, hop + OP_C_S_opCq);
		      set_opt_pair1(cdr(expr), cdr(arg2));
		      choose_c_function(sc, expr, func, 2);
		      return(false);
		    }
		}
	    }
	}

      if ((bad_pairs == 1) && (quotes == 1))
	{
	  if ((func_is_safe) ||
	      ((is_possibly_safe(func)) && 
	       (unsafe_is_safe(sc, func, arg1, arg2, NULL, e))))
	    {
	      if  (symbols == 1)
		{
		  set_optimized(expr);
		  if (is_symbol(arg1))
		    set_optimize_op(expr, hop + OP_SAFE_C_SQ);
		  else set_optimize_op(expr, hop + OP_SAFE_C_QS);
		  choose_c_function(sc, expr, func, 2);
		  return(true);
		}
	      else
		{
		  if (pairs == 1)
		    {
		      /* Q must be 1, symbols = 0, pairs = 1 (the quote), so this must be CQ or QC?
		       */
		      set_optimized(expr);
		      if (is_pair(arg1))
			set_optimize_op(expr, hop + OP_SAFE_C_QC);
		      else set_optimize_op(expr, hop + OP_SAFE_C_CQ);
		      choose_c_function(sc, expr, func, 2);
		      return(true);
		    }
		}
	    }
	  else
	    {
	      if (pairs == 1)
		{
		  set_unsafe_optimize_op(expr, hop + OP_C_ALL_X);
		  annotate_args(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(2));
		  choose_c_function(sc, expr, func, 2);
		  return(false);
		}
	    }
	}

      if (quotes == 2)
	{
	  if ((func_is_safe) ||
	      ((is_possibly_safe(func)) && 
	       (unsafe_is_safe(sc, func, arg1, arg2, NULL, e))))
	    {
	      set_safe_optimize_op(expr, hop + OP_SAFE_C_QQ);
	      choose_c_function(sc, expr, func, 2);
	      return(true);
	    }
	  set_unsafe_optimize_op(expr, hop + OP_C_ALL_X);
	  annotate_args(sc, cdr(expr), e);
	  set_arglist_length(expr, small_int(2));
	  choose_c_function(sc, expr, func, 2);
	  return(false);
	}

      if ((pairs == 1) &&
	  (quotes == 0) &&
	  ((func_is_safe) ||
	   ((is_possibly_safe(func)) && 
	    (unsafe_is_safe(sc, func, arg1, arg2, NULL, e)))))
	{
	  if (symbols == 1)
	    {
	      set_optimized(expr);
	      if (is_symbol(arg1))
		{
		  if ((bad_pairs == 0) || (is_h_optimized(arg2))) /* bad_pair && h_optimized happens a lot */
		    {
		      set_optimize_op(expr, hop + OP_SAFE_C_SZ);
		      choose_c_function(sc, expr, func, 2);
		      /* if hop is on, is it the case that opt1 is unused?  where besides c_function_is_ok is it referenced?
		       *    some like add_ss_1ss use opt1(cdr(...)) which is safe here I think because cadr is a symbol
		       *    it's used in the choosers to detect e.g. temp funcs
		       */
		      return(true);
		    }
		  set_unsafe(expr);
		  set_optimize_op(expr, hop + OP_SAFE_C_SP);
		  choose_c_function(sc, expr, func, 2);
		  return(false);
		}

	      /* arg2 is a symbol */
	      if ((bad_pairs == 0) || (is_h_optimized(arg1)))
		{
		  set_optimize_op(expr, hop + OP_SAFE_C_ZS);
		  choose_c_function(sc, expr, func, 2);
		  return(true);
		}
	      /* unknowns get here: (* amp (amps 0))
	       * also list: (make-polywave pitch (list 1 0.93 2 0.07))
	       * and (* vol (granulate gen))
	       */
	      set_unsafe(expr);
	      set_optimize_op(expr, hop + OP_SAFE_C_PS);
	      choose_c_function(sc, expr, func, 2);
	      return(false);
	    }
	  if (symbols == 0)
	    {
	      set_optimized(expr);
	      if (is_pair(arg1))
		{
		  if ((bad_pairs == 0) || (is_h_optimized(arg2)))
		    {
		      set_optimize_op(expr, hop + OP_SAFE_C_ZC);
		      choose_c_function(sc, expr, func, 2);
		      return(true);
		    }
		  else
		    {
		      set_unsafe(expr);
		      set_optimize_op(expr, hop + OP_SAFE_C_PC);
		      choose_c_function(sc, expr, func, 2);
		      return(false);
		    }
		}
	      else
		{
		  if ((bad_pairs == 0) || (is_h_optimized(arg1)))
		    {
		      set_optimize_op(expr, hop + OP_SAFE_C_CZ);
		      choose_c_function(sc, expr, func, 2);
		      return(true);
		    }
		  else
		    {
		      set_unsafe(expr);
		      set_optimize_op(expr, hop + OP_SAFE_C_CP);
		      choose_c_function(sc, expr, func, 2);
		      return(false);
		    }
		}
	    }
	}

      if ((pairs == 2) &&
	  ((func_is_safe) ||
	   ((is_possibly_safe(func)) && 
	    (unsafe_is_safe(sc, func, arg1, arg2, NULL, e)))))
	{
	  if ((bad_pairs == 1) &&
	      (is_safe_c_s(arg1)))
	    {
	      /* unsafe func here won't work unless we check that later and make the new arg list (for {list} etc)
	       *   (and it has to be the last pair else the unknown_g stuff can mess up)
	       */
	      if (car(arg2) == sc->quote_symbol)
		{
		  set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_Q);
		  choose_c_function(sc, expr, func, 2);
		  return(true);
		}
	      set_unsafe_optimize_op(expr, hop + OP_SAFE_C_opSq_P);
	      choose_c_function(sc, expr, func, 2);
	      return(false);
	    }
	  else
	    {
	      if (quotes == 0)
		{
		  set_unsafely_optimized(expr);
		  if (is_all_x_safe(sc, arg1))
		    {
		      set_optimize_op(expr, hop + ((is_h_optimized(arg2)) ? OP_SAFE_C_AZ : OP_SAFE_C_AP));
		      annotate_arg(sc, cdr(expr), e);
		    }
		  else set_optimize_op(expr, hop + OP_SAFE_C_PP);
		  choose_c_function(sc, expr, func, 2);
		  return(false);
		}
	      else
		{
		  if (quotes == 1)
		    {
		      if (car(arg1) == sc->quote_symbol)
			set_optimize_op(expr, hop + OP_SAFE_C_QP);
		      else set_optimize_op(expr, hop + OP_SAFE_C_PQ);
		      set_unsafely_optimized(expr);
		      choose_c_function(sc, expr, func, 2);
		      return(false);
		    }
		}
	    }
	}

      if (func_is_safe)
	{
	  if (pairs == (quotes + all_x_count(expr)))
	    {
	      set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
	      annotate_args(sc, cdr(expr), e);
	      set_arglist_length(expr, small_int(2));
	      choose_c_function(sc, expr, func, 2);
	      return(true);
	    }
	}

      if ((pairs == 1) &&
	  (symbols == 1) &&
	  (quotes == 0) &&
	  (!func_is_safe) &&
	  (is_symbol(arg1)))
	{
	  set_unsafe_optimize_op(expr, hop + ((is_h_optimized(arg2)) ? OP_C_SZ : OP_C_SP));
	  choose_c_function(sc, expr, func, 2);
	  return(false);
	}
      return(is_optimized(expr));
    }

  if (is_closure(func))
    {
      if (closure_arity_to_int(sc, func) != 2)
	return(false);

      if ((pairs == 0) &&
	  (symbols >= 1))
	{
	  set_unsafely_optimized(expr);
	  if (symbols == 2)
	    {
	      set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS));
	      set_opt_sym2(expr, arg2);
	    }
	  else
	    {
	      if (is_symbol(arg1))
		{
		  set_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)));
		  set_opt_con2(expr, arg2);
		}
	      else 
		{
		  set_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_CS : OP_CLOSURE_CS)));
		  set_opt_sym2(expr, arg2);
		}
	    }
	  set_opt_lambda(expr, func);
	  return(false);
	}

      if ((!arglist_has_rest(sc, closure_args(func))) &&
	  (pairs == (quotes + all_x_count(expr))))
	{
	  set_unsafely_optimized(expr);
	  if (is_safe_closure(func))
	    {
	      if (is_symbol(arg1))
		set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SA);
	      else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA);
	    }
	  else set_optimize_op(expr, hop + OP_CLOSURE_AA);
	  annotate_args(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(2));
	  return(false);
	}
      return(is_optimized(expr));
    }

  if (is_closure_star(func))
    {
      if (((!has_simple_args(closure_body(func))) ||
	   (closure_star_arity_to_int(sc, func) < 2) ||
	   (arglist_has_keyword(cdr(expr)))))
	return(false);

      if ((pairs == 0) &&
	  (symbols >= 1) &&
	  (is_symbol(arg1)))
	{
	  set_unsafely_optimized(expr);
	  if (symbols == 2)
	    {
	      set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_SS : OP_CLOSURE_STAR_SX));
	      set_opt_sym2(expr, arg2);
	    }
	  else
	    {
	      if (is_safe_closure(func))
		{
		  set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_SC);
		  set_opt_con2(expr, arg2);
		  if (arg2 == real_zero)
		    opt_generator(sc, func, expr, hop);
		}
	      else set_optimize_op(expr, hop + OP_CLOSURE_STAR_SX);
	    }
	  set_opt_lambda(expr, func);
	  return(false);
	}

      if ((!arglist_has_rest(sc, closure_args(func))) &&
	  (pairs == (quotes + all_x_count(expr))))
	{
	  set_unsafely_optimized(expr);
	  if (is_safe_closure(func))
	    {
	      if ((is_symbol(arg1)) &&
		  (closure_star_arity_to_int(sc, func) == 2))
		set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_SA);
	      else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_ALL_X);
	    }
	  else set_optimize_op(expr, hop + OP_CLOSURE_STAR_ALL_X);
	  annotate_args(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(2));
	  return(false);
	}
    }
  return(is_optimized(expr));
}


static bool optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, int pairs, int symbols, int quotes, int bad_pairs, s7_pointer e)
{
  s7_pointer arg1, arg2, arg3;

  arg1 = cadr(expr);
  arg2 = caddr(expr);
  arg3 = cadddr(expr);
  if ((pairs == 0) &&
      (is_immutable_symbol(car(expr))))
    hop = 1;

  if ((is_c_function(func) &&
       (c_function_required_args(func) <= 3) &&
       (c_function_all_args(func) >= 3)) ||
      ((is_c_function_star(func)) &&
       (c_function_all_args(func) == 3) &&
       (!is_keyword(arg1)) &&
       (!is_keyword(arg2))))
    {
      if ((is_safe_procedure(func)) ||
	  ((is_possibly_safe(func)) && 
	   (unsafe_is_safe(sc, func, arg1, arg2, arg3, e))))
	{
	  if (pairs == 0)
	    {
	      set_optimized(expr);
	      if (symbols == 0)
		set_optimize_op(expr, hop + OP_SAFE_C_C);
	      else
		{
		  if (symbols == 3)
		    {
		      set_optimize_op(expr, hop + OP_SAFE_C_SSS);
		      set_opt_sym1(cdr(expr), arg2);
		      set_opt_sym2(cdr(expr), arg3);
		    }
		  else
		    {
		      if (symbols == 2)
			{
			  if (!is_symbol(arg1))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_CSS);
			      set_opt_sym1(cdr(expr), arg2);
			      set_opt_sym2(cdr(expr), arg3);
			    }
			  else
			    {
			      if (!is_symbol(arg3))
				{
				  set_opt_con2(cdr(expr), arg3);
				  if (is_keyword(arg2))
				    {
				      set_opt_con1(cdr(expr), arg2);
				      set_optimize_op(expr, hop + OP_SAFE_C_SCC);
				    }
				  else 
				    {
				      set_opt_sym1(cdr(expr), arg2);
				      set_optimize_op(expr, hop + OP_SAFE_C_SSC);
				    }
				}
			      else 
				{
				  set_opt_con1(cdr(expr), arg2);
				  set_opt_sym2(cdr(expr), arg3);
				  set_optimize_op(expr, hop + OP_SAFE_C_SCS);
				}
			    }
			}
		      else
			{
			  if (is_symbol(arg1))
			    {
			      set_opt_con1(cdr(expr), arg2);
			      set_opt_con2(cdr(expr), arg3);
			      set_optimize_op(expr, hop + OP_SAFE_C_SCC);
			    }
			  else
			    {
			      if (is_symbol(arg2))
				{
				  set_opt_sym1(cdr(expr), arg2);
				  set_opt_con2(cdr(expr), arg3);
				  set_optimize_op(expr, hop + OP_SAFE_C_CSC);
				}
			      else
				{
				  set_optimize_op(expr, hop + OP_SAFE_C_AAA); /* fallback on all_x_c and s here -- a kludge */
				  annotate_args(sc, cdr(expr), e);
				  set_arglist_length(expr, small_int(3));
				}
			    }
			}
		    }
		}
	      choose_c_function(sc, expr, func, 3);
	      return(true);
	    }

	  /* pairs != 0 */
	  if (pairs == quotes + all_x_count(expr))
	    {
	      set_optimized(expr);
	      if (quotes == 1)
		{
		  if ((symbols == 2) &&
		      (is_symbol(arg1)) &&
		      (is_symbol(arg3)))
		    {
		      set_opt_con1(cdr(expr), cadr(arg2));
		      set_opt_sym2(cdr(expr), arg3);
		      set_optimize_op(expr, hop + OP_SAFE_C_SQS);
		      choose_c_function(sc, expr, func, 3);
		      return(true);
		    }
		  if ((symbols == 1) &&
		      (is_symbol(arg3)) &&
		      (is_pair(arg2)) &&
		      (car(arg2) == sc->quote_symbol) &&
		      (is_safe_c_s(arg1)))
		    {
		      set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_Q_S);
		      choose_c_function(sc, expr, func, 3);
		      return(true);
		    }
		}
	      annotate_args(sc, cdr(expr), e);
	      set_arglist_length(expr, small_int(3));
	      set_optimize_op(expr, hop + OP_SAFE_C_AAA);

	      if (pairs == 1)
		{
		  if (symbols == 1)
		    {
		      if (is_pair(arg3))
			{
			  if (is_symbol(arg2))
			    set_optimize_op(expr, hop + OP_SAFE_C_CSA);
			  else set_optimize_op(expr, hop + OP_SAFE_C_SCA);
			}
		      else
			{
			  if ((is_pair(arg2)) &&
			      (is_symbol(arg3)))
			    set_optimize_op(expr, hop + OP_SAFE_C_CAS);
			}
		    }
		  else
		    {
		      if ((symbols == 2) && (is_symbol(arg1)))
			set_optimize_op(expr, hop + ((is_symbol(arg2)) ? OP_SAFE_C_SSA : OP_SAFE_C_SAS));
		    }
		}
	      choose_c_function(sc, expr, func, 3);
	      return(true);
	    }

	  if (bad_pairs == 0)
	    {
	      if ((symbols == 2) &&
		  (is_symbol(arg1)) &&
		  (is_symbol(arg2)))
		{
		  set_optimize_op(expr, hop + OP_SAFE_C_SSZ);
		}
	      else
		{
		  /* use either X or Z in all 8 choices */
		  if ((!is_pair(arg1)) ||
		      (is_all_x_op(optimize_op(arg1))))
		    {
		      annotate_arg(sc, cdr(expr), e);
		      if ((!is_pair(arg2)) ||
			  (is_all_x_op(optimize_op(arg2))))
			{
			  set_optimize_op(expr, hop + OP_SAFE_C_AAZ); /* here last can't be A because we checked for that above */
			  annotate_arg(sc, cddr(expr), e);
			}
		      else
			{
			  if ((!is_pair(arg3)) ||
			      (is_all_x_op(optimize_op(arg3))))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_AZA);
			      annotate_arg(sc, cdddr(expr), e);
			    }
			  else set_optimize_op(expr, hop + OP_SAFE_C_AZZ);
			}
		    }
		  else
		    {
		      if ((!is_pair(arg2)) ||
			  (is_all_x_op(optimize_op(arg2))))
			{
			  annotate_arg(sc, cddr(expr), e);
			  if ((!is_pair(arg3)) ||
			      (is_all_x_op(optimize_op(arg3))))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_ZAA);
			      annotate_arg(sc, cdddr(expr), e);
			    }
			  else set_optimize_op(expr, hop + OP_SAFE_C_ZAZ);
			}
		      else
			{
			  if ((!is_pair(arg3)) ||
			      (is_all_x_op(optimize_op(arg3))))
			    {
			      set_optimize_op(expr, hop + OP_SAFE_C_ZZA);
			      annotate_arg(sc, cdddr(expr), e);
			    }
			  else set_optimize_op(expr, hop + OP_SAFE_C_ZZZ);
			}
		    }
		}
	      set_optimized(expr);
	      choose_c_function(sc, expr, func, 3);
	      set_arglist_length(expr, small_int(3));
	      return(true);
	    }

	  /* aap is not better than ssp, sap also saves very little */
	  if ((pairs == 1) &&
	      (bad_pairs == 1) &&
	      (symbols == 2) &&
	      (is_pair(arg3)))
	    {
	      set_unsafe_optimize_op(expr, hop + ((is_h_optimized(arg3)) ? OP_SAFE_C_SSZ : OP_SAFE_C_SSP));
	      choose_c_function(sc, expr, func, 3);
	      return(false);
	    }
	}
      else /* func is not safe */
	{
	  if (pairs == quotes + all_x_count(expr))
	    {
	      set_optimized(expr);
	      if ((symbols == 2) &&
		  (pairs == 0) &&
		  (is_symbol(arg1)) &&
		  (is_symbol(arg3)))
		set_optimize_op(expr, hop + OP_C_SCS);
	      else
		{
		  annotate_args(sc, cdr(expr), e);
		  set_arglist_length(expr, small_int(3));
		  set_optimize_op(expr, hop + OP_C_ALL_X);
		}
	      choose_c_function(sc, expr, func, 3);
	      if (optimize_op(expr) != HOP_SAFE_C_C) /* did chooser fix it up? */
		{
		  set_unsafe(expr);
		  return(false);
		}
	      return(true);
	    }

	  /* (define (hi) (catch #t (lambda () 1) (lambda args 2)))
	   *   first arg list must be (), second a symbol
	   */
	  if (c_function_call(func) == g_catch)
	    {
	      if (((bad_pairs == 2) && (!is_pair(arg1))) ||
		  ((bad_pairs == 3) && (car(arg1) == sc->quote_symbol)))
		{
		  s7_pointer body_lambda, error_lambda;
		  body_lambda = arg2;
		  error_lambda = arg3;

		  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_symbol(cadr(error_lambda))) &&
		      (is_not_null(cddr(error_lambda))))
		    {
		      s7_pointer error_result;
		      error_result = caddr(error_lambda);
		      set_unsafely_optimized(expr);
		      if ((arg1 == sc->T) &&
			  (is_null(cdddr(error_lambda))) &&
			  (!is_symbol(error_result)) &&
			  ((!is_pair(error_result)) || (car(error_result) == sc->quote_symbol)))
			{
			  set_optimize_op(expr, hop + OP_C_CATCH_ALL);
			  set_c_function(expr, func);
			  if (is_pair(error_result))
			    set_opt_con2(expr, cadr(error_result));
			  else set_opt_con2(expr, error_result);
			  set_opt_pair1(cdr(expr), cddr(body_lambda));
			}
		      else
			{
			  set_optimize_op(expr, hop + OP_C_CATCH);
			  choose_c_function(sc, expr, func, 3);
			}
		      return(false);
		    }
		}
	    }
	}
      return(is_optimized(expr));
    }

  /* not c func */
  if (is_closure(func))
    {
      if (closure_arity_to_int(sc, func) != 3)
	return(false);

      if ((symbols == 3) &&
	  (!is_safe_closure(func)))
	{
	  set_unsafely_optimized(expr);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(3));
	  set_optimize_op(expr, hop + OP_CLOSURE_ALL_S);
	  return(false);
	}

      if (pairs == quotes + all_x_count(expr))
	{
	  if (is_safe_closure(func))
	    {
	      if (is_symbol(arg1))
		set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SAA);
	      else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_ALL_X);
	    }
	  else set_optimize_op(expr, hop + OP_CLOSURE_ALL_X);
	  set_unsafely_optimized(expr);
	  annotate_args(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(3));
	  return(false);
	}
    }

  if (is_closure_star(func))
    {
      if ((!has_simple_args(closure_body(func))) ||
	  (closure_star_arity_to_int(sc, func) < 3) ||
	  (arglist_has_keyword(cdr(expr))) ||
	  (arglist_has_rest(sc, closure_args(func)))) /* is this redundant? */
	return(false);

      if (pairs == quotes + all_x_count(expr))
	{
	  set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X)));
	  annotate_args(sc, cdr(expr), e);
	  set_opt_lambda(expr, func);
	  set_arglist_length(expr, small_int(3));
	  return(false);
	}
    }

  if (bad_pairs > quotes) return(false);
  return(is_optimized(expr));
}


static bool optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, int args, int pairs, int symbols, int quotes, int bad_pairs, s7_pointer e)
{
  bool func_is_closure;

  if (bad_pairs > quotes) return(false);
  if ((pairs == 0) &&
      (is_immutable_symbol(car(expr))))
    hop = 1;

  if ((is_c_function(func)) &&
      (c_function_required_args(func) <= (unsigned int)args) &&
      (c_function_all_args(func) >= (unsigned int)args))
    {
      if (is_safe_procedure(func))
	{
	  if (pairs == 0)
	    {
	      if (symbols == 0)
		{
		  set_safe_optimize_op(expr, hop + OP_SAFE_C_C);
		  choose_c_function(sc, expr, func, args);
		  return(true);
		}
	      if ((symbols == args) &&
		  (args < GC_TRIGGER_SIZE))
		{
		  set_safe_optimize_op(expr, hop + OP_SAFE_C_ALL_S);
		  set_arglist_length(expr, make_permanent_integer(args));
		  choose_c_function(sc, expr, func, args);
		  return(true);
		}
	    }

	  if ((args < GC_TRIGGER_SIZE) &&
	      (pairs == (quotes + all_x_count(expr))))
	    {
	      set_optimized(expr);
	      if (args == 4)
		set_optimize_op(expr, hop + OP_SAFE_C_AAAA);
	      else set_optimize_op(expr, hop + OP_SAFE_C_ALL_X);
	      annotate_args(sc, cdr(expr), e);
	      set_arglist_length(expr, make_permanent_integer(args));
	      choose_c_function(sc, expr, func, args);
	      return(true);
	    }
	}
      else /* c_func is not safe */
	{
	  if ((args < GC_TRIGGER_SIZE) &&
	      (pairs == (quotes + all_x_count(expr))))
	    {
	      set_unsafe_optimize_op(expr, hop + OP_C_ALL_X);
	      annotate_args(sc, cdr(expr), e);
	      set_arglist_length(expr, make_permanent_integer(args));
	      choose_c_function(sc, expr, func, args);
	      return(false);
	    }
	}
      return(is_optimized(expr));
    }

  func_is_closure = is_closure(func);
  if (func_is_closure)
    {
      if (closure_arity_to_int(sc, func) != args)
	return(false);

      if ((pairs == 0) &&
	  ((symbols == args) || (symbols == 0)) &&
	  (args < GC_TRIGGER_SIZE))
	{
	  bool safe_case;
	  safe_case = is_safe_closure(func);
	  set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_X));
	  annotate_args(sc, cdr(expr), e);
	  set_arglist_length(expr, make_permanent_integer(args));
	  set_opt_lambda(expr, func);

	  if ((!safe_case) &&
	      (symbols == args))
	    set_optimize_op(expr, hop + OP_CLOSURE_ALL_S);
	  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(expr)))))
    return(false);

  if (args < GC_TRIGGER_SIZE)
    {
      if (((func_is_closure) ||
	   (is_closure_star(func))) &&
	  (!arglist_has_rest(sc, closure_args(func))) &&
	  (pairs == (quotes + all_x_count(expr))))
	{
	  set_unsafely_optimized(expr);
	  if (func_is_closure)
	    set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_X));
	  else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	  annotate_args(sc, cdr(expr), e);
	  set_arglist_length(expr, make_permanent_integer(args));
	  set_opt_lambda(expr, func);
	  return(false);
	}
    }
  return(is_optimized(expr));
}


static bool optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int hop, s7_pointer e)
{
  opcode_t op;
  s7_pointer p, orig_e, body;

  if (!is_pair(cdr(expr))) /* cddr(expr) might be null if, for example, (begin (let ...)) */
    return(false);

  op = (opcode_t)syntax_opcode(func);
  sc->w = e;
  orig_e = e;
  body = cdr(expr);

  switch (op)
    {
    case OP_QUOTE:
    case OP_MACROEXPAND:
      return(false);

    case OP_LET:
    case OP_LET_STAR:
      if (is_symbol(cadr(expr)))
	{
	  e = collect_collisions(sc, caddr(expr), cons(sc, add_sym_to_list(sc, cadr(expr)), e));
	  body = cdddr(expr);
	}
      else 
	{
	  e = collect_collisions(sc, cadr(expr), e);
	  body = cddr(expr);
	}
      break;

    case OP_LETREC:
    case OP_LETREC_STAR:
      e = collect_collisions(sc, cadr(expr), e);
      body = cddr(expr);
      break;

    case OP_DEFINE_MACRO:
    case OP_DEFINE_MACRO_STAR:
    case OP_DEFINE_BACRO:
    case OP_DEFINE_BACRO_STAR:
    case OP_DEFINE_CONSTANT:
    case OP_DEFINE_EXPANSION:
    case OP_DEFINE:
    case OP_DEFINE_STAR:
      if (is_pair(cadr(expr)))
	{
	  s7_pointer name_args;
	  name_args = cadr(expr);
	  if (is_symbol(car(name_args)))
	    e = cons(sc, add_sym_to_list(sc, car(name_args)), e);
	  if (is_symbol(cdr(name_args)))
	    e = cons(sc, add_sym_to_list(sc, cdr(name_args)), e);
	  else e = collect_collisions_star(sc, cdr(name_args), e);
	  /* fprintf(stderr, "%s -> e: %s\n", DISPLAY(expr), DISPLAY(e)); */
	}
      body = cddr(expr);
      break;

    case OP_LAMBDA:
    case OP_LAMBDA_STAR:
      if (is_symbol(cadr(expr))) /* (lambda args ...) */
	e = cons(sc, add_sym_to_list(sc, cadr(expr)), e);
      else e = collect_collisions_star(sc, cadr(expr), e);
      body = cddr(expr);
      break;

    case OP_SET:
      if (is_symbol(cadr(expr)))
	e = cons(sc, add_sym_to_list(sc, cadr(expr)), e);
      body = sc->nil;
      break;

    case OP_DO:
      e = collect_collisions(sc, cadr(expr), e);
      body = cddr(expr);
      break;

    case OP_WITH_LET:
      if (sc->safety != 0)
	hop = 0;
      orig_e = sc->nil;
      e = sc->nil;
      /* we can't trust anything here, so hop ought to be off.  For example,
       *    (define (hi)
       *      (let ((e (sublet (curlet)
       *                 (cons 'abs (lambda (a) (- a 1))))))
       *        (with-let e (abs -1))))
       * returns 1 if hop is 1, but -2 outside the function body.
       */
      break;

    default:
      break;
    }
  if (is_pair(e)) sc->w = e;
  /* fprintf(stderr, "%s -> e: %s\n", DISPLAY(expr), DISPLAY(e)); */

  for (p = cdr(expr); is_pair(p); p = cdr(p))
    {
      if (p == body) orig_e = e;
      if ((is_pair(car(p))) && (!is_checked(car(p)))) /* ((typeflag & (0xff | T_CHECKED)) == T_PAIR) is not faster */
	optimize_expression(sc, car(p), hop, orig_e);
    }

  if ((hop == 1) &&
      (symbol_id(car(expr)) == 0))
    {
      if ((op == OP_IF) || (op == OP_OR) || (op == OP_AND))
	{
	  bool happy = true;
	  for (p = cdr(expr); (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 sym = NULL;
	      bool c_s_is_ok = true;

	      for (args = 0, p = cdr(expr); 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_safe_optimize_op(expr, hop + OP_SAFE_C_C);
	      if (pairs == 0)
		{
		  if (op == OP_OR)
		    set_c_function(expr, or_direct);
		  else
		    {
		      if (op == OP_AND)
			set_c_function(expr, and_direct);
		      else set_c_function(expr, if_direct);
		    }
		  return(true);
		}

	      if ((pairs == args) &&
		  (c_s_is_ok))
		{
		  if (op == OP_OR)
		    set_c_function(expr, or_s_direct);
		  else
		    {
		      if (op == OP_AND)
			set_c_function(expr, and_s_direct);
		      else set_c_function(expr, if_s_direct);
		    }
		  return(true);
		}

	      for (p = cdr(expr); is_pair(p); p = cdr(p))
		set_c_call(p, all_x_eval(sc, car(p), e, pair_symbol_is_safe));

	      if (op == OP_OR)
		{
		  if (s7_list_length(sc, cdr(expr)) == 2)
		    {
		      set_c_function(expr, or_all_x_2);
		      if ((c_call(cdr(expr)) == all_x_c_u) &&
			  (c_call(cddr(expr)) == all_x_c_u))
			set_c_function(expr, or_all_x_2s);
		    }
		  else set_c_function(expr, or_all_x);
		}
	      else
		{
		  if (op == OP_AND)
		    {
		      if (s7_list_length(sc, cdr(expr)) == 2)
			set_c_function(expr, and_all_x_2);
		      else set_c_function(expr, and_all_x);
		    }
		  else
		    {
		      s7_pointer test, b1, b2;
		      test = cdr(expr);
		      b1 = cdr(test);
		      b2 = cdr(b1);
		      if ((c_call(b1) == all_x_q) &&
			  (is_pair(b2)))
			{
			  if (c_call(b2) == all_x_q)
			    set_c_function(expr, if_all_x_qq);
			  else set_c_function(expr, if_all_x_qa);
			}
		      else
			{
			  if ((is_pair(car(test))) &&
			      (caar(test) == sc->not_symbol))
			    {
			      set_c_call(test, all_x_eval(sc, cadar(test), e, pair_symbol_is_safe));
			      if (is_null(b2))
				set_c_function(expr, if_all_not_x1);
			      else set_c_function(expr, if_all_not_x2);
			    }
			  else
			    {
			      if (is_null(b2))
				set_c_function(expr, if_all_x1);
			      else set_c_function(expr, if_all_x2);
			    }
			}
		    }
		}
	      return(true);
	    }
	  /* else we could check other if cases here (test is often all_x_safe)
	   */
	}
    }
  return(false);
}


static bool optimize_expression(s7_scheme *sc, s7_pointer expr, int hop, s7_pointer e)
{
  s7_pointer car_expr;
  /* fprintf(stderr, "opt %d %s %s\n", hop, DISPLAY(expr), DISPLAY(e)); */
  /* if (is_checked(expr)) return(true); */

  set_checked(expr);
  car_expr = car(expr);

  if (is_symbol(car_expr))
    {
      s7_pointer func;
      if (is_syntactic(car_expr)) 
	return(optimize_syntax(sc, expr, _TSyn(slot_value(global_slot(car_expr))), hop, e));

      if (car_expr == sc->quote_symbol)
	return(false);

      func = find_uncomplicated_symbol(sc, car_expr, e);
      if (is_slot(func))
	{
	  func = slot_value(func);
	  if (is_syntax(func))   /* 12-8-16 was is_syntactic, but that is only appropriate above -- here we have the value */
	    return(optimize_syntax(sc, expr, 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 */
	    {
	      int pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0, orig_hop;
	      s7_pointer p;

	      orig_hop = hop;
	      if ((is_any_closure(func)) ||      /* can't depend on opt1 here because it might not be global, or might be redefined locally */
		  ((!is_global(car_expr)) &&
		   ((!is_slot(global_slot(car_expr))) ||
		    (slot_value(global_slot(car_expr)) != 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
		   */

		  hop = 0;
		  /* this is very tricky!  See s7test for some cases.  Basically, we need to protect a recursive call
		   *   of the current function being optimized from being confused with some previous definition
		   *   of the same name.  But method lists have global names so the global bit is off even though the
		   *   thing is actually a safe global.  But no closure can be considered safe in the hop sense --
		   *   even a global function might be redefined at any time, and previous uses of it in other functions
		   *   need to reflect its new value.
		   *   So, closures are always checked, but built-in functions are used as if never redefined until that redefinition.
		   *   costs: index 6/1380, t502: 2/12900, bench: 43/4134, snd-test: 22/37200
		   * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't
		   *   offend me much.  Consider each a sort of reader macro until someone redefines it -- previous
		   *   uses may not be affected because they might have been optimized away -- the result depends on the
		   *   current optimizer.
		   * Another case (from K Matheussen):
		   *   (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2)
		   *   when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is
		   *   not good enough -- if we load mockery.scm, nothing is global!
		   */
		}
	      /* 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 bit should be on
	       *   for that one case.
	       */

	      for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */
		{
		  s7_pointer car_p;
		  car_p = car(p);
		  if (is_symbol(car_p))
		    symbols++;
		  else
		    {
		      if (is_pair(car_p))
			{
			  pairs++;
			  if (!is_checked(car_p))
			    {
			      if (!optimize_expression(sc, car_p, orig_hop, e))
				{
				  bad_pairs++;
				  if ((car(car_p) == sc->quote_symbol) &&
				      (is_pair(cdr(car_p))) &&
				      (is_null(cddr(car_p))))
				    quotes++;
				}
			    }
			  else
			    {
			      if ((!is_optimized(car_p)) ||
				  (is_unsafe(car_p)))
				{
				  bad_pairs++;
				  if ((car(car_p) == sc->quote_symbol) &&
				      (is_pair(cdr(car_p))) &&
				      (is_null(cddr(car_p))))
				    quotes++;
				}
			    }
			}
		    }
		}
	      if (is_null(p))                    /* if not null, dotted list of args? */
		{
		  switch (args)
		    {
		    case 0:  return(optimize_thunk(sc, expr, func, hop));
		    case 1:  return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e));
		    case 2:  return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e));
		    case 3:  return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e));
		    default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e));
		    }
		}
	      return(false);
	    }
	}
      else
	{
	  if ((sc->undefined_identifier_warnings) &&
	      (func == sc->undefined) &&         /* car_expr is not in e or global */
	      (symbol_tag(car_expr) == 0))         /*    and we haven't looked it up earlier */
	    {
	      s7_pointer p;
	      p = sc->input_port;
	      if ((is_input_port(p)) &&
		  (port_file(p) != stdin) &&
		  (!port_is_closed(p)) &&
		  (port_filename(p)))
		s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", DISPLAY(car_expr), port_filename(p), port_line_number(p));
	      else s7_warn(sc, 1024, "; %s might be undefined\n", DISPLAY(car_expr));
	      symbol_set_tag(car_expr, 1);             /* one warning is enough */
	    }
	  /* we need local definitions and func args in e?  also check is_symbol case below
	   */
	}

      /* car_expr 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 = cdr(expr); is_pair(p); p = cdr(p), len++)
	  {
	    s7_pointer car_p;
	    car_p = car(p);
	    if (is_pair(car_p))
	      {
		pairs++;
		if ((hop != 0) && (car(car_p) == sc->quote_symbol))
		  quotes++;
		if (!is_checked(car_p))
		  optimize_expression(sc, car_p, hop, e);
	      }
	    else
	      {
		if (is_symbol(car_p))
		  symbols++;
	      }
	  }

	if ((is_null(p)) &&              /* (+ 1 . 2) */
	    (!is_optimized(expr)))
	  {
	    /* len=0 case is almost entirely arglists */
	    set_opt_con1(expr, sc->gc_nil);
	    if (pairs == 0)
	      {
		if (len == 0)
		  {
		    /* hoping to catch object application here, as in readers in Snd */
		    set_unsafe_optimize_op(expr, OP_UNKNOWN);
		    return(false);
		  }

		if (len == 1)
		  {
		    if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */
		      {
			set_unsafe_optimize_op(expr, OP_UNKNOWN_G);
			/* 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(expr);
		    if (symbols == 2)
		      set_optimize_op(expr, OP_UNKNOWN_GG);
		    else
		      {
			if (symbols == 0)
			  set_optimize_op(expr, OP_UNKNOWN_GG);
			else
			  {
			    if (is_symbol(cadr(expr)))
			      set_optimize_op(expr, OP_UNKNOWN_GG);
			    else set_optimize_op(expr, OP_UNKNOWN_GG);
			  }
		      }
		    return(false);
		  }

		if ((len >= 3) &&
		    (len == symbols))
		  {
		    set_unsafe_optimize_op(expr, OP_UNKNOWN_ALL_S);
		    set_arglist_length(expr, make_permanent_integer(len));
		    return(false);
		  }
	      }
	    else /* pairs != 0 */
	      {
		s7_pointer arg1;
		arg1 = cadr(expr);
		if (pairs == 1)
		  {
		    if (len == 1)
		      {
			if (quotes == 1)
			  {
			    set_unsafe_optimize_op(expr, OP_UNKNOWN_A);
			    return(false);
			  }

			if (is_all_x_safe(sc, arg1))
			  {
			    set_arglist_length(expr, small_int(1));
			    set_unsafe_optimize_op(expr, OP_UNKNOWN_A);
			    return(false);
			  }
		      }
		    else
		      {
			if (len == 2)
			  {
			    if ((is_all_x_safe(sc, arg1)) &&
				(is_all_x_safe(sc, caddr(expr))))
			      {
				set_arglist_length(expr, small_int(2));
				set_unsafe_optimize_op(expr, OP_UNKNOWN_AA);
				return(false);
			      }
			  }
		      }
		  }

		if ((len == 2) &&
		    (is_all_x_safe(sc, arg1)) &&
		    (is_all_x_safe(sc, caddr(expr))))
		  {
		    set_arglist_length(expr, small_int(2));
		    set_unsafe_optimize_op(expr, OP_UNKNOWN_AA);
		    return(false);
		  }

		if ((pairs == (quotes + all_x_count(expr))) &&
		    (len < GC_TRIGGER_SIZE))
		  {
		    set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : OP_UNKNOWN_ALL_X);
		    set_arglist_length(expr, make_permanent_integer(len));
		    return(false);
		  }
	      }
	  }
      }
    }
  else
    {
      /* car(expr) is not a symbol, but there might be interesting stuff here */
      /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */
      s7_pointer p;
      for (p = expr; is_pair(p); p = cdr(p))
	{
	  if ((is_pair(car(p))) && (!is_checked(car(p))))
	    optimize_expression(sc, car(p), hop, e);
	}
    }
  return(false);
}


static s7_pointer optimize(s7_scheme *sc, s7_pointer code, int hop, s7_pointer e)
{
  s7_pointer x;
  if (sc->safety > 1) return(NULL);
  /* fprintf(stderr, "optimize %s %d %s\n", DISPLAY_80(code), hop, DISPLAY(e)); */
  for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x))
    {
      set_checked(x);
      if ((is_pair(car(x))) && (!is_checked(car(x))))
	optimize_expression(sc, car(x), hop, e);
    }
  if ((!is_null(x)) &&
      (!is_pair(x)))
    eval_error(sc, "stray dot in function body: ~S", code);
  return(NULL);
}


#if WITH_GCC
  #define indirect_c_function_is_ok(Sc, X) ({s7_pointer _X_; _X_ = X; (((optimize_op(_X_) & 0x1) != 0) || (c_function_is_ok(Sc, _X_)));})
  #define indirect_cq_function_is_ok(Sc, X) ({s7_pointer _X_; _X_ = X; ((!is_optimized(_X_)) || ((optimize_op(_X_) & 0x1) != 0) || (c_function_is_ok(Sc, _X_)));})
#else
  #define indirect_c_function_is_ok(Sc, X) (((optimize_op(X) & 0x1) != 0) || (c_function_is_ok(Sc, X)))
  #define indirect_cq_function_is_ok(Sc, X) ((!is_optimized(X)) || ((optimize_op(X) & 0x1) != 0) || (c_function_is_ok(Sc, X)))
#endif

static bool body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end);

static bool form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_end)
{
  /* called only from body_is_safe and itself */
  s7_pointer expr;

  sc->cycle_counter++;
  if ((!is_proper_list(sc, x)) ||
      (sc->cycle_counter > 5000))
    return(false);

  expr = car(x);
  if (is_syntactic_symbol(expr))
    {
      switch (symbol_syntax_op(expr))
	{
	case OP_OR:
	case OP_AND:
	case OP_BEGIN:
	case OP_WITH_BAFFLE:
	  if (!body_is_safe(sc, func, cdr(x), at_end))
	    return(false);
	  break;

	case OP_MACROEXPAND:
	  return(false);

	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)))
	    return(false);

	case OP_LETREC:
	case OP_LETREC_STAR:
	  if (is_pair(cadr(x)))
	    {
	      s7_pointer vars;
	      for (vars = cadr(x); is_pair(vars); vars = cdr(vars))
		{
		  s7_pointer let_var;

		  let_var = car(vars);
		  if ((!is_pair(let_var)) ||
		      (!is_pair(cdr(let_var))))
		    return(false);

		  if (car(let_var) == func)
		    return(false); /* it's shadowed */

		  if ((is_pair(cadr(let_var))) &&
		      (!form_is_safe(sc, func, cadr(let_var), false)))
		    return(false);
		}
	    }
	  if (!body_is_safe(sc, func, cddr(x), at_end))
	    return(false);
	  break;

	case OP_IF:
	  if (!is_pair(cdr(x))) return(false); /* (if) ! */
	  if (!((!is_pair(cadr(x))) || (form_is_safe(sc, func, cadr(x), false)))) return(false);
	  if (!((!is_pair(caddr(x))) || (form_is_safe(sc, func, caddr(x), at_end)))) return(false);
	  if (!((!is_pair(cdddr(x))) || (!is_pair(cadddr(x))) || (form_is_safe(sc, func, cadddr(x), at_end)))) return(false);
	  break;

	case OP_WHEN:
	case OP_UNLESS:
	  if (!is_pair(cdr(x))) return(false); /* (when) */
	  if (!((!is_pair(cadr(x))) || (form_is_safe(sc, func, cadr(x), false)))) return(false);
	  if (!body_is_safe(sc, func, cddr(x), at_end)) return(false);
	  break;

	case OP_COND:
	  {
	    s7_pointer p;
	    for (p = cdr(x); is_pair(p); p = cdr(p))
	      {
		s7_pointer ex;
		ex = car(p);
		if (is_pair(ex)) /* ?? */
		  {
		    if ((is_pair(car(ex))) && (!form_is_safe(sc, func, car(ex), false)))
		      return(false);
		    if ((is_pair(cdr(ex))) && (!body_is_safe(sc, func, cdr(ex), at_end)))
		      return(false);
		  }
	      }
	    if (is_not_null(p))
	      return(false);
	  }
	  break;

	case OP_CASE:
	  {
	    s7_pointer p;
	    if ((is_pair(cadr(x))) && (!form_is_safe(sc, func, cadr(x), false))) return(false);
	    for (p = cddr(x); is_pair(p); p = cdr(p))
	      if ((is_pair(car(p))) && (!body_is_safe(sc, func, cdar(p), at_end)))
		return(false);
	  }
	  break;

	case OP_DO:
	  /* (do (...) (...) ...) */
	  if (!is_pair(cddr(x)))
	    return(false);
	  if (!body_is_safe(sc, func, cdddr(x), false))
	    return(false);
	  if (is_pair(cadr(x)))
	    {
	      s7_pointer vars;
	      for (vars = cadr(x); is_pair(vars); vars = cdr(vars))
		{
		  s7_pointer do_var;
		  do_var = car(vars);
		  if (!is_pair(do_var))
		    return(false);

		  if ((car(do_var) == func) ||
		      (!is_pair(cdr(do_var))))   /* (do ((a . 1) (b . 2)) ...) */
		    return(false);

		  if ((is_pair(cadr(do_var))) &&
		      (!form_is_safe(sc, func, cadr(do_var), false)))
		    return(false);

		  if ((is_pair(cddr(do_var))) &&
		      (is_pair(caddr(do_var))) &&
		      (!form_is_safe(sc, func, caddr(do_var), false)))
		    return(false);
		}
	    }
	  if ((is_pair(caddr(x))) &&
	      (!body_is_safe(sc, func, caddr(x), at_end)))
	    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)
	    return(false);

	  /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */
	  if (is_symbol(caddr(x)))
	    return(false);          /* ?? because it might be a local function that has captured local state? */

	  if (((!is_pair(caddr(x))) || (form_is_safe(sc, func, caddr(x), false))) &&
	      ((is_symbol(cadr(x))) ||
	       ((is_pair(cadr(x))) && (form_is_safe(sc, func, cadr(x), false)))))
	    return(true);
	  return(false);

	case OP_WITH_LET:
	  if (is_pair(cadr(x)))
	    return(false);

	  if (!body_is_safe(sc, sc->F, cddr(x), at_end))
	    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))
	   */
	  return(false);
	}
    }
  else /* car(x) is not syntactic ?? */
    {
      if ((!is_optimized(x)) ||
	  (is_unsafe(x)))
	{
	  if (expr == func) /* try to catch tail call */
	    {
	      s7_pointer p;

	      for (p = cdr(x); is_pair(p); p = cdr(p))
		if ((is_pair(car(p))) &&
		    (((!is_optimized(car(p))) && (caar(p) != sc->quote_symbol)) ||
		     (is_unsafe(car(p))) ||
		     (caar(p) == func)))    /* func called as arg, so not tail call */
		  return(false);

	      if ((at_end) && (is_null(p))) /* tail call, so safe */
		return(true);
	      return(false);
	    }

	  if (is_symbol(expr))
	    {
	      if (is_global(expr))
		{
		  s7_pointer f;
		  f = find_symbol_checked(sc, expr);
		  if (((is_c_function(f)) &&
		       ((is_safe_procedure(f)) ||
			((is_possibly_safe(f)) && 
			 (is_pair(cdr(x))) &&
			 (is_pair(cddr(x))) &&
			 (unsafe_is_safe(sc, f, cadr(x), caddr(x), (is_pair(cdddr(x))) ? cadddr(x) : NULL, sc->nil))))) ||
		      ((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)))))
			  {
			    if ((caar(p) != func) ||
				(!is_null(cdr(p))))
			      return(false);
			  }
		      if (!is_null(p))
			return(false);
		    }
		}
	      else
		{
		  s7_pointer f;
		  f = find_symbol(sc, expr);
		  if (is_slot(f))
		    {
		      if ((is_syntax(slot_value(f))) || (is_any_macro(slot_value(f))))
			return(false);
		      if ((is_closure(slot_value(f))) &&
			  (is_safe_closure(slot_value(f))))
			{
			  s7_pointer p;
			  /* the calling function is safe, but what about its arguments? */
			  for (p = cdr(x); is_pair(p); p = cdr(p))
			    if ((is_pair(car(p))) &&
				(caar(p) == func)) /* this would be a recursive call on func that is not in tail-call position */
			      return(false);
			  return(true);
			}
		    }
		}
	    }
	  return(false);
	}
    }
  return(true);
}


static bool body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end)
{
  /* called in optimize_lambda and above */
  s7_pointer p;
  for (p = body; is_pair(p); p = cdr(p))
    if ((is_pair(car(p))) &&
	(!form_is_safe(sc, func, car(p), (at_end) && (is_null(cdr(p))))))
      return(false);
  return(is_null(p));
}



/* ---------------------------------------- error checks ---------------------------------------- */

#define goto_START 0
#define goto_BEGIN1 1
#define fall_through 2
#define goto_DO_END_CLAUSES 3
#define goto_SAFE_DO_END_CLAUSES 4
#define goto_OPT_EVAL 5
#define goto_START_WITHOUT_POP_STACK 6
#define goto_EVAL 7
#define goto_APPLY 8
#define goto_EVAL_ARGS 9
#define goto_DO_UNCHECKED 10

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 ...) */
	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))
    {
      s7_pointer car_x;
      car_x = car(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) */
	    eval_error(sc, "lambda parameter '~S is a pair (perhaps you want define* or lambda*?)", car_x);
	  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) ...) */
	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) */
	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 ...) */
	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))
    {
      s7_pointer car_w;
      car_w = car(w);
      if (is_pair(car_w))
	{
	  if (s7_is_constant(car(car_w)))                            /* (lambda* ((:a 1)) ...) */
	    eval_error(sc, "lambda* parameter '~A is a constant", car(car_w));
	  if (symbol_is_in_arg_list(caar(w), cdr(w)))             /* (lambda* ((a 1) a) ...) */
	    eval_error(sc, "lambda* parameter '~A is used twice in the argument list", car(car_w));

	  if (!is_pair(cdr(car_w)))                                  /* (lambda* ((a . 0.0)) a) */
	    {
	      if (is_null(cdr(car_w)))                               /* (lambda* ((a)) ...) */
		eval_error(sc, "lambda* parameter default value missing? '~A", car_w);
	      eval_error(sc, "lambda* parameter is a dotted pair? '~A", car_w);
	    }
	  else
	    {
	      if ((is_pair(cadr(car_w))) &&                          /* (lambda* ((a (quote . -1))) ...) */
		  (s7_list_length(sc, cadr(car_w)) < 0))
		eval_error(sc, "lambda* parameter default value is improper? ~A", car_w);
	    }

	  if (is_not_null(cddr(car_w)))                              /* (lambda* ((a 0.0 'hi)) a) */
	    eval_error(sc, "lambda* parameter has multiple default values? '~A", car_w);

	  set_local(car(car_w));
	}
      else
	{
	  if (car_w != sc->key_rest_symbol)
	    {
	      if (s7_is_constant(car_w))
		{
		  if (car_w == sc->key_allow_other_keys_symbol)
		    {
		      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);
		      if (w == top)
			eval_error(sc, ":allow-other-keys can't be the only parameter: ~A", args);
		      set_allow_other_keys(top);
		      set_cdr(v, sc->nil);
		    }
		  else                                        /* (lambda* (pi) ...) */
		    eval_error(sc, "lambda* parameter '~A is a constant", car_w);
		}
	      if (symbol_is_in_arg_list(car_w, cdr(w)))       /* (lambda* (a a) ...) or (lambda* (a . a) ...) */
		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) ...) */
		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) ...) */
		    eval_error(sc, "lambda* :rest parameter is not a symbol? ~A", w);
		  eval_error(sc, "lambda* :rest parameter can't have a default value. ~A", w);
		}
	      else
		{
		  if (is_immutable_symbol(cadr(w)))
		    return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(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) */
	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 void check_lambda(s7_scheme *sc)
{
  /* 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;
  if (!is_pair(code))                                 /* (lambda) or (lambda . 1) */
    eval_error_no_return(sc, sc->syntax_error_symbol, "lambda: no args? ~A", current_code(sc));

  body = cdr(code);
  if (!is_pair(body))                                 /* (lambda #f) */
    eval_error_no_return(sc, sc->syntax_error_symbol, "lambda: no body? ~A", code);
  
  /* in many cases, this is a no-op -- we already checked at define */
  check_lambda_args(sc, car(code), NULL);
  clear_syms_in_list(sc);
  
  /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...)
   *   one problem the hop=0 fixes is that safe closures assume the old frame exists, so we need to check for define below
   *   I wonder about apply define...
   */
  if ((sc->safety == 0) &&
      ((main_stack_op(sc) == OP_DEFINE1) ||
       (((sc->stack_end - sc->stack_start) > 4) &&
	(((opcode_t)(sc->stack_end[-5])) == OP_DEFINE1) &&  /* surely if define is ok, so is define dilambda? 16-Apr-16 */
	(sc->op_stack_now > sc->op_stack) &&
	((*(sc->op_stack_now - 1)) == (s7_pointer)slot_value(global_slot(sc->dilambda_symbol)))))) 
    optimize_lambda(sc, true, sc->gc_nil, car(code), body); /* why was lambda the func? */
  else optimize(sc, body, 0, sc->nil);
  
  if ((is_overlaid(code)) &&
      (has_opt_back(code)))
    pair_set_syntax_symbol(code, sc->lambda_unchecked_symbol);
}

static void check_lambda_star(s7_scheme *sc)
{
  if ((!is_pair(sc->code)) ||
      (!is_pair(cdr(sc->code))))                                          /* (lambda*) or (lambda* #f) */
    eval_error_no_return(sc, sc->syntax_error_symbol, "lambda*: no args or no body? ~A", sc->code);
  
  set_car(sc->code, check_lambda_star_args(sc, car(sc->code), NULL));
  clear_syms_in_list(sc);
  
  if ((sc->safety != 0) ||
      (main_stack_op(sc) != OP_DEFINE1))
    optimize(sc, cdr(sc->code), 0, sc->nil);
  else optimize_lambda(sc, false, sc->gc_nil, car(sc->code), cdr(sc->code));
  
  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    pair_set_syntax_symbol(sc->code, sc->lambda_star_unchecked_symbol);
}

static s7_pointer check_when(s7_scheme *sc)
{
  if (!is_pair(sc->code))                                            /* (when) or (when . 1) */
    eval_error(sc, "when has no expression or body:  ~A", sc->code);
  if (!is_pair(cdr(sc->code)))                                       /* (when 1) or (when 1 . 1) */
    eval_error(sc, "when has no body?:  ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      pair_set_syntax_symbol(sc->code, sc->when_unchecked_symbol);
      if (is_symbol(car(sc->code)))
	pair_set_syntax_symbol(sc->code, sc->when_s_symbol);
    }
  return(sc->code);
}


static s7_pointer check_unless(s7_scheme *sc)
{
  if (!is_pair(sc->code))                                            /* (unless) or (unless . 1) */
    eval_error(sc, "unless has no expression or body:  ~A", sc->code);
  if (!is_pair(cdr(sc->code)))                                       /* (unless 1) or (unless 1 . 1) */
    eval_error(sc, "unless has no body?:  ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      pair_set_syntax_symbol(sc->code, sc->unless_unchecked_symbol);
      if (is_symbol(car(sc->code)))
	pair_set_syntax_symbol(sc->code, sc->unless_s_symbol);
    }
  return(sc->code);
}


static s7_pointer check_case(s7_scheme *sc)
{
  bool keys_simple = true, have_else = false, has_feed_to = false, keys_single = true, bodies_simple = true, bodies_simplest = true;
  s7_pointer x;

  if (!is_pair(sc->code))                                            /* (case) or (case . 1) */
    eval_error(sc, "case has no selector:  ~A", sc->code);
  if (!is_pair(cdr(sc->code)))                                       /* (case 1) or (case 1 . 1) */
    eval_error(sc, "case has no clauses?:  ~A", sc->code);
  if (!is_pair(cadr(sc->code)))                                      /* (case 1 1) */
    eval_error(sc, "case clause is not a list? ~A", sc->code);

  for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
    {
      s7_pointer y;
      if ((!is_pair(x)) ||                                        /* (case 1 ((2) 1) . 1) */
	  (!is_pair(car(x))))
	eval_error(sc, "case clause ~A messed up", x);
      if (!is_pair(cdar(x)))                                      /* (case 1 ((1))) */
	eval_error(sc, "case clause result missing: ~A", car(x));

      if ((bodies_simple) && (!is_null(cddar(x))))
	{
	  bodies_simple = false;
	  bodies_simplest = false;
	}
      if (bodies_simplest)
	{
	  if ((is_pair(cadar(x))) &&
	      (caadar(x) != sc->quote_symbol))
	    {
	      if (is_pair(caar(x)))
		bodies_simplest = false;
	      else
		{
		  if ((caar(x) != sc->else_object) && (caar(x) != sc->else_symbol) &&
		      ((!is_symbol(caar(x))) ||
		       (s7_symbol_value(sc, caar(x)) != sc->else_object)))
		    bodies_simplest = false;
		}
	    }
	}
      y = caar(x);
      if (!is_pair(y))
	{
	  if ((y != sc->else_object) && (y != sc->else_symbol) &&        /* (case 1 (2 1)) */
	      ((!is_symbol(y)) ||
	       (s7_symbol_value(sc, y) != sc->else_object)))             /* "proper list" below because: (case 1 (() 2) ... */
	    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)) */
	    eval_error(sc, "case 'else' clause, ~A, is not the last clause", x);
	  have_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>
	   * but we do support: (let ((otherwise else)) (case 0 ((1) 2) (otherwise 3))) -> 3!
	   *   is that consistent? 
	   *   (let ((else #f)) (case 0 ((1) 2) (else 3))) -> 3
	   *   (case 0 ((1) 2) (else (let ((else 3)) else))) -> 3
	   * 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
	   * another approach: make else a value, not a symbol, like #<unspecified>, evaluates to itself
	   * or set it to be immutable, but I guess I'll say "use #_else" for now.
	   */
	  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) */
		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_symbol) &&
	  (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
	{
	  has_feed_to = true;
	  if (!is_pair(cddr(y)))                                  /* (case 1 (else =>)) */
	    eval_error(sc, "case: '=>' target missing?  ~A", y);
	  if (is_pair(cdddr(y)))                                  /* (case 1 (else => + - *)) */
	    eval_error(sc, "case: '=>' has too many targets: ~A", y);
	}
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
	{
	  set_opt_key(x, caar(x));
	  if (is_pair(opt_key(x))) set_opt_clause(x, cadar(x));
	}
      pair_set_syntax_symbol(sc->code, sc->case_unchecked_symbol);

      if ((!has_feed_to) &&
	  (keys_simple))
	{
	  if (have_else) /* don't combine ifs ! */
	    {
	      if (is_symbol(car(sc->code)))
		pair_set_syntax_symbol(sc->code, sc->case_simple_symbol);
	    }
	  else
	    {
	      if (keys_single)
		{
		  if ((bodies_simple) &&
		      (is_symbol(car(sc->code))))
		    pair_set_syntax_symbol(sc->code, sc->case_simplest_symbol);
		  else
		    {
		      if ((is_optimized(car(sc->code))) &&
			  (optimize_op(car(sc->code)) == HOP_SAFE_C_SS))
			pair_set_syntax_symbol(sc->code, sc->case_simplest_ss_symbol);
		    }
		  for (x = cdr(sc->code); is_not_null(x); x = cdr(x))
		    set_opt_key(x, caaar(x));
		}
	      else
		{
		  if (bodies_simple)
		    {
		      if (is_symbol(car(sc->code)))
			pair_set_syntax_symbol(sc->code, sc->case_simpler_1_symbol);
		      else
			{
			  if ((is_optimized(car(sc->code))) &&
			      (optimize_op(car(sc->code)) == HOP_SAFE_C_SS))
			    pair_set_syntax_symbol(sc->code, sc->case_simpler_ss_symbol);
			}
		    }
		  else
		    {
		      if (is_symbol(car(sc->code)))
			pair_set_syntax_symbol(sc->code, sc->case_simpler_symbol);
		    }
		}
	    }
	}
    }
  return(sc->code);
}


static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer start)
{
  s7_pointer binding;

  pair_set_syntax_symbol(sc->code, sc->let_one_symbol);
  binding = car(start);

  if (is_pair(cadr(binding)))
    {
      if (is_h_optimized(cadr(binding)))
	{
	  if (is_null(cddr(sc->code)))                /* one statement body */
	    {
	      set_opt_sym2(cdr(sc->code), car(binding));
	      set_opt_pair2(sc->code, cadr(binding));
	      pair_set_syntax_symbol(sc->code, sc->let_z_symbol);

	      if ((is_h_safe_c_s(cadr(binding))) &&
		  (is_pair(cadr(sc->code))))          /* one body expr is a pair */
		{
		  pair_set_syntax_symbol(sc->code, sc->let_opsq_p_symbol);
		  set_opt_sym2(sc->code, cadr(cadr(binding)));

		  if ((!is_optimized(cadr(sc->code))) &&
		      (is_syntactic_symbol(caadr(sc->code))))
		    {
		      /* the is_optimized check here and in other parallel cases protects against cases like:
		       *   (define (hi) (let ((e #f)) (let ((val (not e))) (if (boolean? val) val e)))) (hi)
		       * where the "(if...)" part is optimized as safe_c_s before we get here.  If we simply
		       * pair_set_syntax_op(cadr(sc->code)) as below, the optimization bit is on, but the
		       * apparent optimize_op (op) is now safe_c_qq! So eval ejects it and it is handled by the
		       * explicit ("trailers") code.
		       */
		      pair_set_syntax_op(cadr(sc->code), symbol_syntax_op(caadr(sc->code)));
		    }
		  return(sc->code);
		}
	    }

	  if (is_h_safe_c_s(cadr(binding)))
	    {
	      pair_set_syntax_symbol(sc->code, sc->let_opsq_symbol);
	      set_opt_sym2(sc->code, cadr(cadr(binding)));
	      return(sc->code);
	    }
	  /* opt1 here is opt_back */
	  set_opt_pair2(sc->code, cadr(binding));
	  if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS)
	    {
	      pair_set_syntax_symbol(sc->code, sc->let_opssq_symbol);
	      set_opt_sym3(sc->code, caddr(cadr(binding)));
	    }
	  else
	    {
	      if (optimize_op(cadr(binding)) == HOP_SAFE_C_C)
		{
		  set_opt_sym3(sc->code, car(binding));
		  pair_set_syntax_symbol(sc->code, sc->let_opcq_symbol);
		}
	      /* let_all_x here is slightly slower than fallback let_z */
	    }
	}
    }
  else
    {
      s7_pointer p;
      p = cadaar(sc->code);                    /* sc->code is of the form '(((x y))...) */
      set_opt_sym3(sc->code, caaar(sc->code));
      if (is_symbol(p))
	{
	  set_opt_sym2(sc->code, p);
	  pair_set_syntax_symbol(sc->code, sc->let_s_symbol);
	}
      else 
	{
	  set_opt_con2(sc->code, p);
	  pair_set_syntax_symbol(sc->code, sc->let_c_symbol);
	}
    }
  return(sc->code);
}


static s7_pointer check_let(s7_scheme *sc)
{
  s7_pointer x, start;
  bool named_let;
  int vars;

  if (!is_pair(sc->code))               /* (let . 1) */
    {
      if (is_null(sc->code))            /* (let) */
	eval_error(sc, "let has no variables or body: ~A", sc->code);
      eval_error(sc, "let form is an improper list? ~A", sc->code);
    }

  if (!is_pair(cdr(sc->code)))          /* (let () ) */
    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))))
    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) */
	eval_error(sc, "let variable list is messed up: ~A", sc->code);
      if (is_null(cddr(sc->code)))              /* (let hi () ) */
	eval_error(sc, "named let has no body: ~A", sc->code);
      if (is_immutable_symbol(car(sc->code)))
	return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), sc->code)));
      set_local(car(sc->code));
      start = cadr(sc->code);
    }
  else start = car(sc->code);

  clear_syms_in_list(sc);
  for (vars = 0, x = start; is_pair(x); vars++, x = cdr(x))
    {
      s7_pointer y, carx;

      carx = car(x);

      if ((!is_pair(carx)) || (is_null(cdr(carx))))  /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */
	eval_error(sc, "let variable declaration, but no value?: ~A", x);

      if (!(is_pair(cdr(carx))))                     /* (let ((x . 1))...) */
	eval_error(sc, "let variable declaration is not a proper list?: ~A", x);

      if (is_not_null(cddr(carx)))                   /* (let ((x 1 2 3)) ...) */
	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) ..")
       */

      y = car(carx);
      if (!(is_symbol(y)))
	eval_error(sc, "bad variable ~S in let", carx);

      if (is_immutable_symbol(y))
	return(s7_error(sc, sc->wrong_type_arg_symbol,	set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));

      /* check for name collisions -- not sure this is required by Scheme */
      if (symbol_tag(y) == sc->syms_tag)
	eval_error(sc, "duplicate identifier in let: ~A", y);
      add_sym_to_list(sc, y);
      set_local(y);
    }

  /* we accept (let ((:hi 1)) :hi)
   *           (let ('1) quote) [guile accepts this]
   */

  if (is_not_null(x))                  /* (let* ((a 1) . b) a) */
    eval_error(sc, "let var list improper?: ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (named_let)
	{
	  s7_pointer ex;

	  if (is_null(start))
	    pair_set_syntax_symbol(sc->code, sc->named_let_no_vars_symbol);
	  else pair_set_syntax_symbol(sc->code, sc->named_let_symbol);

	  /* 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 (ex = start; is_pair(ex); ex = cdr(ex))
	    sc->args = cons(sc, caar(ex), sc->args);
	  optimize_lambda(sc, true, car(sc->code), sc->args = safe_reverse_in_place(sc, sc->args), cddr(sc->code));

	  /* apparently these guys are almost never safe */
	  return(sc->code);
	}

      if (is_null(start))
	pair_set_syntax_symbol(sc->code, sc->let_no_vars_symbol);
      else
	{
	  pair_set_syntax_symbol(sc->code, sc->let_unchecked_symbol);
	  if (is_null(cdr(start)))                                    /* one binding */
	    check_let_one_var(sc, start);
	  else
	    {
	      if (vars < GC_TRIGGER_SIZE)
		{
		  s7_pointer p, op;

		  op = sc->nil;
		  for (p = start; is_pair(p); p = cdr(p))
		    {
		      s7_pointer x;
		      x = car(p);
		      if (is_pair(cadr(x)))
			{
			  if (car(cadr(x)) == sc->quote_symbol)
			    op = sc->let_all_x_symbol;
			  else
			    {
			      if (is_h_safe_c_s(cadr(x)))
				{
				  if ((op == sc->nil) || (op == sc->let_all_opsq_symbol))
				    op = sc->let_all_opsq_symbol;
				  else op = sc->let_all_x_symbol;
				}
			      else
				{
				  if (is_all_x_safe(sc, cadr(x)))
				    op = sc->let_all_x_symbol;
				  else
				    {
				      op = sc->let_unchecked_symbol;
				      break;
				    }
				}
			    }
			}
		      else
			{
			  if (is_symbol(cadr(x)))
			    {
			      if ((op == sc->nil) || (op == sc->let_all_s_symbol))
				op = sc->let_all_s_symbol;
			      else op = sc->let_all_x_symbol;
			    }
			  else
			    {
			      if ((op == sc->nil) || (op == sc->let_all_c_symbol))
				op = sc->let_all_c_symbol;
			      else op = sc->let_all_x_symbol;
			    }
			}
		    }
		  pair_set_syntax_symbol(sc->code, op);
		}
	      else pair_set_syntax_symbol(sc->code, sc->let_unchecked_symbol);
	    }
	}
      if (pair_syntax_symbol(sc->code) == sc->let_all_x_symbol)
	{
	  s7_pointer p;
	  for (p = start; is_pair(p); p = cdr(p))
	    set_c_call(cdar(p), all_x_eval(sc, cadar(p), sc->envir, let_symbol_is_safe));
	}
    }
  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) */
    eval_error(sc, "let* variable list is messed up: ~A", sc->code);

  if (!is_pair(cdr(sc->code)))               /* (let*) */
    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) */
	eval_error(sc, "let* variable list is messed up: ~A", sc->code);
      if (is_null(cddr(sc->code)))                  /* (let* hi () ) */
	eval_error(sc, "named let* has no body: ~A", sc->code);
      if (is_immutable_symbol(car(sc->code)))
	return(s7_error(sc, sc->wrong_type_arg_symbol,	set_elist_2(sc, make_string_wrapper(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)) ...) */
	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)) ...) */
	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) */
	eval_error(sc, "bad variable ~S in let*", x);

      z = car(x);
      if (is_immutable_symbol(z))
	return(s7_error(sc, sc->wrong_type_arg_symbol,	set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));

      if (!is_pair(x))                              /* (let* ((x)) ...) */
	eval_error(sc, "let* variable declaration, but no value?: ~A", x);

      if (!(is_pair(cdr(x))))                       /* (let* ((x . 1))...) */
	eval_error(sc, "let* variable declaration is not a proper list?: ~A", x);

      if (is_not_null(cddr(x)))                     /* (let* ((x 1 2 3)) ...) */
	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) */
	    eval_error(sc, "let* variable/binding is ~S?", car(x));

	  if (!is_pair(cdar(x)))                    /* (let* ((a 1) (b . 2)) ...) */
	    eval_error(sc, "let* variable list is messed up? ~A", x);
	}
      else
	{
	  if (is_not_null(x))                       /* (let* ((a 1) . b) a) */
	    eval_error(sc, "let* var list improper?: ~A", x);
	}

      /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error! */
      set_local(z);
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (named_let)
	{
	  if (is_null(cadr(sc->code)))
	    pair_set_syntax_symbol(sc->code, sc->named_let_no_vars_symbol);
	  else
	    {
	      pair_set_syntax_symbol(sc->code, sc->named_let_star_symbol);
	      set_opt_con2(sc->code, cadr(car(cadr(sc->code))));
	    }
	  return(sc->code);
	}

      pair_set_syntax_symbol(sc->code, sc->let_star_unchecked_symbol);
      if (is_null(car(sc->code)))
	pair_set_syntax_symbol(sc->code, sc->let_no_vars_symbol); /* (let* () ...) */
      else
	{
	  if (is_null(cdar(sc->code)))
	    check_let_one_var(sc, car(sc->code)); /* (let* ((var...))...) -> (let ((var...))...) */
	  else  /* more than one entry */
	    {
	      s7_pointer p, op;
	      op = sc->let_star_all_x_symbol;
	      set_opt_con2(sc->code, cadaar(sc->code));
	      for (p = car(sc->code); is_pair(p); p = cdr(p))
		{
		  s7_pointer x;
		  x = car(p);
		  if (is_pair(cadr(x)))
		    {
		      if ((!is_all_x_safe(sc, cadr(x))) &&
			  (car(cadr(x)) != sc->quote_symbol))
			{
			  op = sc->let_star2_symbol;
			  break;
			}
		    }
		}
	      pair_set_syntax_symbol(sc->code, op);
	    }
	}
      if ((pair_syntax_symbol(sc->code) == sc->let_all_x_symbol) ||
	  (pair_syntax_symbol(sc->code) == sc->let_star_all_x_symbol))
	{
	  s7_pointer p;
	  for (p = car(sc->code); is_pair(p); p = cdr(p))
	    set_c_call(cdar(p), all_x_eval(sc, cadar(p), sc->envir, let_symbol_is_safe));
	}
    }
  return(sc->code);
}


static s7_pointer check_letrec(s7_scheme *sc, bool letrec)
{
  s7_pointer x, caller;
  caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol;
  if ((!is_pair(sc->code)) ||                 /* (letrec . 1) */
      (!is_pair(cdr(sc->code))) ||            /* (letrec) */
      (!s7_is_list(sc, car(sc->code))))       /* (letrec 1 ...) */
    eval_error_with_caller(sc, "~A: variable list is messed up: ~A", caller, sc->code);

  clear_syms_in_list(sc);
  for (x = car(sc->code); is_not_null(x); x = cdr(x))
    {
      s7_pointer y, carx;
      if (!is_pair(x))                        /* (letrec ((a 1) . 2) ...) */
	eval_error_with_caller(sc, "~A: improper list of variables? ~A", caller, sc->code);

      carx = car(x);
      if ((!is_pair(carx)) ||                 /* (letrec (1 2) #t) */
	  (!(is_symbol(car(carx)))))
	eval_error_with_caller(sc, "~A: bad variable ~S", caller, carx);

      y = car(carx);
      if (is_immutable_symbol(y))
	return(s7_error(sc, sc->wrong_type_arg_symbol,	set_elist_2(sc, make_string_wrapper(sc, "can't bind an immutable object: ~S"), x)));

      if (!is_pair(cdr(carx)))                /* (letrec ((x . 1))...) */
	{
	  if (is_null(cdr(carx)))             /* (letrec ((x)) x) -- perhaps this is legal? */
	    eval_error_with_caller(sc, "~A: variable declaration has no value?: ~A", caller, carx);
	  eval_error_with_caller(sc, "~A: variable declaration is not a proper list?: ~A", caller, carx);
	}
      if (is_not_null(cddr(carx)))            /* (letrec ((x 1 2 3)) ...) */
	eval_error_with_caller(sc, "~A: variable declaration has more than one value?: ~A", caller, carx);

      /* check for name collisions -- this is needed in letrec* else which of the two legit values
       *    does our "rec" refer to, so to speak.
       */
      if (symbol_tag(y) == sc->syms_tag)
	eval_error_with_caller(sc, "~A: duplicate identifier: ~A", caller, y);
      add_sym_to_list(sc, y);
      set_local(y);
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    pair_set_syntax_symbol(sc->code, (letrec) ? sc->letrec_unchecked_symbol : sc->letrec_star_unchecked_symbol);

  return(sc->code);
}


static s7_pointer check_quote(s7_scheme *sc)
{
  if (!is_pair(sc->code))                    /* (quote . -1) */
    {
      if (is_null(sc->code))
	eval_error(sc, "quote: not enough arguments: ~A", sc->code);
      eval_error(sc, "quote: stray dot?: ~A", sc->code);
    }
  if (is_not_null(cdr(sc->code)))             /* (quote . (1 2)) or (quote 1 1) */
    eval_error(sc, "quote: too many arguments ~A", sc->code);
#if 0
  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      pair_set_syntax_symbol(sc->code, sc->quote_unchecked_symbol);
    }
#endif
  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) */
    eval_error(sc, "and: stray dot?: ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (all_pairs)
	{
	  for (p = sc->code; is_pair(p); p = cdr(p))
	    set_c_call(p, all_x_eval(sc, car(p), sc->envir, let_symbol_is_safe));  /* c_callee can be nil! */
	  if ((c_callee(sc->code)) &&
	      (is_pair(cdr(sc->code))) &&
	      (is_null(cddr(sc->code))))
	    pair_set_syntax_symbol(sc->code, sc->and_p2_symbol);
	  else pair_set_syntax_symbol(sc->code, sc->and_p_symbol);
	}
      else pair_set_syntax_symbol(sc->code, sc->and_unchecked_symbol);
    }
  return(sc->code);
}


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))
    eval_error(sc, "or: stray dot?: ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (all_pairs)
	{
	  s7_pointer ep;
	  for (ep = sc->code; is_pair(ep); ep = cdr(ep))
	    set_c_call(ep, all_x_eval(sc, car(ep), sc->envir, let_symbol_is_safe));
	  if ((c_callee(sc->code)) &&
	      (is_pair(cdr(sc->code))) &&
	      (is_null(cddr(sc->code))))
	    pair_set_syntax_symbol(sc->code, sc->or_p2_symbol);
	  else pair_set_syntax_symbol(sc->code, sc->or_p_symbol);
	}
      else pair_set_syntax_symbol(sc->code, sc->or_unchecked_symbol);
    }
  return(sc->code);
}


static s7_pointer check_if(s7_scheme *sc)
{
  s7_pointer cdr_code;

  if (!is_pair(sc->code))                                /* (if) or (if . 1) */
    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) */
    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) */
	eval_error(sc, "too many clauses for if: ~A", sc->code);
    }
  else
    {
      if (is_not_null(cdr(cdr_code)))                    /* (if 1 2 . 3) */
	eval_error(sc, "if: ~A has improper list?", sc->code);
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      s7_pointer test;
      bool one_branch;
      pair_set_syntax_symbol(sc->code, sc->if_unchecked_symbol);

      one_branch = (is_null(cdr(cdr_code)));
      test = car(sc->code);
      if (is_pair(test))
	{
	  if (is_h_optimized(test))
	    {
	      if (optimize_op(test) == HOP_SAFE_C_C)
		{
		  if (c_callee(test) == g_and_all_x_2)
		    {
		      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_and2_p_symbol : sc->if_and2_p_p_symbol);
		      set_opt_and_2_test(sc->code, cddr(test));
		    }
		  else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_cc_p_symbol : sc->if_cc_p_p_symbol);
		  set_opt_pair2(sc->code, cdr(test));
		}
	      else
		{
		  if (is_h_safe_c_s(test))
		    {
		      /* these miss methods? */
		      if (car(test) == sc->is_pair_symbol)
			pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_is_pair_p_symbol : sc->if_is_pair_p_p_symbol);
		      else
			{
			  if (car(test) == sc->is_symbol_symbol)
			    pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_is_symbol_p_symbol : sc->if_is_symbol_p_p_symbol);
			  else
			    {
			      if (car(test) == sc->not_symbol)
				pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_not_s_p_symbol : sc->if_not_s_p_p_symbol);
			      else pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_cs_p_symbol : sc->if_cs_p_p_symbol);
			    }
			}
		      set_opt_sym2(sc->code, cadr(test));
		    }
		  else
		    {
		      if (optimize_op(test) == HOP_SAFE_C_SQ)
			{
			  pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_csq_p_symbol : sc->if_csq_p_p_symbol);
			  set_opt_con2(sc->code, cadr(caddr(test)));
			  set_opt_sym3(sc->code, cadr(test));
			}
		      else
			{
			  if (optimize_op(test) == HOP_SAFE_C_SS)
			    {
			      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_css_p_symbol : sc->if_css_p_p_symbol);
			      set_opt_sym2(sc->code, caddr(test));
			      set_opt_sym3(sc->code, cadr(test));
			    }
			  else
			    {
			      if (optimize_op(test) == HOP_SAFE_C_SC)
				{
				  pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_csc_p_symbol : sc->if_csc_p_p_symbol);
				  set_opt_con2(sc->code, caddr(test));
				  set_opt_sym3(sc->code, cadr(test));
				}
			      else
				{
				  if (optimize_op(test) == HOP_SAFE_C_S_opCq)
				    {
				      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_s_opcq_p_symbol : sc->if_s_opcq_p_p_symbol);
				      set_opt_pair2(sc->code, caddr(test));
				      set_opt_sym3(sc->code, cadr(test));
				    }
				  else
				    {
				      if (optimize_op(test) == HOP_SAFE_C_opSSq)
					{
					  pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_opssq_p_symbol : sc->if_opssq_p_p_symbol);
					  set_opt_pair2(sc->code, cadar(sc->code));
					  set_opt_sym3(sc->code, caddr(opt_pair2(sc->code)));
					}
				      else
					{
					  if (is_all_x_safe(sc, test))
					    {
					      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_a_p_symbol : sc->if_a_p_p_symbol);
					      set_c_call(sc->code, all_x_eval(sc, test, sc->envir, let_symbol_is_safe));
					      /* fprintf(stderr, "%s\n", DISPLAY(sc->code)); */
					    }
					  else
					    {
					      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_z_p_symbol : sc->if_z_p_p_symbol);
					      set_opt_con2(sc->code, cadr(sc->code));
					    }
					}
				    }
				}
			    }
			}
		    }
		}
	    }
	  else
	    {
	      pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_p_p_symbol : sc->if_p_p_p_symbol);
	      if (is_syntactic_symbol(car(test)))
		{
		  pair_set_syntax_op(test, symbol_syntax_op(car(test)));

		  if ((symbol_syntax_op(car(test)) == OP_AND) ||
		      (symbol_syntax_op(car(test)) == OP_OR))
		    {
		      opcode_t new_op;
		      s7_pointer old_code;
		      old_code = sc->code;
		      sc->code = cdr(test);
		      if (symbol_syntax_op(car(test)) == OP_AND) check_and(sc); else check_or(sc);
		      new_op = symbol_syntax_op(car(test));
		      sc->code = old_code;
		      if ((new_op == OP_AND_P) || (new_op == OP_AND_P2))
			pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_andp_p_symbol : sc->if_andp_p_p_symbol);
		      else
			{
			  if ((new_op == OP_OR_P) || (new_op == OP_OR_P2))
			    pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_orp_p_symbol : sc->if_orp_p_p_symbol);
			}
		    }
		}
	    }
	}
      else /* test is symbol or constant, but constant here is nutty */
	{
	  if (is_symbol(test))
	    pair_set_syntax_symbol(sc->code, (one_branch) ? sc->if_s_p_symbol : sc->if_s_p_p_symbol);
	}
    }
  return(sc->code);
}


static s7_pointer optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body)
{
  int len;
  /* fprintf(stderr, "opt %s %s\n", DISPLAY(args), DISPLAY(body)); */

  len = s7_list_length(sc, body);
  if (len < 0)                                                               /* (define (hi) 1 . 2) */
    eval_error_with_caller(sc, "~A: function body messed up, ~A", (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, sc->code);

  if (len > 0)  /* i.e. not circular */
    {
      s7_pointer lst;

      clear_syms_in_list(sc);
      if (is_symbol(func))
	lst = list_1(sc, add_sym_to_list(sc, func));
      else lst = sc->nil;
      optimize(sc, body, 1, collect_collisions_star(sc, args, lst));

      /* if the body is safe, we can optimize the calling sequence */
      if ((is_proper_list(sc, args)) &&
	  (!arglist_has_rest(sc, args)))
	{
	  if (!unstarred_lambda)
	    {
	      s7_pointer p;
	      bool happy = true;
	      /* check default vals -- if none is an expression or symbol, set simple args */
	      for (p = args; is_pair(p); p = cdr(p))
		{
		  s7_pointer arg;
		  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_symbol))))
		    {
		      happy = false;
		      break;
		    }
		}
	      if (happy)
		set_simple_args(body);
	    }
	  sc->cycle_counter = 0;
	  if (((unstarred_lambda) || (has_simple_args(body))) &&
	      (body_is_safe(sc, func, body, true)))
	    {
	      /* there is one problem with closure* here -- we can't trust anything that has fancy (non-constant) default argument values. */
	      set_safe_closure(body);
	      /* this bit is set on the function itself in make_closure and friends */
	    }
	}
    }
  return(NULL);
}


static s7_pointer check_define(s7_scheme *sc)
{
  s7_pointer func, caller;
  bool starred;
  int arity = CLOSURE_ARITY_NOT_SET;

  starred = (sc->op == OP_DEFINE_STAR);
  if (starred)
    {
      caller = sc->define_star_symbol;
      sc->op = OP_DEFINE_STAR_UNCHECKED;
    }
  else 
    {
      if (sc->op == OP_DEFINE)
	caller = sc->define_symbol;
      else caller = sc->define_constant_symbol;
    }

  if (!is_pair(sc->code))
    eval_error_with_caller(sc, "~A: nothing to define? ~A", caller, sc->code);     /* (define) */

  if (!is_pair(cdr(sc->code)))
    {
      if (is_null(cdr(sc->code)))
	eval_error_with_caller(sc, "~A: no value? ~A", caller, sc->code);          /* (define var) */
      eval_error_with_caller(sc, "~A: bad form? ~A", caller, sc->code);            /* (define var . 1) */
    }
  if (!is_pair(car(sc->code)))
    {
      if (is_not_null(cddr(sc->code)))                                           /* (define var 1 . 2) */
	eval_error_with_caller(sc, "~A: more than 1 value? ~A", caller, sc->code); /* (define var 1 2) */
      if (starred)
	eval_error(sc, "define* is restricted to functions: (define* ~{~S~^ ~})", sc->code);

      func = car(sc->code);
      if (!is_symbol(func))                                                      /* (define 3 a) */
	eval_error_with_caller(sc, "~A: define a non-symbol? ~S", caller, func);
      if (is_keyword(func))                                                      /* (define :hi 1) */
	eval_error_with_caller(sc, "~A ~A: keywords are constants", caller, func);
      if (is_syntactic(func))                                                    /* (define and a) */
	{
	  if (sc->safety > 0)
	    s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined", DISPLAY(func));
	  set_local(func);
	}

      if ((is_pair(cadr(sc->code))) &&               /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */
	  ((caadr(sc->code) == sc->lambda_symbol) ||
	   (caadr(sc->code) == sc->lambda_star_symbol)) &&
	  (symbol_id(caadr(sc->code)) == 0))
	/* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */
	optimize_lambda(sc, caadr(sc->code) == sc->lambda_symbol, func, cadr(cadr(sc->code)), cddr(cadr(sc->code)));
    }
  else
    {
      func = caar(sc->code);
      if (!is_symbol(func))                                                      /* (define (3 a) a) */
	eval_error_with_caller(sc, "~A: define a non-symbol? ~S", caller, func);
      if (is_syntactic(func))                                                    /* (define (and a) a) */
	{
	  if (sc->safety > 0)
	    s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined", DISPLAY(func));
	  set_local(func);
	}
      if (starred)
	set_cdar(sc->code, check_lambda_star_args(sc, cdar(sc->code), &arity));
      else check_lambda_args(sc, cdar(sc->code), &arity);
      optimize_lambda(sc, !starred, func, cdar(sc->code), cdr(sc->code));
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (sc->op == OP_DEFINE)
	{
	  if ((is_pair(car(sc->code))) &&
	      (!symbol_has_accessor(func)) &&
	      (!is_immutable_symbol(func)))
	    pair_set_syntax_symbol(sc->code, sc->define_funchecked_symbol);
	  else pair_set_syntax_symbol(sc->code, sc->define_unchecked_symbol);
	}
      else 
	{
	  if (starred)
	    pair_set_syntax_symbol(sc->code, sc->define_star_unchecked_symbol);
	  else pair_set_syntax_symbol(sc->code, sc->define_constant_unchecked_symbol); 
	}
    }
  return(sc->code);
}

static int define_unchecked_ex(s7_scheme *sc)
{
  if (sc->op == OP_DEFINE_STAR_UNCHECKED)
    {
      s7_pointer x;
      unsigned int typ;
      if (is_safe_closure(cdr(sc->code)))
	typ = T_CLOSURE_STAR | T_PROCEDURE | T_SAFE_CLOSURE;
      else typ = T_CLOSURE_STAR | T_PROCEDURE;
      new_cell(sc, x, typ);
      closure_set_args(x, cdar(sc->code));
      closure_set_body(x, cdr(sc->code));
      closure_set_let(x, sc->envir);
      closure_arity(x) = CLOSURE_ARITY_NOT_SET;
      closure_set_setter(x, sc->F);
      sc->capture_let_counter++;
      sc->value = x;
      sc->code = caar(sc->code);
      return(fall_through);
    }

  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);
	  return(goto_EVAL);
	}
      
      if (is_symbol(sc->code))
	sc->value = find_global_symbol_checked(sc, sc->code);
      else sc->value = sc->code;
      sc->code = x;
    }
  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 opt2 somewhere, and pick it up the next time around (since call/cc might take
       *   us back to the previous case).  We also can't re-use opt2(sc->code) because opt2
       *   is not cleared in the gc.
       */
      make_closure_with_let(sc, x, cdar(sc->code), cdr(sc->code), sc->envir);
      sc->value = _NFre(x);
      sc->code = caar(sc->code);
    }
  return(fall_through);
}

static void define_funchecked(s7_scheme *sc)
{
  s7_pointer new_func, new_env, code;
  code = sc->code;
  sc->value = caar(code);
  
  new_cell(sc, new_func, T_CLOSURE | T_PROCEDURE | T_COPY_ARGS);
  closure_set_args(new_func, cdar(code));
  closure_set_body(new_func, cdr(code));
  closure_set_setter(new_func, sc->F);
  closure_arity(new_func) = CLOSURE_ARITY_NOT_SET;
  sc->capture_let_counter++;
  
  if (is_safe_closure(cdr(code)))
    {
      s7_pointer arg;
      set_safe_closure(new_func);
      
      new_cell_no_check(sc, new_env, T_LET | T_FUNCTION_ENV);
      let_id(new_env) = ++sc->let_number;
      let_set_slots(new_env, sc->nil);
      set_outlet(new_env, sc->envir);
      closure_set_let(new_func, new_env);
      funclet_set_function(new_env, sc->value);
      
      for (arg = closure_args(new_func); is_pair(arg); arg = cdr(arg))
	make_slot_1(sc, new_env, car(arg), sc->nil);
      let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
    }
  else closure_set_let(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);
  sc->value = new_func;
}

		    
static int lambda_star_default(s7_scheme *sc)
{
  while (true)
    {
      s7_pointer z;
      z = sc->args;
      if (is_slot(z))
	{
	  if (slot_value(z) == sc->undefined)
	    {
	      if (is_closure_star(sc->code))
		{
		  s7_pointer val;
		  val = slot_expression(z);
		  if (is_symbol(val))
		    {
		      slot_set_value(z, find_symbol_checked(sc, val));
		      if (slot_value(z) == sc->undefined)
			{
			  /* the current environment here contains the function parameters which
			   *   defaulted to #<undefined> earlier in apply_lambda_star,
			   *   so (define (f f) (define* (f (f f)) f) (f)) (f 0) looks for the
			   *   default f, finds itself currently undefined, and raises an error!
			   *   So, before claiming it is unbound, we need to check outlet as well.
			   *   But in the case above, the inner define* shadows the caller's
			   *   parameter before checking the default arg values, so the default f
			   *   refers to the define* -- I'm not sure this is a bug.  It means 
			   *   that (define* (f (a f)) a) returns f: (equal? f (f)) -> #t, so
			   *   any outer f needs an extra let and endless outlets:
			   *   (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3
			   *   We want the shadowing once the define* is done, so the current mess is simplest.
			   */
			  slot_set_value(z, s7_symbol_local_value(sc, val, outlet(sc->envir)));
			  if (slot_value(z) == sc->undefined)
			    eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* defaults: ~A is unbound", slot_symbol(z));
			  /* but #f is default if no expr, so there's some inconsistency here */
			}
		    }
		  else
		    {
		      if (is_pair(val))
			{
			  if (car(val) == sc->quote_symbol)
			    {
			      if ((!is_pair(cdr(val))) ||      /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */
				  (is_pair(cddr(val))))
				eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* default: ~A is messed up", val);
			      slot_set_value(z, cadr(val));
			    }
			  else
			    {
			      push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
			      sc->code = val;
			      return(goto_EVAL);
			    }
			}
		      else slot_set_value(z, val);
		    }
		}
	      else slot_set_value(z, slot_expression(z));
	    }
	  sc->args = slot_pending_value(z);
	}
      else break;
    }
  return(fall_through);
}

#if 0
static void unsafe_closure_2(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2)
{
  s7_pointer code, args;
  if (sc->stack_end >= sc->stack_resize_trigger) resize_stack(sc); /* not check_stack_size because it tries to return sc->F */
  code = opt_lambda(sc->code);
  args = closure_args(code);
  new_frame_with_two_slots(sc, closure_let(code), sc->envir, car(args), arg1, cadr(args), arg2);
  sc->code = closure_body(code);
}
#else
#define unsafe_closure_2(Sc, Arg1, Arg2) \
{ \
  s7_pointer Code, Args, A1, A2; A1 = Arg1; A2 = Arg2; \
  if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc); \
  Code = opt_lambda(Sc->code); \
  Args = closure_args(Code); \
  new_frame_with_two_slots(Sc, closure_let(Code), Sc->envir, car(Args), A1, cadr(Args), A2); \
  Sc->code = closure_body(Code); \
}
#endif

static void unsafe_closure_star(s7_scheme *sc)
{
  s7_pointer x, z, e;
  unsigned long long int id;
  
  new_frame(sc, closure_let(sc->code), sc->envir);
  e = sc->envir;
  id = let_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);
      
      set_type(z, T_SLOT);
      slot_set_symbol(z, sym);
      symbol_set_local(sym, id, z);
      slot_set_value(z, val);
      set_next_slot(z, let_slots(e));
      let_set_slots(e, z);
      z = args;
    }
  sc->code = closure_body(sc->code);
}

static void fill_closure_star(s7_scheme *sc, s7_pointer p)
{
  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 = opt_lambda(sc->code);
}

static void fill_safe_closure_star(s7_scheme *sc, s7_pointer x, s7_pointer p)
{
  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), let_id(sc->envir), x);
    }
  sc->code = closure_body(opt_lambda(sc->code));
}
	  

static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op)
{
  s7_pointer x, y, caller;
  caller = sc->define_macro_symbol;
  switch (op)
    {
    case OP_DEFINE_MACRO:      caller = sc->define_macro_symbol;      break;
    case OP_DEFINE_MACRO_STAR: caller = sc->define_macro_star_symbol; break;
    case OP_DEFINE_BACRO:      caller = sc->define_bacro_symbol;      break;
    case OP_DEFINE_BACRO_STAR: caller = sc->define_bacro_star_symbol; break;
    case OP_DEFINE_EXPANSION:  caller = sc->define_expansion_symbol;  break;
    }

  if (!is_pair(sc->code))                                               /* (define-macro . 1) */
    eval_error_with_caller(sc, "~A name missing (stray dot?): ~A", caller, sc->code);
  if (!is_pair(car(sc->code)))                                          /* (define-macro a ...) */
    return(wrong_type_argument_with_type(sc, caller, 1, car(sc->code), make_string_wrapper(sc, "a list: (name ...)")));
  /* not car(opt_back(sc->code)) to get the caller (e.g. 'define-bacro) because opt_back might not be set: (apply define-macro '(1)) */

  x = caar(sc->code);
  if (!is_symbol(x))
    eval_error_with_caller(sc, "~A: ~S is not a symbol?", caller, x);
  if (dont_eval_args(x))                                               /* (define-macro (quote a) quote) */
    {
      if (sc->safety > 0)
	s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined", DISPLAY(x));
      set_local(x);
    }
  if (is_immutable_symbol(x))
    eval_error_with_caller(sc, "~A: ~S is immutable", caller, x);

  if (!is_pair(cdr(sc->code)))                /* (define-macro (...)) */
    eval_error_with_caller(sc, "~A ~A, but no body?", caller, x);

  y = cdar(sc->code);            /* the arglist */
  if ((!s7_is_list(sc, y)) &&
      (!is_symbol(y)))
    return(s7_error(sc, sc->syntax_error_symbol,                                      /* (define-macro (mac . 1) ...) */
		    set_elist_3(sc, make_string_wrapper(sc, "macro ~A argument list is ~S?"), x, y)));

  for ( ; is_pair(y); y = cdr(y))
    if ((!is_symbol(car(y))) &&
	((sc->op == OP_DEFINE_MACRO) || (sc->op == OP_DEFINE_BACRO) || (sc->op == OP_DEFINE_EXPANSION)))
      return(s7_error(sc, sc->syntax_error_symbol,                                    /* (define-macro (mac 1) ...) */
		      set_elist_3(sc, make_string_wrapper(sc, "define-macro ~A argument name is not a symbol: ~S"), x, y)));

  if ((sc->op == OP_DEFINE_MACRO_STAR) || (sc->op == OP_DEFINE_BACRO_STAR))
    set_cdar(sc->code, check_lambda_star_args(sc, cdar(sc->code), NULL));
  else check_lambda_args(sc, cdar(sc->code), NULL);

  return(sc->code);
}

static int expansion_ex(s7_scheme *sc)
{
  int loc;
  s7_pointer caller;
  
  /* read-time macro expansion:
   *   (define-macro (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 like define-macro, but the programmer guarantees that the macro
   *   name will not be shadowed.
   *
   * to make expansion recognition fast here, define-expansion sets the T_EXPANSION
   *   bit in the symbol as well as the value:
   *   set_type(sc->code, T_EXPANSION | T_SYMBOL)
   * but this can lead to confusion because the expansion name is now globally identified as an expansion.
   *    (let () (define-expansion (ex1 a) `(+ ,a 1)) (display (ex1 3)))
   *    (define (ex1 b) (* b 2)) (display (ex1 3))
   * since this happens at the top level, the first line is evaluated, ex1 becomes an expansion.
   * but the reader has no idea about lets and whatnot, so in the second line, ex1 is still an expansion
   * to the reader, so it sees (define (+ b 1) ...) -- error!  To support tail-calls, there's no
   * way in eval to see the let close, so we can't clear the expansion flag when the let is done.
   * But we don't want define-expansion to mimic define-constant (via T_IMMUTABLE) because programs
   * like lint need to cancel reader-cond (for example).  So, we allow an expansion to be redefined,
   * and check here that the expander symbol still refers to an expansion.
   *
   * but in (define (ex1 b) b), the reader doesn't know we're in a define call (or it would be
   *   a bother to notice), so to redefine an expansion, first (set! ex1 #f) or (define ex1 #f),
   *   then (define (ex1 b) b).
   *
   * This is a mess!  Maybe we should insist that expansions are always global.
   *
   * run-time expansion and splicing into the code as in CL won't work in s7 because macros
   *   are first-class objects.  For example (define (f m) (m 1)), call it with a macro, say `(+ ,arg 1),
   *   and in CL-style, you'd now have the body (+ ,arg 1) or maybe even 2, now call f with a function,
   *   or some other macro -- oops!
   */
  
  loc = s7_stack_top(sc) - 1;
  if (is_pair(stack_args(sc->stack, loc)))
    caller = car(stack_args(sc->stack, loc)); /* this can be garbage */
  else caller = sc->F;
  if ((loc >= 3) &&
      (stack_op(sc->stack, loc) != OP_READ_QUOTE) &&             /* '(hi 1) for example */
      (stack_op(sc->stack, loc) != OP_READ_VECTOR) &&            /* #(reader-cond) for example */
      (caller != sc->quote_symbol) &&          /* (quote (hi 1)) */
      (caller != sc->macroexpand_symbol) &&    /* (macroexpand (hi 1)) */
      (caller != sc->define_expansion_symbol)) /* (define-expansion ...) being reloaded/redefined */
    {
      s7_pointer symbol, slot;
      /* we're playing fast and loose with sc->envir in the reader, so here we need a disaster check */
#if DEBUGGING
      if (unchecked_type(sc->envir) != T_LET) sc->envir = sc->nil;
#else
      if (!is_let(sc->envir)) sc->envir = sc->nil;
#endif
      symbol = car(sc->value);
      if ((symbol_id(symbol) == 0) ||
	  (sc->envir == sc->nil))
	slot = global_slot(symbol);
      else slot = find_symbol(sc, symbol);
      if (is_slot(slot))
	sc->code = slot_value(slot);
      else sc->code = sc->undefined;
      if (!is_expansion(sc->code))
	clear_expansion(symbol);
      else
	{
	  sc->args = copy_list(sc, cdr(sc->value));
	  return(goto_APPLY);
	}
    }
  return(fall_through);
}

static s7_pointer check_with_let(s7_scheme *sc)
{
  if (!is_pair(sc->code))                            /* (with-let . "hi") */
    eval_error(sc, "with-let takes an environment argument: ~A", sc->code);
  if (!is_pair(cdr(sc->code)))                       /* (with-let e) -> an error? */
    eval_error(sc, "with-let body is messed up: ~A", sc->code);
  if ((!is_pair(cddr(sc->code))) &&
      (!is_null(cddr(sc->code))))
    eval_error(sc, "with-let body has stray dot? ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      pair_set_syntax_symbol(sc->code, sc->with_let_unchecked_symbol);
      if ((is_symbol(car(sc->code))) &&
	  (is_pair(cadr(sc->code))))
	pair_set_syntax_symbol(sc->code, sc->with_let_s_symbol);
    }
  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) */
    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) */
	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)) */
	    eval_error(sc, "cond: stray dot? ~A", sc->code);
	  if ((cadr(y) == sc->feed_to_symbol) &&
	      (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
	    {
	      has_feed_to = true;
	      if (!is_pair(cddr(y)))                                  /* (cond (#t =>)) or (cond (#t => . 1)) */
		eval_error(sc, "cond: '=>' target missing?  ~A", x);
	      if (is_pair(cdddr(y)))                                  /* (cond (1 => + abs)) */
		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) */
    eval_error(sc, "cond: stray dot? ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (has_feed_to)
	{
	  pair_set_syntax_symbol(sc->code, sc->cond_unchecked_symbol);
	  if (is_null(cdr(sc->code)))
	    {
	      s7_pointer expr, f;
	      expr = car(sc->code);
	      f = caddr(expr);
	      if ((is_pair(f)) &&
		  (car(f) == sc->lambda_symbol) &&
		  (is_null(cdr(cddr(f)))))
		{
		  s7_pointer arg;
		  arg = cadr(f);
		  if ((is_pair(arg)) &&
		      (is_null(cdr(arg))) &&
		      (is_symbol(car(arg))))
		    {
		      /* (define (hi) (cond (#t => (lambda (s) s)))) */
		      set_opt_lambda2(sc->code, caddar(sc->code));  /* (lambda ...) above */
		      pair_set_syntax_symbol(sc->code, sc->if_p_feed_symbol);
		    }
		}
	    }
	}
      else
	{
	  s7_pointer p, sym = NULL;
	  bool xopt = true, c_s_is_ok = true;
	  pair_set_syntax_symbol(sc->code, sc->cond_simple_symbol);

	  for (p = sc->code; xopt && (is_pair(p)); p = cdr(p))
	    {
	      xopt = is_all_x_safe(sc, caar(p));
	      if ((c_s_is_ok) &&
		  (caar(p) != sc->T) &&
		  (caar(p) != sc->else_object))
		{
		  if ((!is_pair(caar(p))) ||
		      (!is_h_safe_c_s(caar(p))) ||
		      ((sym) && (sym != cadaar(p))))
		    c_s_is_ok = false;
		  else sym = cadaar(p);
		}
	    }
	  if (c_s_is_ok)
	    pair_set_syntax_symbol(sc->code, sc->cond_s_symbol);
	  else
	    {
	      if (xopt)
		{
		  int i;
		  pair_set_syntax_symbol(sc->code, sc->cond_all_x_symbol);
		  for (i = 0, p = sc->code; is_pair(p); i++, p = cdr(p))
		    set_c_call(car(p), cond_all_x_eval(sc, caar(p), (is_null(sc->envir)) ? sc->rootlet : sc->envir));  /* handle 'else' specially here */
		  if (i == 2)
		    pair_set_syntax_symbol(sc->code, sc->cond_all_x_2_symbol);
		}
	    }
	}
    }
  return(sc->code);
}


static s7_pointer check_set(s7_scheme *sc)
{
  if (!is_pair(sc->code))
    {
      if (is_null(sc->code))                                             /* (set!) */
	eval_error(sc, "set!: not enough arguments: ~A", sc->code);
      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) */
	eval_error(sc, "set!: not enough arguments: ~A", sc->code);
      eval_error(sc, "set!: stray dot? ~A", sc->code);           /* (set! var . 1) */
    }
  if (is_not_null(cddr(sc->code)))                                       /* (set! var 1 2) */
    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) */
    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) */
	eval_error(sc, "set! can't change ~S", car(sc->code));
    }

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(sc->code)))
    {
      if (is_pair(car(sc->code)))
	{
	  /* here we have (set! (...) ...) */
	  s7_pointer inner, value;
	  inner = car(sc->code);
	  value = cadr(sc->code);

	  pair_set_syntax_symbol(sc->code, sc->set_unchecked_symbol);
	  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))
		pair_set_syntax_symbol(sc->code, sc->set_pws_symbol);
	      else
		{
		  if ((is_pair(cdr(inner))) &&
		      (!is_pair(cddr(inner)))) /* we check cddr(sc->code) above */
		    {
		      if (!is_pair(cadr(inner)))
			{
			  /* (set! (f s) ...) */
			  if (!is_pair(value))
			    pair_set_syntax_symbol(sc->code, sc->set_pair_symbol);
			  else
			    {
			      pair_set_syntax_symbol(sc->code, sc->set_pair_p_symbol);
			      /* splice_in_values protects us here from values */
			      if (is_h_optimized(value)) /* this excludes h_unknown_g etc */
				{
				  pair_set_syntax_symbol(sc->code, sc->set_pair_z_symbol);
				  if (is_all_x_safe(sc, value))
				    {
				      s7_pointer obj;
				      annotate_arg(sc, cdr(sc->code), sc->envir);
				      pair_set_syntax_symbol(sc->code, sc->set_pair_za_symbol);
				      obj = find_symbol_checked(sc, car(inner));
				      if ((is_c_function(obj)) &&
					  (is_c_function(c_function_setter(obj))))
					{
					  pair_set_syntax_symbol(sc->code, sc->set_pair_a_symbol);
					}
				    }
				}
			    }
			}
		      else
			{
			  if ((car(cadr(inner)) == sc->quote_symbol) &&
			      (is_symbol(car(inner))) &&
			      ((is_symbol(value)) || (is_all_x_safe(sc, value))))
			    {
			      if (is_symbol(value))
				pair_set_syntax_symbol(sc->code, sc->set_let_s_symbol);
			      else
				{
				  pair_set_syntax_symbol(sc->code, sc->set_let_all_x_symbol);
				  set_c_call(cdr(sc->code), all_x_eval(sc, value, sc->envir, let_symbol_is_safe));
				}
			    }
			  else
			    {
			      if (is_h_safe_c_c(cadr(inner)))
				{
				  if (!is_pair(value))
				    pair_set_syntax_symbol(sc->code, sc->set_pair_c_symbol);
				  else
				    {
				      /* splice_in_values protects us here from values */
				      pair_set_syntax_symbol(sc->code, sc->set_pair_c_p_symbol);
				    }
				}
			    }
			}
		    }
		}
	    }
	}
      else pair_set_syntax_symbol(sc->code, sc->set_normal_symbol);

      if (is_symbol(car(sc->code)))
	{
	  s7_pointer settee, value;
	  settee = car(sc->code);
	  value = cadr(sc->code);

	  if ((!symbol_has_accessor(settee)) &&
	      (!is_syntactic(settee)))
	    {
	      if (is_symbol(value))
		pair_set_syntax_symbol(sc->code, sc->set_symbol_s_symbol);
	      else
		{
		  if (!is_pair(value))
		    pair_set_syntax_symbol(sc->code, sc->set_symbol_c_symbol);
		  else
		    {
		      if (car(value) == sc->quote_symbol)
			pair_set_syntax_symbol(sc->code, sc->set_symbol_q_symbol);
		      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
			   */
			  pair_set_syntax_symbol(sc->code, sc->set_symbol_p_symbol);
			  if (is_h_safe_c_s(value))
			    {
			      pair_set_syntax_symbol(sc->code, sc->set_symbol_opsq_symbol);
			      set_opt_sym2(sc->code, cadr(value));
			    }
			  else
			    {
			      if (is_h_optimized(value))
				{
				  pair_set_syntax_symbol(sc->code, sc->set_symbol_z_symbol);
				  if (optimize_op(value) == HOP_SAFE_C_C)
				    {
				      pair_set_syntax_symbol(sc->code, sc->set_symbol_opcq_symbol);
				      /* opt1 here points back? */
				      set_opt_pair2(sc->code, cdr(value));
				    }
				  else
				    {
				      /* most of these special cases probably don't matter */
				      if (optimize_op(value) == HOP_SAFE_C_SS)
					{
					  if (settee == cadr(value))
					    pair_set_syntax_symbol(sc->code, sc->increment_ss_symbol);
					  else pair_set_syntax_symbol(sc->code, sc->set_symbol_opssq_symbol);
					  set_opt_pair2(sc->code, cdr(value));
					}
				      else
					{
					  if (optimize_op(value) == HOP_SAFE_C_SSS)
					    {
					      if ((settee == cadr(value)) &&
						  (car(value) == sc->add_symbol))
						pair_set_syntax_symbol(sc->code, sc->increment_sss_symbol);
					      else pair_set_syntax_symbol(sc->code, sc->set_symbol_opsssq_symbol);
					      set_opt_pair2(sc->code, cdr(value));
					    }
					  else
					    {
					      if (is_all_x_safe(sc, value)) /* value = cadr(sc->code) */
						{
						  pair_set_syntax_symbol(sc->code, sc->set_symbol_a_symbol);
						  annotate_arg(sc, cdr(sc->code), sc->envir);
						}
					      if (is_callable_c_op(optimize_op(value)))
						{
						  if ((settee == cadr(value)) &&
						      (!is_null(cddr(value))))
						    {
						      if (is_null(cdddr(value)))
							{
							  if (is_all_x_safe(sc, caddr(value)))
							    {
							      /* this appears to give a slight savings over the SZ case */
							      pair_set_syntax_symbol(sc->code, sc->increment_sa_symbol);
							      annotate_arg(sc, cddr(value), sc->envir); /* this sets c_callee(arg) */
							      set_opt_pair2(sc->code, cddr(value));
							    }
							  else
							    {
							      if (is_optimized(caddr(value)))
								{
								  pair_set_syntax_symbol(sc->code, sc->increment_sz_symbol);
								  set_opt_pair2(sc->code, caddr(value));
								}
							    }
							}
						      else
							{
							  if ((is_null(cddddr(value))) &&
							      (is_all_x_safe(sc, caddr(value))) &&
							      (is_all_x_safe(sc, cadddr(value))))
							    {
							      pair_set_syntax_symbol(sc->code, sc->increment_saa_symbol);
							      annotate_arg(sc, cddr(value), sc->envir);
							      annotate_arg(sc, cdddr(value), sc->envir);
							      set_opt_pair2(sc->code, cddr(value));
							    }
							}
						    }
						}
					    }
					}
				    }
				}
			    }

			  if ((is_h_optimized(value)) &&
			      (!is_unsafe(value)) &&
			      (is_not_null(cdr(value))))               /* (set! x (y)) */
			    {
			      if (is_not_null(cddr(value)))
				{
				  if ((caddr(value) == small_int(1)) &&
				      (cadr(value) == settee))
				    {
				      if ((opt_cfunc(value) == add_s1) ||
					  (opt_cfunc(value) == add_cs1))
					pair_set_syntax_symbol(sc->code, sc->increment_1_symbol);
				      else
					{
					  if ((opt_cfunc(value) == subtract_s1) ||
					      (opt_cfunc(value) == subtract_cs1))
					    pair_set_syntax_symbol(sc->code, sc->decrement_1_symbol);
					}
				    }
				  else
				    {
				      if ((cadr(value) == small_int(1)) &&
					  (caddr(value) == settee) &&
					  (opt_cfunc(value) == add_1s))
					pair_set_syntax_symbol(sc->code, sc->increment_1_symbol);
				      else
					{
					  if ((settee == caddr(value)) &&
					      (is_symbol(cadr(value))) &&
					      (caadr(sc->code) == sc->cons_symbol))
					    {
					      pair_set_syntax_symbol(sc->code, sc->set_cons_symbol);
					      set_opt_sym2(sc->code, cadr(value));
					    }
					}
				    }
				}
			    }
			}
		    }
		}
	    }
	}
    }
  return(sc->code);
}

static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value)
{
  /* fprintf(stderr, "%s: %s %s\n", __func__, DISPLAY(arg), DISPLAY(value)); */
  if (is_slot(obj))
    obj = slot_value(obj);
  else eval_error(sc, "no generalized set for ~A", caar(sc->code));
  
  switch (type(obj))
    {
    case T_C_OBJECT:
      set_car(sc->t2_1, arg);
      set_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
      set_car(sc->t3_1, obj);
      set_car(sc->t3_2, arg);
      set_car(sc->t3_3, value);
      sc->value = g_vector_set(sc, sc->t3_1);
#else
      if (vector_rank(obj) > 1)
	{
	  set_car(sc->t3_1, obj);
	  set_car(sc->t3_2, arg);
	  set_car(sc->t3_3, value);
	  sc->value = g_vector_set(sc, sc->t3_1);
	}
      else
	{
	  s7_int index;

	  if (!is_integer(arg))
	    eval_type_error(sc, "vector-set!: index must be an integer: ~S", sc->code);
	  index = integer(arg);
	  if (index < 0)
	    eval_range_error(sc, "vector-set!: index must not be negative: ~S", sc->code);
	  if (index >= vector_length(obj))
	    eval_range_error(sc, "vector-set!: index must be less than vector length: ~S", sc->code);
	  vector_setter(obj)(sc, obj, index, value);
	  sc->value = _NFre(value);
	}
#endif
      break;
      
    case T_STRING:
#if WITH_GMP
      set_car(sc->t3_1, obj);
      set_car(sc->t3_2, arg);
      set_car(sc->t3_3, value);
      sc->value = g_string_set(sc, sc->t3_1);
#else
      {
	s7_int index;
	if (!is_integer(arg))
	  eval_type_error(sc, "string-set!: index must be an integer: ~S", sc->code);
	index = integer(arg);
	if (index < 0)
	  eval_range_error(sc, "string-set!: index must not be negative: ~S", sc->code);
	if (index >= string_length(obj))
	  eval_range_error(sc, "string-set!: index must be less than string length: ~S", sc->code);
	if (s7_is_character(value))
	  {
	    string_value(obj)[index] = (char)s7_character(value);
	    sc->value = _NFre(value);
	  }
	else
	  {
	    if ((is_byte_vector(obj)) &&
		(s7_is_integer(value)))
	      {
		int ic;
		ic = s7_integer(value);
		if ((ic < 0) || (ic > 255))
		  eval_type_error(sc, "string-set!: value must be a character: ~S", sc->code);
		string_value(obj)[index] = (char)ic;
		sc->value = _NFre(value);
	      }
	    else eval_type_error(sc, "string-set!: value must be a character: ~S", sc->code);
	  }
      }
#endif
      break;
      
    case T_PAIR:
      set_car(sc->t3_1, obj);
      set_car(sc->t3_2, arg);
      set_car(sc->t3_3, value);
      sc->value = g_list_set(sc, sc->t3_1);
      break;
      
    case T_HASH_TABLE:
      sc->value = s7_hash_table_set(sc, obj, arg, value);
      break;
      
    case T_LET:
      sc->value = s7_let_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:
    case T_C_FUNCTION_STAR:
      /* obj here is a c_function, but its setter could be a closure and vice versa below */
      if (is_procedure_or_macro(c_function_setter(obj)))
	{
	  if (is_c_function(c_function_setter(obj)))
	    {
	      set_car(sc->t2_1, arg);
	      set_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);
	      if (needs_copied_args(sc->code))
		sc->args = list_2(sc, arg, value);
	      else sc->args = set_plist_2(sc, arg, value);
	      return(true); /* goto APPLY; */
	    }
	}
      else eval_error(sc, "no generalized set for ~A", obj);
      break;
      
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      if (is_procedure_or_macro(closure_setter(obj)))
	{
	  if (is_c_function(closure_setter(obj)))
	    {
	      set_car(sc->t2_1, arg);
	      set_car(sc->t2_2, value);
	      sc->value = c_function_call(closure_setter(obj))(sc, sc->t2_1);
	    }
	  else
	    {
	      sc->code = closure_setter(obj);
	      if (needs_copied_args(sc->code))
		sc->args = list_2(sc, arg, value);
	      else sc->args = set_plist_2(sc, arg, value);
	      return(true); /* 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);
    }
  return(false);
}


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_op(p) & 1) != 0) &&
	  (is_safe_c_op(optimize_op(p))))
	return(true);

      if (direct_memq(car(p), vars))
	return(false);
    }
  else
    {
      if (direct_memq(p, vars))
	return(false);
    }
  return(true);
}

static int set_pair_ex(s7_scheme *sc)
{
  s7_pointer caar_code, cx;

  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;
      return(goto_EVAL);
    }
  
  if (is_symbol(caar_code))
    {
      /* this was cx = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */
      cx = find_symbol(sc, caar_code);
      if (is_slot(cx))
	cx = slot_value(cx);
      else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
    }
  else cx = 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(cx))
    {
    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.
	     *  TODO: ambiguity here -- is (set! (obj a b) v) actually (set! ((obj a) b) v)?
	     *  perhaps look at setter? c-object-set takes 1 arg -- is this a bug?
	     */
	    push_op_stack(sc, sc->object_set_function);
	    if (is_null(cdr(settee)))
	      {
		push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cddr(sc->code));
		sc->code = cadr(sc->code);
	      }
	    else
	      {
		push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
		sc->code = cadr(settee);
	      }
	    return(goto_EVAL);
	  }
	
	index = cadr(settee);
	if (!is_pair(index))
	  {
	    if (is_symbol(index))
	      index = find_symbol_checked(sc, index);
	    
	    val = cadr(sc->code);
	    if (!is_pair(val))
	      {
		if (is_symbol(val))
		  val = find_symbol_checked(sc, val);
		set_car(sc->t2_1, index);
		set_car(sc->t2_2, val);
		sc->value = (*(c_object_set(cx)))(sc, cx, sc->t2_1);
		return(goto_START);
	      }
	    push_op_stack(sc, sc->object_set_function);
	    sc->args = list_2(sc, index, cx);
	    sc->code = cdr(sc->code);
	    return(goto_EVAL_ARGS);
	  }
	else
	  {
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
	    push_op_stack(sc, sc->object_set_function);
	    sc->code = cadr(settee);
	  }
	return(goto_EVAL);
      }
      break;
      
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      {
	/* cx 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))) &&
	    (type(cx) == T_VECTOR))
	  {
	    push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
	    sc->code = list_2(sc, car(settee), cadr(settee));
	    return(goto_EVAL);
	  }

	if ((!is_null(cddr(settee))) ||
	    (vector_rank(cx) > 1))
	  {
	    /* multi-index case -- use slow version */
	    push_op_stack(sc, sc->vector_set_function);
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
	    sc->code = cadr(settee);
	    return(goto_EVAL);
	  }
	
	index = cadr(settee);
	if (!is_pair(index))
	  {
	    s7_int ind;
	    
	    if (is_symbol(index))
	      index = find_symbol_checked(sc, index);
	    if (!s7_is_integer(index))
	      eval_error_no_return(sc, sc->wrong_type_arg_symbol, "vector-set!: index must be an integer: ~S", sc->code);
	    ind = s7_integer(index);
	    if ((ind < 0) ||
		(ind >= vector_length(cx)))
	      out_of_range(sc, sc->vector_set_symbol, small_int(2), index, (ind < 0) ? its_negative_string : its_too_large_string);
	    val = cadr(sc->code);
	    if (!is_pair(val))
	      {
		if (is_symbol(val))
		  val = find_symbol_checked(sc, val);
		vector_setter(cx)(sc, cx, ind, val);
		sc->value = _NFre(val);
		return(goto_START);
	      }
	    push_op_stack(sc, sc->vector_set_function);
	    sc->args = list_2(sc, index, cx);
	    sc->code = cdr(sc->code);
	    return(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, cx), cdr(sc->code));
	    push_op_stack(sc, sc->vector_set_function);
	    sc->code = cadr(settee);
	  }
      }
      break;
      
    case T_STRING:
      {
	/* sc->code = cons(sc, sc->string_set_function, 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!
	 *    cx 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 = find_symbol_checked(sc, index);
	    if (!s7_is_integer(index))
	      eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: index must be an integer: ~S", sc->code);
	    ind = s7_integer(index);
	    if ((ind < 0) ||
		(ind >= string_length(cx)))
	      out_of_range(sc, sc->string_set_symbol, small_int(2), index, (ind < 0) ? its_negative_string : its_too_large_string);
	    
	    val = cadr(sc->code);
	    if (!is_pair(val))
	      {
		if (is_symbol(val))
		  val = find_symbol_checked(sc, val);
		if (s7_is_character(val))
		  {
		    string_value(cx)[ind] = character(val);
		    sc->value = val;
		    return(goto_START);
		  }
		else
		  {
		    if ((is_byte_vector(cx)) &&
			(s7_is_integer(val)))
		      {
			int ic;
			ic = s7_integer(val);
			if ((ic < 0) || (ic > 255))
			  eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: value must be a character: ~S", sc->code);
			string_value(cx)[ind] = (char)ic;
			sc->value = val;
			return(goto_START);
		      }
		  }
		eval_error_no_return(sc, sc->wrong_type_arg_symbol, "string-set!: value must be a character: ~S", sc->code);
	      }
	    push_op_stack(sc, sc->string_set_function);
	    sc->args = list_2(sc, index, cx);
	    sc->code = cdr(sc->code);
	    return(goto_EVAL_ARGS);
	  }
	else
	  {
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
	    push_op_stack(sc, sc->string_set_function);
	    sc->code = cadar(sc->code);
	  }
      }
      break;
      
    case T_PAIR:
      /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (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);

	if (!is_null(cddr(settee)))
	  {
	    /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return 
	     *    (let ((L (list (list 1 2)))) (set! (L 0 0) 3) L)
	     */
	    push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
	    sc->code = list_2(sc, car(settee), cadr(settee));
	    return(goto_EVAL);
	  }

	index = cadr(settee);
	val = cadr(sc->code);
	
	if ((is_pair(index)) ||
	    (is_pair(val)))
	  {
	    push_op_stack(sc, sc->list_set_function);
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
	    sc->code = index;
	    return(goto_EVAL);
	  }
	
	if (is_symbol(index))
	  index = find_symbol_checked(sc, index);
	if (is_symbol(val))
	  val = find_symbol_checked(sc, val);
	
	set_car(sc->t2_1, index);
	set_car(sc->t2_2, val);
	sc->value = g_list_set_1(sc, cx, sc->t2_1, 2);
	return(goto_START);
      }
      break;
      
      
    case T_HASH_TABLE:
      {
	s7_pointer settee, key;
	
	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)))
	  {
	    push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
	    sc->code = list_2(sc, car(settee), cadr(settee));
	    return(goto_EVAL);
	  }
	
	key = cadr(settee);
	if (!is_pair(key))
	  {
	    s7_pointer val;
	    if (is_symbol(key))
	      key = find_symbol_checked(sc, key);
	    val = cadr(sc->code);
	    if (!is_pair(val))
	      {
		if (is_symbol(val))
		  val = find_symbol_checked(sc, val);
		sc->value = s7_hash_table_set(sc, cx, key, val);
		return(goto_START);
	      }
	    push_op_stack(sc, sc->hash_table_set_function);
	    sc->args = list_2(sc, key, cx);
	    sc->code = cdr(sc->code);
	    return(goto_EVAL_ARGS);
	  }
	else
	  {
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
	    push_op_stack(sc, sc->hash_table_set_function);
	    sc->code = cadar(sc->code);
	  }
      }
      break;
      
      
    case T_LET:
      /* sc->code = cons(sc, sc->let_set_function, s7_append(sc, car(sc->code), cdr(sc->code))); */
      {
	s7_pointer settee, key;
	/* 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 let-set!: ~S", sc->code);
	if (!is_null(cddr(sc->code)))
	  s7_wrong_number_of_args_error(sc, "too many values for let-set!: ~S", sc->code);
	
	settee = car(sc->code);
	if (is_null(cdr(settee)))
	  s7_wrong_number_of_args_error(sc, "no identifier for let-set!: ~S", sc->code);
	
	if (!is_null(cddr(settee)))
	  {
	    push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
	    sc->code = list_2(sc, car(settee), cadr(settee));
	    return(goto_EVAL);
	  }

	key = cadr(settee);
	if ((is_pair(key)) &&
	    (car(key) == sc->quote_symbol))
	  {
	    s7_pointer val;
	    key = cadr(key);
	    val = cadr(sc->code);
	    if (!is_pair(val))
	      {
		if (is_symbol(val))
		  val = find_symbol_checked(sc, val);
		sc->value = s7_let_set(sc, cx, key, val);
		return(goto_START);
	      }
	    push_op_stack(sc, sc->let_set_function);
	    sc->args = list_2(sc, key, cx);
	    sc->code = cdr(sc->code);
	    return(goto_EVAL_ARGS);
	  }
	else
	  {
	    push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code));
	    push_op_stack(sc, sc->let_set_function);
	    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:
    case T_C_FUNCTION_STAR:
      /* perhaps it has a setter */
      if (is_procedure(c_function_setter(cx)))
	{
	  /* sc->code = cons(sc, c_function_setter(cx), 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)))
		    {
		      set_car(sc->t2_1, find_symbol_checked(sc, cadar(sc->code)));
		      set_car(sc->t2_2, find_symbol_checked(sc, cadr(sc->code)));
		      sc->args = sc->t2_1;
		      sc->code = c_function_setter(cx);
		      return(goto_APPLY); /* check arg num etc */
		    }
		  if ((is_symbol(caddar(sc->code))) &&
		      (is_null(cdddar(sc->code))))
		    {
		      set_car(sc->t3_1, find_symbol_checked(sc, cadar(sc->code)));
		      set_car(sc->t3_2, find_symbol_checked(sc, caddar(sc->code)));
		      set_car(sc->t3_3, find_symbol_checked(sc, cadr(sc->code)));
		      sc->args = sc->t3_1;
		      sc->code = c_function_setter(cx);
		      return(goto_APPLY); /* check arg num etc */
		    }
		}
	      
	      push_op_stack(sc, c_function_setter(cx));
	      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)))
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(sc->code)));
		  else set_car(sc->t1_1, cadr(sc->code));
		  sc->args = sc->t1_1;
		  sc->code = c_function_setter(cx);
		  return(goto_APPLY); /* check arg num etc */
		}
	      push_op_stack(sc, c_function_setter(cx));
	      push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code));
	      sc->code = cadr(sc->code);
	    }
	}
      else
	{
	  if (is_any_macro(c_function_setter(cx)))
	    {
	      if (is_null(cdar(sc->code)))
		sc->args = copy_list(sc, cdr(sc->code));
	      else sc->args = s7_append(sc, cdar(sc->code), copy_list(sc, cdr(sc->code)));
	      /* append copies except for its last arg, but for macros, we have to copy everything, hence the extra copy_list */
	      sc->code = c_function_setter(cx);
	      return(goto_APPLY);
	    }
	  else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
	}
      break;
      
    case T_MACRO:   case T_MACRO_STAR:
    case T_BACRO:   case T_BACRO_STAR:
    case T_CLOSURE: case T_CLOSURE_STAR:
      {
	s7_pointer setter;
	setter = closure_setter(cx);
	if (is_procedure(setter))          /* appears to be caar_code */
	  {
	    /* (set! (o g) ...), here cx = o, sc->code = ((o g) ...) */
	    push_op_stack(sc, setter);
	    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(setter))
	      {
		if (is_null(cdar(sc->code)))
		  sc->args = copy_list(sc, cdr(sc->code));
		else sc->args = s7_append(sc, cdar(sc->code), copy_list(sc, cdr(sc->code)));
		sc->code = setter;
		return(goto_APPLY);
	      }
	    else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
	  }
      }
      break;
      
    case T_ITERATOR:     /* not sure this makes sense */
      {
	s7_pointer setter;
	setter = iterator_sequence(cx);
	if ((is_any_closure(setter)) || (is_any_macro(setter)))
	  setter = closure_setter(iterator_sequence(cx));
	else setter = sc->F;
	if (is_procedure(setter))
	  {
	    push_op_stack(sc, setter);
	    push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil);
	    sc->code = cadr(sc->code);    /* the (as yet unevaluated) value, incoming code was ((obj) val) */
	  }
	else
	  {
	    if (is_any_macro(setter))
	      {
		sc->args = list_1(sc, cadr(sc->code));
		sc->code = setter;
		return(goto_APPLY);
	      }
	    else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
	  }
      }
      break;

    case T_SYNTAX:
      if (cx == slot_value(global_slot(sc->with_let_symbol)))
	{
	  /* (set! (with-let a b) x), cx = with-let, sc->code = ((with-let a b) x)
	   *   a and x are in the current env, b is in a, we need to evaluate a and x, then
	   *   call (with-let a-value (set! b x-value))
	   */
	  sc->args = cdar(sc->code);
	  sc->code = cadr(sc->code);
	  push_stack(sc, OP_SET_WITH_LET_1, sc->args, sc->code);
	  return(goto_EVAL);
	}
      /* else fall through */
      
    default:                                         /* (set! (1 2) 3) */
      eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", caar_code);
    }
  return(goto_EVAL);
}

static void activate_let(s7_scheme *sc)
{
  s7_pointer e;
  e = sc->value;
  if (!is_let(e))                    /* (with-let . "hi") */
    eval_error_no_return(sc, sc->wrong_type_arg_symbol, "with-let takes an environment argument: ~A", e);
  if (e == sc->rootlet)
    sc->envir = sc->nil;                             /* (with-let (rootlet) ...) */
  else
    {
      s7_pointer p;
      set_with_let_let(e);
      let_id(e) = ++sc->let_number;
      sc->envir = e;
      for (p = let_slots(e); is_slot(p); p = next_slot(p))
	{
	  s7_pointer sym;
	  sym = slot_symbol(p);
	  if (symbol_id(sym) != sc->let_number)
	    symbol_set_local(sym, sc->let_number, p);
	}
    }
}


static bool tree_match(s7_scheme *sc, s7_pointer tree)
{
  if (is_symbol(tree))
    return(is_matched_symbol(tree));
  if (is_pair(tree))
    return((tree_match(sc, car(tree))) || (tree_match(sc, cdr(tree))));
  return(false);
}


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;

  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_MACROEXPAND:
		      return(false);

		    case OP_QUOTE:
		      break;

		    case OP_LET:
		    case OP_LET_STAR:
		      if (is_symbol(cadr(expr)))
			return(false);

		    case OP_LETREC:
		    case OP_LETREC_STAR:
		    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)))
			    {
			      sc->x = sc->nil;
			      return(false);
			    }
			  sc->x = sc->nil;
			}
		      if (op == OP_DO)
			{
			  /* set_unsafe_do(cdr(expr)); */
			  if (!do_is_safe(sc, (op == OP_DO) ? cdddr(expr) : cddr(expr), steppers, var_list, has_set))
			    return(false);
			}
		      else
			{
			  if (!do_is_safe(sc, cddr(expr), steppers, var_list, has_set))
			    return(false);
			}
		      break;

		    case OP_SET:
		      {
			s7_pointer settee;
			settee = cadr(expr);
			if (!is_symbol(settee))             /* (set! (...) ...) which is tricky due to setter functions/macros */
			  {
			    s7_pointer setv;
			    if ((!is_pair(settee)) ||
				(!is_symbol(car(settee))))
			      return(false);
			    setv = find_symbol_unexamined(sc, car(settee));
			    if (!((setv) &&
				  ((is_sequence(setv)) ||
				   ((is_c_function(setv)) && 
				    (is_safe_procedure(c_function_setter(setv)))))))
			      return(false);
			    (*has_set) = true;
			  }
			else
			  {
			    if ((is_pair(cadr(sc->code))) &&
				(is_pair(caadr(sc->code))))
			      {
				bool res;
				set_match_symbol(settee);
				res = tree_match(sc, caadr(sc->code)); /* (set! end ...) in some fashion */
				clear_match_symbol(settee);
				if (res) return(false);
			      }
			    
			    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 step var's value used as the stored value by set!? */
			  return(false);
		      }
		      break;

		    case OP_IF:
		    case OP_WHEN:
		    case OP_UNLESS:
		    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_LET:
		      return(true);

		    default:
		      return(false);
		    }
		}
	      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(x)) /* "setter" includes stuff like cons and vector -- x is a symbol */
			{
			  /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe
			   *   similarly (vector-set! v 0 i) etc
			   */
			  if (!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))) ||
				  ((x == sc->hash_table_set_symbol) &&
				   (is_symbol(caddr(expr))) && 
				   (direct_memq(caddr(expr), steppers))) ||
				  ((is_symbol(cadddr(expr))) && 
				   (direct_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 preserves_type(s7_scheme *sc, unsigned int x)
{
  return((x == sc->add_class) || 
	 (x == sc->subtract_class) || 
	 (x == sc->multiply_class));
}


static s7_pointer check_do(s7_scheme *sc)
{
  s7_pointer x;
  
  /* fprintf(stderr, "check_do: %s\n", DISPLAY(sc->code)); */

  if ((!is_pair(sc->code)) ||                             /* (do . 1) */
      ((!is_pair(car(sc->code))) &&                       /* (do 123) */
       (is_not_null(car(sc->code)))))                     /* (do () ...) is ok */
    eval_error(sc, "do: var list is not a list: ~S", sc->code);

  if (!is_pair(cdr(sc->code)))                            /* (do () . 1) */
    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? */
    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)) */
	    eval_error(sc, "do: variable name missing? ~A", sc->code);

	  if (!is_symbol(caar(x)))                       /* (do ((3 2)) ()) */
	    eval_error(sc, "do step variable: ~S is not a symbol?", x);

	  if (is_immutable_symbol(caar(x)))              /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */
	    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)) ...) */
		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))) ...) */
		eval_error(sc, "do: step variable info has extra stuff after the increment: ~A", sc->code);
	    }
	  else 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))) */
	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))
	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))
    eval_error(sc, "stray dot in do body? ~A", sc->code);

  if ((is_overlaid(sc->code)) &&
      (has_opt_back(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))));
      pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);

      /* (define (hi) (do ((i 0 (+ i 1))) ((= i 3)) (display i)) (newline)) */
      /* (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))) &&
	  (is_pair(body)))
	{
	  /* loop has one step variable, and normal-looking end test
	   */
	  vars = car(vars);
	  if ((safe_list_length(sc, vars) == 3) &&
	      ((!is_pair(cadr(vars))) ||
	       (is_h_safe_c_c(cadr(vars)))))
	    {
	      s7_pointer step_expr;
	      step_expr = caddr(vars);

	      if ((is_optimized(step_expr)) &&
		  (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(vars) == cadr(step_expr))) ||
		   ((optimize_op(step_expr) == HOP_SAFE_C_C) && (car(vars) == cadr(step_expr)) &&
		    ((opt_cfunc(step_expr) == add_cs1) || (opt_cfunc(step_expr) == subtract_cs1))) ||
		   ((optimize_op(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)) &&
		      ((opt_any1(end) == equal_s_ic) ||
		       (optimize_op(end) == HOP_SAFE_C_SS) ||
		       (optimize_op(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 (opt_cfunc(step_expr) == add_cs1)
			{
			  set_c_function(step_expr, add_s1);
			  set_optimize_op(step_expr, HOP_SAFE_C_SC);
			}
		      if (opt_cfunc(step_expr) == subtract_cs1)
			{
			  set_c_function(step_expr, subtract_s1);
			  set_optimize_op(step_expr, HOP_SAFE_C_SC);
			}
		      if (opt_cfunc(end) == equal_s_ic)
			{
			  set_c_function(end, equal_2);
			  set_optimize_op(end, HOP_SAFE_C_SC);
			}

		      if ((opt_cfunc(step_expr) == add_s1) &&
			  (opt_cfunc(end) == equal_2) &&
			  (s7_is_integer(caddr(step_expr))) &&
			  (s7_integer(caddr(step_expr)) == 1))
			{
			  pair_set_syntax_symbol(sc->code, sc->simple_do_a_symbol);
			  if ((one_line) &&
			      (is_optimized(car(body))))
			    pair_set_syntax_symbol(sc->code, sc->simple_do_e_symbol);
			}
		      else pair_set_syntax_symbol(sc->code, sc->simple_do_symbol);

		      if ((one_line) &&
			  ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_C)) &&
			  (is_syntactic_symbol(caar(body))))
			{
			  pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
			  pair_set_syntax_symbol(sc->code, sc->simple_do_p_symbol);
			  set_opt_pair2(sc->code, caddr(caar(sc->code)));

			  if ((s7_is_integer(caddr(step_expr))) &&
			      (s7_integer(caddr(step_expr)) == 1) &&
			      (c_function_class(opt_cfunc(step_expr)) == sc->add_class) &&
			      /* we check above that (car(vars) == cadr(step_expr))
			       *    and that         (car(vars) == cadr(end))
			       */
			      ((c_function_class(opt_cfunc(end)) == sc->equal_class) ||
			       (opt_cfunc(end) == geq_2)))
			    pair_set_syntax_symbol(sc->code, sc->dotimes_p_symbol);
			}

		      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(opt_cfunc(step_expr)) == sc->add_class) &&
			      ((c_function_class(opt_cfunc(end)) == sc->equal_class) ||
			       (opt_cfunc(end) == geq_2))
			      )
			    {
			      /* we're stepping by +1 and going to =
			       *   the final integer check has to wait until run time (symbol value dependent)
			       */
			      pair_set_syntax_symbol(sc->code, sc->safe_do_symbol);
			      if ((!has_set) &&
				  (c_function_class(opt_cfunc(end)) == sc->equal_class))
				pair_set_syntax_symbol(sc->code, sc->safe_dotimes_symbol);
			    }
			}
		      return(sc->nil); 
		    }
		}
	    }
	}

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

      /* check end expression first */
      if ((is_pair(car(end))) &&
	  (caar(end) != sc->quote_symbol) &&
	  (is_optimized(car(end))) &&
	  (is_all_x_safe(sc, car(end))))
	set_c_call(cdr(sc->code), all_x_eval(sc, car(end), sc->envir, let_symbol_is_safe));
      else return(sc->code);

      /* vars can be nil (no steppers) */
      if (is_pair(vars))
	{
	  s7_pointer p;
	  for (p = vars; is_pair(p); p = cdr(p))
	    {
	      s7_pointer var;
	      var = car(p);

		if ((!is_all_x_safe(sc, cadr(var))) ||
		    ((is_pair(cddr(var))) &&
		     (!is_all_x_safe(sc, caddr(var)))))
		{
		  s7_pointer q;
		  for (q = vars; q != p; q = cdr(q))
		    clear_match_symbol(caar(q));
		  return(sc->code);
		}
	      set_match_symbol(car(var));
	    }
	  /* 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(!)
	   */
	  for (p = vars; is_pair(p); p = cdr(p))
	    {
	      s7_pointer var, val;
	      var = car(p);
	      val = cddr(var);
	      if (is_pair(val))
		{
		  var = car(var);
		  clear_match_symbol(var); /* ignore current var */
		  if (tree_match(sc, car(val)))
		    {
		      s7_pointer q;
		      for (q = vars; is_pair(q); q = cdr(q))
			clear_match_symbol(caar(q));
		      return(sc->code);
		    }
		  set_match_symbol(var);
		}
	    }
	  for (p = vars; is_pair(p); p = cdr(p))
	    clear_match_symbol(caar(p));
	}

      /* end and steps look ok! */
      pair_set_syntax_symbol(sc->code, sc->dox_symbol);
      set_opt_pair2(sc->code, car(end));      /* end expr */

      /* each step expr is safe so not an explicit set!
       *   the symbol_is_safe check in all_x_eval needs to see the do envir, not the caller's
       *   but that means the is_all_x_safe check above also needs to use the local env?
       */
      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(cdr(var))) 
		set_c_call(cdr(var), all_x_eval(sc, cadr(var), sc->envir, let_symbol_is_safe)); /* init val */
	      if (is_pair(cddr(var))) 
		{
		  s7_pointer step_expr;
		  step_expr = caddr(var);
		  set_c_call(cddr(var), all_x_eval(sc, step_expr, vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */
		  if ((is_pair(step_expr)) &&
		      (car(step_expr) != sc->quote_symbol) &&     /* opt_cfunc(==opt1) might not be set in this case (sigh) */
		      (preserves_type(sc, c_function_class(opt_cfunc(step_expr)))))
		    set_safe_stepper(cddr(var));
		}
	    }
	}
      /* there are only a couple of cases in snd-test where a multi-statement do body is completely all-x-able */
      return(sc->nil);
    }
  return(sc->code);
}

static bool dox_pf_ok(s7_scheme *sc, s7_pointer code, s7_pointer scc, s7_function endf, bool all_pairs)
{
  s7_pointer p, endp;
  int body_len, i;
  s7_pf_t pf;

  endp = caadr(scc);
  body_len = s7_list_length(sc, code);

  s7_xf_new(sc, sc->envir);
  for (i = 0, p = code; is_pair(p); i++, p = cdr(p))
    if ((!is_symbol(caar(p))) ||
	(!xf_opt(sc, car(p))))
      break;

  if ((is_null(p)) &&
      (pf = xf_opt(sc, endp)))
    {
      s7_pointer slots;
      s7_pointer *top;

      slots = let_slots(sc->envir);
      top = sc->cur_rf->data;
      
      if ((all_pairs) && (body_len == 1))
	{	
	  s7_rf_t rf;
	  rf = (s7_rf_t)(*top);
	  top++;
	  while (true)
	    {
	      s7_pointer slot;
	      s7_pointer *temp;
	      s7_pointer **rp;
	      
	      temp = top;
	      rp = &temp;
	      rf(sc, rp);

	      for (slot = slots; is_slot(slot); slot = next_slot(slot))
		if (is_pair(slot_expression(slot)))
		  slot_set_pending_value(slot, c_call(slot_expression(slot))(sc, car(slot_expression(slot))));
	      for (slot = slots; is_slot(slot); slot = next_slot(slot))
		if (is_pair(slot_expression(slot)))
		  slot_set_value(slot, slot_pending_value(slot));
	      
	      (*rp)++;
	      if (is_true(sc, pf(sc, rp)))
		{
		  s7_xf_free(sc);
		  sc->code = cdadr(scc);
		  return(true);
		}
	    }
	}
      else
	{
	  while (true)
	    {
	      s7_pointer slot;
	      s7_pointer *temp;
	      s7_pointer **rp;
	      
	      temp = top;
	      rp = &temp;
	      
	      for (i = 0; i < body_len; i++)
		{
		  s7_rf_t rf;
		  rf = (s7_rf_t)(**rp); (*rp)++;
		  rf(sc, rp);
		}
	      
	      for (slot = slots; is_slot(slot); slot = next_slot(slot))
		if (is_pair(slot_expression(slot)))
		  slot_set_pending_value(slot, c_call(slot_expression(slot))(sc, car(slot_expression(slot))));
	      for (slot = slots; is_slot(slot); slot = next_slot(slot))
		if (is_pair(slot_expression(slot)))
		  slot_set_value(slot, slot_pending_value(slot));

	      (*rp)++;
	      if (is_true(sc, pf(sc, rp)))
		{
		  s7_xf_free(sc);
		  sc->code = cdadr(scc);
		  return(true);
		}
	    }
	}
    }
  s7_xf_free(sc);
  return(false);
}

static int dox_ex(s7_scheme *sc)
{
  /* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
   *    since all these exprs are local, we don't need to jump until the body
   */
  long long int id;
  s7_pointer frame, vars, slot, code;
  s7_function endf;
  int gc_loc;
  bool all_pairs = true;
	    
  new_frame(sc, sc->envir, frame);   /* new frame is not tied into the symbol lookup process yet */
  gc_loc = s7_gc_protect(sc, frame); /* maybe use temp3 here?  can c_call below jump out? */
  for (vars = car(sc->code); is_pair(vars); vars = cdr(vars))
    {
      s7_pointer expr, val;
      expr = cadar(vars);
      if (is_pair(expr))
	{
	  if (car(expr) == sc->quote_symbol)
	    val = cadr(expr);
	  else val = c_call(cdar(vars))(sc, expr);
	}
      else
	{
	  if (is_symbol(expr))
	    val = find_symbol_checked(sc, expr);
	  else val = expr;
	}
      new_cell_no_check(sc, slot, T_SLOT);
      slot_set_symbol(slot, caar(vars));
      slot_set_value(slot, val);
      set_stepper(slot);
      slot_set_expression(slot, cddar(vars));

      if (is_pair(slot_expression(slot)))
	{
	  if (is_safe_stepper(slot_expression(slot)))
	    {
	      s7_pointer step_expr;
	      step_expr = car(slot_expression(slot));
	      if ((is_pair(cddr(step_expr))) &&
		  (type(val) == type(caddr(step_expr))))
		set_safe_stepper(slot);
	    }
	}
      else all_pairs = false;

      set_next_slot(slot, let_slots(frame));
      let_set_slots(frame, slot);
    }
  
  sc->envir = frame;
  s7_gc_unprotect_at(sc, gc_loc);
  id = let_id(frame);
  for (slot = let_slots(frame); is_slot(slot); slot = next_slot(slot))
    symbol_set_local(slot_symbol(slot), id, slot);
  
  if (is_true(sc, c_call(cdr(sc->code))(sc, opt_pair2(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);
      return(goto_DO_END_CLAUSES);
    }
	    
  code = cddr(sc->code);
  endf = c_callee(cdr(sc->code));

  if (is_null(code)) /* no body? */
    {
      s7_pointer endp, slots, scc;
      scc = sc->code;
      endp = opt_pair2(sc->code);

      if (endf == all_x_c_c)
	{
	  endf = c_callee(endp);
	  endp = cdr(endp);
	}

      slots = let_slots(sc->envir);

      if (!is_slot(slots))
	{
	  while (!is_true(sc, endf(sc, endp)));
	  sc->code = cdadr(scc);
	  return(goto_DO_END_CLAUSES);
	}

      if ((is_null(next_slot(slots))) && (is_pair(slot_expression(slots))))
	{
	  s7_function f;
	  s7_pointer a;

	  f = c_callee(slot_expression(slots));
	  a = car(slot_expression(slots));
	  if (f == all_x_c_c)
	    {
	      f = c_callee(a);
	      a = cdr(a);
	    }

	  while (true) /* thash titer */
	    {
	      slot_set_value(slots, f(sc, a));
	      if (is_true(sc, endf(sc, endp)))
		{
		  sc->code = cdadr(scc);
		  return(goto_DO_END_CLAUSES);
		}
	    }
	}
      else
	{
	  while (true)
	    {
	      s7_pointer slt;
	      for (slt = slots; is_slot(slt); slt = next_slot(slt))
		if (is_pair(slot_expression(slt)))
		  slot_set_value(slt, c_call(slot_expression(slt))(sc, car(slot_expression(slt))));
	      if (is_true(sc, endf(sc, endp)))
		{
		  sc->code = cdadr(scc); 
		  return(goto_DO_END_CLAUSES);
		}
	    }
	}
    }

  if ((!is_unsafe_do(sc->code)) &&
      (dox_pf_ok(sc, code, sc->code, endf, all_pairs)))
    return(goto_DO_END_CLAUSES);
      
  /* fprintf(stderr, "dox: %s\n", DISPLAY(code)); */

  set_unsafe_do(sc->code);
  if ((is_null(cdr(code))) && /* one expr */
      (is_pair(car(code))))
    {
      code = car(code);
      
      if ((typesflag(code) == SYNTACTIC_PAIR) ||
	  (typesflag(car(code)) == SYNTACTIC_TYPE))
	{
	  push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);
	  
	  if (typesflag(code) == SYNTACTIC_PAIR)
	    sc->op = (opcode_t)pair_syntax_op(code);
	  else
	    {
	      sc->op = (opcode_t)symbol_syntax_op(car(code));
	      pair_set_syntax_op(code, sc->op);
	      set_syntactic_pair(code);
	    }
	  sc->code = cdr(code);
	  return(goto_START_WITHOUT_POP_STACK);
	}
    }
  return(fall_through);
}

	  
static int simple_do_ex(s7_scheme *sc, s7_pointer code)
{
  s7_pointer body, step_expr, step_var, ctr, end;
  s7_function stepf, endf;
  s7_pf_t rf;

  /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(sc->code)); */

  body = car(opt_pair2(code));
  if (!is_symbol(car(body)))
    return(fall_through);
    
  step_expr = caddr(caar(code));
  stepf = c_callee(step_expr);
  endf = c_callee(caadr(code));
  ctr = dox_slot1(sc->envir);
  end = dox_slot2(sc->envir);
  step_var = caddr(step_expr);

#if (!WITH_GMP)
  set_stepper(ctr);
  if (((stepf == g_subtract_s1) && (endf == g_less_s0)) ||
      ((stepf == g_add_s1) && (endf == g_equal_2)))  /* add_s1 means (+ sym 1) */
    set_safe_stepper(ctr);
#endif
  s7_xf_new(sc, sc->envir);
  rf = xf_opt(sc, body);
  if (rf)
    {
      s7_pointer *top;
      /* fprintf(stderr, "ex: %s\n", DISPLAY(code)); */
      top = sc->cur_rf->data;
      top++;
#if (!WITH_GMP)	  
      if ((stepf == g_add_s1) && (endf == g_equal_2))
	{
	  while (true)
	    {
	      s7_pointer *temp;
	      temp = top;
	      rf(sc, &temp);
	      slot_set_value(ctr, c_add_s1(sc, slot_value(ctr)));
	      if (is_true(sc, c_equal_2(sc, slot_value(ctr), slot_value(end))))
		{
		  s7_xf_free(sc);
		  sc->code = cdr(cadr(code));
		  return(goto_DO_END_CLAUSES);
		}
	    }
	}
#endif
      while (true)
	{
	  s7_pointer *temp;
	  temp = top;
	  rf(sc, &temp);
	  
	  set_car(sc->t2_1, slot_value(ctr));
	  set_car(sc->t2_2, step_var);
	  slot_set_value(ctr, stepf(sc, sc->t2_1));
	  
	  set_car(sc->t2_1, slot_value(ctr));
	  set_car(sc->t2_2, slot_value(end));
	  if (is_true(sc, endf(sc, sc->t2_1)))
	    {
	      s7_xf_free(sc);
	      sc->code = cdr(cadr(code));
	      return(goto_DO_END_CLAUSES);
	    }
	}
    }
  s7_xf_free(sc);
  return(fall_through);
}

static bool pf_ok(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step)
{
  s7_pointer p;
  int body_len, i;

  if (safe_step)
    set_safe_stepper(sc->args);
  else set_safe_stepper(dox_slot1(sc->envir));
  body_len = s7_list_length(sc, code);

  s7_xf_new(sc, sc->envir);
  for (i = 0, p = code; is_pair(p); i++, p = cdr(p))
    if (!xf_opt(sc, car(p)))
      break;

  if (is_null(p))
    {
      s7_pointer stepper;
      s7_pointer *top;
      s7_int end;
      
      stepper = slot_value(sc->args);
      end = denominator(stepper);
      top = sc->cur_rf->data;
      if (safe_step)
	{
	  if (body_len == 1)
	    {
	      s7_int end4;
	      s7_rf_t rf;
	      rf = (s7_rf_t)(*top);
	      top++;
	      end4 = end - 4;
	      for (; numerator(stepper) < end4; numerator(stepper)++)
		{
		  s7_pointer *rp;
		  rp = top;
		  rf(sc, &rp);
		  numerator(stepper)++;
		  rp = top;
		  rf(sc, &rp);
		  numerator(stepper)++;
		  rp = top;
		  rf(sc, &rp);
		  numerator(stepper)++;
		  rp = top;
		  rf(sc, &rp);
		}
	      for (; numerator(stepper) < end; numerator(stepper)++)
		{
		  s7_pointer *rp;
		  rp = top;
		  rf(sc, &rp);
		}
	    }
	  else
	    {
	      for (; numerator(stepper) < end; numerator(stepper)++)
		{
		  s7_pointer *temp;
		  s7_pointer **rp;
		  
		  temp = top;
		  rp = &temp;
		  for (i = 0; i < body_len; i++)
		    {
		      s7_rf_t rf;
		      rf = (s7_rf_t)(**rp); (*rp)++;
		      rf(sc, rp);
		    }
		}
	    }
	}
      else
	{
	  /* can't re-use the stepper value directly */
	  s7_pointer step_slot, end_slot;
	  s7_int step;

	  step_slot = dox_slot1(sc->envir);
	  end_slot = dox_slot2(sc->envir);

	  if (body_len == 1)
	    {
	      s7_rf_t rf;
	      rf = (s7_rf_t)(*top);
	      top++;
	      while (true)
		{
		  s7_pointer *rp;
		  rp = top;
		  rf(sc, &rp);

		  step = s7_integer(slot_value(step_slot)) + 1;
		  slot_set_value(step_slot, make_integer(sc, step));
		  if (step == s7_integer(slot_value(end_slot))) break;
		}
	    }
	  else
	    {
	      while (true)
		{
		  s7_pointer *temp;
		  s7_pointer **rp;
		  
		  temp = top;
		  rp = &temp;
		  for (i = 0; i < body_len; i++)
		    {
		      s7_rf_t rf;
		      rf = (s7_rf_t)(**rp); (*rp)++;
		      rf(sc, rp);
		    }

		  step = s7_integer(slot_value(step_slot)) + 1;
		  slot_set_value(step_slot, make_integer(sc, step));
		  if (step == s7_integer(slot_value(end_slot))) break;
		}
	    }
	}
      s7_xf_free(sc);
      sc->code = cdadr(scc);
      return(true);
    }
  s7_xf_free(sc);
  return(false);
}
 

static int let_pf_ok(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc, bool safe_case)
{
  s7_pointer let_body, p = NULL, let_vars, let_code;
  bool let_star;
  int body_len;
  s7_rf_t varf = NULL;
  s7_pointer old_e, stepper;
  int var_len;

  /* fprintf(stderr, "%lld %lld %s %d\n", numerator(step_slot), denominator(step_slot), DISPLAY(scc), safe_case); */

  let_code = caddr(scc);
  let_body = cddr(let_code);
  body_len = s7_list_length(sc, let_body);
  let_star = (symbol_syntax_op(car(let_code)) == OP_LET_STAR);
  let_vars = cadr(let_code);
  set_safe_stepper(step_slot);
  stepper = slot_value(step_slot);

  old_e = sc->envir;
  sc->envir = new_frame_in_env(sc, sc->envir);
  
  s7_xf_new(sc, old_e);
  for (var_len = 0, p = let_vars; (is_pair(p)) && (is_pair(cadar(p))); var_len++, p = cdr(p))
    {
      s7_int var_loc;
      s7_pointer expr, fcar, car_ex;
      s7_rp_t varp;

      var_loc = s7_xf_store(sc, NULL);
      expr = cadar(p);
      car_ex = car(expr);
      /* fcar = find_symbol_checked(sc, car(expr)); */

      if (!is_symbol(car_ex)) break;
      fcar = find_symbol(sc, car_ex);
      if (!is_slot(fcar)) break;
      fcar = slot_value(fcar);

      varp = rf_function(fcar);
      if (!varp) break;
      varf = varp(sc, expr);
      if (!varf) break;
      s7_xf_store_at(sc, var_loc, (s7_pointer)varf);
      if (let_star)
	make_slot_1(sc, sc->envir, caar(p), s7_make_mutable_real(sc, 1.5));
    }
  
  if (is_null(p))
    {
      int i;
      s7_pf_t bodyf = NULL;
      if (!let_star)
	for (p = let_vars; is_pair(p); p = cdr(p))
	  make_slot_1(sc, sc->envir, caar(p), s7_make_mutable_real(sc, 1.5));
      
      for (i = 0, p = let_body; is_pair(p); i++, p = cdr(p))
	{
	  bodyf = xf_opt(sc, car(p));
	  if (!bodyf) break;
	}
      
      if (is_null(p))
	{
	  s7_pointer *top;
	  s7_int end;
	  
	  if (safe_case)
	    {
	      end = denominator(stepper);
	      top = sc->cur_rf->data;
	      
	      if ((var_len == 1) && (body_len == 1)) /* very common special case */
		{
		  s7_pointer rl;
		  s7_int end3;
		  s7_pointer **rp;
		  s7_pointer *temp;

		  end3 = end - 3;
		  rl = slot_value(let_slots(sc->envir));
		  top++;
		  for (; numerator(stepper) < end3; numerator(stepper)++)
		    {
		      temp = top;
		      rp = &temp;
		      set_real(rl, varf(sc, rp)); 
		      (*rp)++;
		      bodyf(sc, rp);
		      numerator(stepper)++;
		      temp = top;
		      rp = &temp;
		      set_real(rl, varf(sc, rp)); 
		      (*rp)++;
		      bodyf(sc, rp);
		      numerator(stepper)++;
		      temp = top;
		      rp = &temp;
		      set_real(rl, varf(sc, rp)); 
		      (*rp)++;
		      bodyf(sc, rp);
		    }
		  for (; numerator(stepper) < end; numerator(stepper)++)
		    {
		      temp = top;
		      rp = &temp;
		      set_real(rl, varf(sc, rp)); 
		      (*rp)++;
		      bodyf(sc, rp);
		    }
		}
	      else
		{
		  let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir)));
		  for (; numerator(stepper) < end; numerator(stepper)++)
		    {
		      s7_pointer **rp;
		      s7_pointer *temp;
		      
		      temp = top;
		      rp = &temp;
		      
		      for (p = let_slots(sc->envir); is_slot(p); p = next_slot(p))
			{
			  s7_rf_t r1;
			  r1 = (s7_rf_t)(**rp); (*rp)++;
			  set_real(slot_value(p), r1(sc, rp)); 
			}
		      for (i = 0; i < body_len; i++)
			{
			  s7_pf_t pf;
			  pf = (s7_pf_t)(**rp); (*rp)++;
			  pf(sc, rp);
			}
		    }
		}
	    }
	  else
	    {
	      end = denominator(stepper);
	      top = sc->cur_rf->data;
	      
	      if ((var_len == 1) && (body_len == 1)) /* very common special case */
		{
		  s7_pointer rl;
		  s7_int k;
		  rl = slot_value(let_slots(sc->envir));
		  top++;
		  for (k = numerator(stepper); k < end; k++)
		    {
		      s7_pointer **rp;
		      s7_pointer *temp;
		      slot_set_value(step_slot, make_integer(sc, k));
		      
		      temp = top;
		      rp = &temp;
		      set_real(rl, varf(sc, rp)); 
		      (*rp)++;
		      bodyf(sc, rp);
		    }
		}
	      else
		{
		  s7_int k;
		  let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir)));
		  for (k = numerator(stepper); k < end; k++)
		    {
		      s7_pointer **rp;
		      s7_pointer *temp;
		      slot_set_value(step_slot, make_integer(sc, k));
		      
		      temp = top;
		      rp = &temp;
		      
		      for (p = let_slots(sc->envir); is_slot(p); p = next_slot(p))
			{
			  s7_rf_t r1;
			  r1 = (s7_rf_t)(**rp); (*rp)++;
			  set_real(slot_value(p), r1(sc, rp)); 
			}
		      for (i = 0; i < body_len; i++)
			{
			  s7_pf_t pf;
			  pf = (s7_pf_t)(**rp); (*rp)++;
			  pf(sc, rp);
			}
		    }
		}
	    }
	  s7_xf_free(sc);
	  sc->code = cdr(cadr(scc));
	  return(goto_SAFE_DO_END_CLAUSES);
	}
    }
  sc->envir = old_e;
  s7_xf_free(sc);
  return(fall_through);
}


static int safe_dotimes_ex(s7_scheme *sc)
{
  s7_pointer init_val;

  /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(sc->code)); */

  init_val = cadr(caar(sc->code));
  if (is_symbol(init_val))
    init_val = find_symbol_checked(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 = find_symbol_checked(sc, end_val);
      
      if (s7_is_integer(end_val))
	{
	  sc->code = cddr(code);
	  sc->envir = new_frame_in_env(sc, sc->envir);
	  sc->args = make_slot_1(sc, sc->envir, caaar(code), make_mutable_integer(sc, s7_integer(init_val)));
	  
	  denominator(slot_value(sc->args)) = s7_integer(end_val);
	  set_stepper(sc->args);

	  /* (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));
	      return(goto_SAFE_DO_END_CLAUSES);
	    }
	  
	  if (s7_integer(init_val) == s7_integer(end_val))
	    {
	      sc->code = cdr(cadr(code));
	      return(goto_SAFE_DO_END_CLAUSES);
	    }
	  
	  if ((is_null(cdr(sc->code))) && 
	      (is_pair(car(sc->code))))
	    {
	      sc->code = car(sc->code);
	      set_opt_pair2(code, sc->code); /* is_pair above */
	      
	      if ((typesflag(sc->code) == SYNTACTIC_PAIR) ||
		  (typesflag(car(sc->code)) == SYNTACTIC_TYPE))
		{
		  if (!is_unsafe_do(code))
		    {
		      if ((symbol_syntax_op(car(sc->code)) == OP_LET) ||
			  (symbol_syntax_op(car(sc->code)) == OP_LET_STAR))
			{
			  if (let_pf_ok(sc, sc->args, code, true) == goto_SAFE_DO_END_CLAUSES)
			    return(goto_SAFE_DO_END_CLAUSES);
			}
		      else
			{
			  if (pf_ok(sc, cddr(code), code, true))
			    return(goto_SAFE_DO_END_CLAUSES);
			}
		      set_unsafe_do(code);
		    }

		  push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code);
		  if (typesflag(sc->code) == SYNTACTIC_PAIR)
		    sc->op = (opcode_t)pair_syntax_op(sc->code);
		  else
		    {
		      sc->op = (opcode_t)symbol_syntax_op(car(sc->code));
		      pair_set_syntax_op(sc->code, sc->op);
		      set_syntactic_pair(sc->code);
		    }
		  sc->code = cdr(sc->code);
		  return(goto_START_WITHOUT_POP_STACK);
		}
	      else /* car not syntactic? */
		{
		  if ((!is_unsafe_do(code)) &&
		      (pf_ok(sc, cddr(code), code, true)))
		    return(goto_SAFE_DO_END_CLAUSES);
		  set_unsafe_do(code);

#if DEBUGGING
		  if (!is_optimized(sc->code)) fprintf(stderr, "%s[%d]: not opt: %s\n", __func__, __LINE__, DISPLAY(sc->code));
#endif
		  if (is_optimized(sc->code)) /* think this is not needed -- can we get here otherwise? */
		    {
		      push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code);
		      return(goto_OPT_EVAL);
		    }
		}
	      /* impossible? but make sure in any case we're set up for begin */
	      sc->code = cddr(code);			
	    }

	  /* multi-line body */
	  if ((!is_unsafe_do(code)) &&
	      (pf_ok(sc, sc->code, code, true)))
	    return(goto_SAFE_DO_END_CLAUSES);
	  set_unsafe_do(code);

	  set_opt_pair2(code, sc->code);
	  push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code);
	  return(goto_BEGIN1);
	}
    }
  return(fall_through);
}

static int safe_do_ex(s7_scheme *sc)
{
  /* 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)
   * but end might not be an integer -- need to catch this earlier.
   */
  s7_pointer end, init_val, end_val, code;

  /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(sc->code)); */

  code = sc->code;

  init_val = cadaar(code);
  if (is_symbol(init_val))
    init_val = find_symbol_checked(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 = find_symbol_checked(sc, end);
  else end_val = end;

  if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val)))
    {
      pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);
      return(goto_DO_UNCHECKED);
    }

  /* (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);
  dox_set_slot1(sc->envir, make_slot_1(sc, sc->envir, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */

  if ((s7_integer(init_val) == s7_integer(end_val)) ||
      ((s7_integer(init_val) > s7_integer(end_val)) &&
       (opt_cfunc(car(cadr(code))) == geq_2)))
    {
      sc->code = cdr(cadr(code));
      return(goto_SAFE_DO_END_CLAUSES);
    }

  if (is_symbol(end))
    sc->args = find_symbol(sc, end);
  else sc->args = make_slot(sc, sc->dox_slot_symbol, end); /* here and elsewhere sc->args is used for GC protection */
  dox_set_slot2(sc->envir, sc->args);
  
  if ((!is_unsafe_do(sc->code)) &&
      ((!is_optimized(caadr(code))) ||
       (opt_cfunc(caadr(code)) != geq_2)))
    {
      set_stepper(dox_slot1(sc->envir));

      if (pf_ok(sc, cddr(sc->code), sc->code, false))
	return(goto_SAFE_DO_END_CLAUSES);
      set_unsafe_do(sc->code);
    }

  sc->code = cddr(code);
  if (is_unsafe_do(sc->code))              /* we've seen this loop before and it's not optimizable */
    {
      set_opt_pair2(code, sc->code);
      push_stack(sc, OP_SAFE_DO_STEP, sc->args, code);
      return(goto_BEGIN1);
    }
  
  set_unsafe_do(sc->code);
  set_opt_pair2(code, sc->code);
  push_stack(sc, OP_SAFE_DO_STEP, sc->args, code);
  return(goto_BEGIN1);
}

static int dotimes_p_ex(s7_scheme *sc)
{
  s7_pointer init, end, code, init_val, end_val;
  /* (do ... (set! args ...)) -- one line, syntactic */

  /* if (!is_unsafe_do(sc->code)) fprintf(stderr, "%s: %s\n", __func__, DISPLAY(sc->code)); */

  code = sc->code;
  init = cadaar(code);
  if (is_symbol(init))
    init_val = find_symbol_checked(sc, init);
  else
    {
      if (is_pair(init))
	init_val = c_call(init)(sc, cdr(init));
      else init_val = init;
    }
  sc->value = init_val;

  set_opt_pair2(code, caadr(code));
  end = caddr(opt_pair2(code));
  if (is_symbol(end))
    sc->args = find_symbol(sc, end);
  else sc->args = make_slot(sc, sc->dox_slot_symbol, end);
  end_val = slot_value(sc->args);

  if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val)))
    {
      pair_set_syntax_symbol(sc->code, sc->do_unchecked_symbol);
      return(goto_DO_UNCHECKED);
    }

  sc->envir = new_frame_in_env(sc, sc->envir);
  dox_set_slot1(sc->envir, make_slot_1(sc, sc->envir, caaar(code), init_val));
  dox_set_slot2(sc->envir, sc->args);
  
  set_car(sc->t2_1, slot_value(dox_slot1(sc->envir)));
  set_car(sc->t2_2, slot_value(dox_slot2(sc->envir)));
  if (is_true(sc, c_call(caadr(code))(sc, sc->t2_1)))
    {
      sc->code = cdadr(code);
      return(goto_DO_END_CLAUSES);
    }

  if ((!is_unsafe_do(code)) &&
      (opt_cfunc(caadr(code)) != geq_2))
    {
      s7_pointer old_args, old_init, body;
      body = caddr(code);

      old_args = sc->args;
      old_init = slot_value(dox_slot1(sc->envir));
      sc->args = dox_slot1(sc->envir);
      slot_set_value(sc->args, make_mutable_integer(sc, integer(slot_value(dox_slot1(sc->envir)))));
      denominator(slot_value(sc->args)) = integer(slot_value(dox_slot2(sc->envir)));
      set_stepper(sc->args);
      
      if (((typesflag(body) == SYNTACTIC_PAIR) ||
	   (typesflag(car(body)) == SYNTACTIC_TYPE)) &&
	  ((symbol_syntax_op(car(body)) == OP_LET) ||
	   (symbol_syntax_op(car(body)) == OP_LET_STAR)))
	{
	  if (let_pf_ok(sc, sc->args, code, false) == goto_SAFE_DO_END_CLAUSES)
	    return(goto_DO_END_CLAUSES);
	}
      else
	{
	  if (pf_ok(sc, cddr(code), code, false))
	    return(goto_DO_END_CLAUSES);
	}
      slot_set_value(sc->args, old_init);
      sc->args = old_args;
      set_unsafe_do(code);
    }

  push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
  sc->code = caddr(code);
  return(goto_EVAL);
}
	  
static int do_init_ex(s7_scheme *sc)
{
  s7_pointer x, y, z;
  while (true)
    {
      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. */
	  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;
	      return(goto_EVAL);
	    }
	  if (is_symbol(init))
	    sc->value = find_symbol_checked(sc, init);
	  else sc->value = init;
	  sc->code = cdr(sc->code);
	}
      else break;
    }
  
  /* all the initial values are now in the args list */
  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);
      
      set_type(y, T_SLOT);
      slot_set_symbol(y, sym);
      slot_set_value(y, val);
      set_next_slot(y, let_slots(sc->envir));
      let_set_slots(sc->envir, y);
      symbol_set_local(sym, let_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_opt_slot1(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, sc->value = 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))
   */
  return(fall_through);
}
  
  
#if (!WITH_GCC)
#define closure_is_ok(Sc, Code, Type, Args)          (find_symbol_unchecked(Sc, car(Code)) == opt_lambda_unchecked(Code))
#define closure_star_is_ok(Sc, Code, Type, Args)     (find_symbol_unchecked(Sc, car(Code)) == opt_lambda_unchecked(Code))
#else

/* 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 (opt_lambda(code))
 *
 * (_val_) is needed below because car(code) might be undefined (with-let can cause this confusion),
 *   and find_symbol_unchecked returns NULL in that case.
 */
#if 1
/* unlike the c_function_is_ok case, the macro form here is faster?? callgrind and time agree on this.
 *   opt_lambda(_code_) here can (legitimately) be a free cell or almost anything.
 */
#define closure_is_ok(Sc, Code, Type, Args) \
  ({ s7_pointer _code_, _val_; _code_ = Code; _val_ = find_symbol_unexamined(Sc, car(_code_)); \
     ((_val_ == opt_any1(_code_)) || \
      ((_val_) && (typesflag(_val_) == (unsigned short)Type) &&		\
       ((closure_arity(_val_) == Args) || (closure_arity_to_int(Sc, _val_) == Args)) && \
       (set_opt_lambda(_code_, _val_)))); })
#else
static bool closure_is_ok(s7_scheme *sc, s7_pointer code, unsigned short type, int args)
{
  s7_pointer f;
  f = find_symbol_unexamined(sc, car(code));
  return ((f == opt_lambda_unchecked(code)) ||
	  ((f) &&
	   (typesflag(f) == type) &&
	   ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) &&
	   (set_opt_lambda(code, f))));
}
#endif

#define closure_star_is_ok(Sc, Code, Type, Args) \
  ({ s7_pointer _val_; _val_ = find_symbol_unexamined(Sc, car(Code)); \
     ((_val_ == opt_any1(Code)) || \
      ((_val_) && (typesflag(_val_) == (unsigned short)Type) &&		\
       ((closure_arity(_val_) >= Args) || (closure_star_arity_to_int(Sc, _val_) >= Args)) && \
       (set_opt_lambda(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 */


/* unknown ops */

static int fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, int op)
{
  /* sc arg used if debugging */
  set_optimize_op(code, op);
  set_opt_lambda(code, func); /* opt_lambda works here because it is the only checked case, but ideally we'd split out all the cases via switch (op) */
  return(goto_OPT_EVAL);
}

static int unknown_ex(s7_scheme *sc, s7_pointer f)
{
  s7_pointer code;
  
  code = sc->code;
  switch (type(f))
    {
    case T_C_OBJECT:
      if (s7_is_aritable(sc, f, 0))
	return(fixup_unknown_op(sc, code, f, OP_C_OBJECT));
      break;
      
    case T_GOTO:
      return(fixup_unknown_op(sc, code, f, OP_GOTO));
      
    case T_CLOSURE:
      if ((!has_methods(f)) &&
	  (is_null(closure_args(f))))
	{
	  int hop;
	  hop = (is_immutable_symbol(car(code))) ? 1 : 0;
	  if (is_safe_closure(f))
	    {
	      s7_pointer body;
	      body = closure_body(f);
	      set_optimize_op(code, hop + OP_SAFE_THUNK);
	      if (is_null(cdr(body)))
		{
		  if (is_optimized(car(body)))
		    set_optimize_op(code, hop + OP_SAFE_THUNK_E);
		  else
		    {
		      if ((is_pair(car(body))) &&
			  (is_syntactic_symbol(caar(body))))
			{
			  set_optimize_op(code, hop + OP_SAFE_THUNK_P);
			  if (typesflag(car(body)) != SYNTACTIC_PAIR)
			    {
			      pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
			      set_syntactic_pair(car(body));
			    }
			}
		    }
		}
	      set_opt_lambda(code, f);
	      return(goto_OPT_EVAL);
	    }
	  return(fixup_unknown_op(sc, code, f, hop + OP_THUNK));
	}
      /* we can't ignore the recheck here (i.e. set the hop bit) because the closure, even if a global can be set later:
       *   (begin (define *x* #f) (define (test) (display (*x*))) (define (setx n) (set! *x* (lambda () n))) (setx 1) (test) (setx 2) (test))
       * this is a case where the name matters (we need a pristine global), so it's easily missed.
       */
      break;
      
    case T_CLOSURE_STAR:
      if ((!has_methods(f)) &&
	  (has_simple_args(closure_body(f))))
	return(fixup_unknown_op(sc, code, f, ((is_immutable_symbol(car(code))) ? 1 : 0) + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR : OP_CLOSURE_STAR)));
      break;
      
    default:
      break;
    }
  return(fall_through);
}

static int unknown_g_ex(s7_scheme *sc, s7_pointer f)
{
  s7_pointer code;
  bool sym_case;
  int hop;

  code = sc->code;
  hop = (is_immutable_symbol(car(code))) ? 1 : 0;
  sym_case = is_symbol(cadr(code));
  
  switch (type(f))
    {
    case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
      if (s7_is_aritable(sc, f, 1))
	{
	  if (sym_case)
	    {
	      set_optimize_op(code, hop + ((is_safe_procedure(f)) ? OP_SAFE_C_S : OP_C_S));
	      set_c_function(code, f);
	      return(goto_OPT_EVAL);
	    }
	  else
	    {
	      if (is_safe_procedure(f))
		{
		  set_optimize_op(code, hop + OP_SAFE_C_C);
		  set_c_function(code, f);
		  return(goto_OPT_EVAL);
		}
	    }
	}
      break;
      
    case T_CLOSURE:
      if ((!has_methods(f)) &&
	  (closure_arity_to_int(sc, f) == 1))
	{
	  if (sym_case)
	    {
	      set_opt_sym2(code, cadr(code));
	      if (is_safe_closure(f))
		{
		  s7_pointer body;
		  set_optimize_op(code, hop + ((is_global(car(code))) ? OP_SAFE_GLOSURE_S : OP_SAFE_CLOSURE_S));
		  body = closure_body(f);
		  if (is_null(cdr(body)))
		    {
		      if ((is_optimized(car(body))) &&
			  (is_global(car(code))))
			set_optimize_op(code, hop + OP_SAFE_GLOSURE_S_E);
		      else
			{
			  if ((is_pair(car(body))) &&
			      (is_syntactic_symbol(caar(body))))
			    {
			      set_optimize_op(code, hop + OP_SAFE_CLOSURE_S_P);
			      if (typesflag(car(body)) != SYNTACTIC_PAIR)
				{
				  pair_set_syntax_op(car(body), symbol_syntax_op(caar(body)));
				  set_syntactic_pair(car(body));
				}
			    }
			}
		    }
		}
	      else set_optimize_op(code, hop + ((is_global(car(code))) ? OP_GLOSURE_S : OP_CLOSURE_S));
	    }
	  else 
	    {
	      set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_C : OP_CLOSURE_C));
	      set_opt_con2(code, cadr(code));
	    }
	  set_opt_lambda(code, f);
	  return(goto_OPT_EVAL);
	}
      break;
      
    case T_CLOSURE_STAR:
      if ((sym_case) &&
	  (!has_methods(f)) &&
	  (has_simple_args(closure_body(f))) &&
	  (!is_null(closure_args(f))))
	{
	  set_opt_sym2(code, cadr(code));
	  return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_S : OP_CLOSURE_STAR_S)));
	}
      break;
      
    case T_INT_VECTOR:
    case T_FLOAT_VECTOR:
    case T_VECTOR:
      if ((sym_case) ||
	  (is_integer(cadr(code))))      /* (v 4/3) */
	return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_VECTOR_S : OP_VECTOR_C));
      break;
      
    case T_STRING:
      return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_STRING_S : OP_STRING_C));
      
    case T_PAIR:
      return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_PAIR_S : OP_PAIR_C));
      
    case T_C_OBJECT:
      if (s7_is_aritable(sc, f, 1))
	return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_C_OBJECT_S : OP_C_OBJECT_C));
      break;
      
    case T_LET:
      return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_ENVIRONMENT_S : OP_ENVIRONMENT_C));
      
    case T_HASH_TABLE:
      return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_HASH_TABLE_S : OP_HASH_TABLE_C));
      
    case T_GOTO:
      return(fixup_unknown_op(sc, code, f, (sym_case) ? OP_GOTO_S : OP_GOTO_C));
      
    default:
      break;
    }
  return(fall_through);
}
		  
static int unknown_gg_ex(s7_scheme *sc, s7_pointer f)
{
  if (s7_is_aritable(sc, f, 2))
    {
      bool s1, s2;
      int hop;
      s7_pointer code;
  
      code = sc->code;
      hop = (is_immutable_symbol(car(code))) ? 1 : 0;
      s1 = is_symbol(cadr(code));
      s2 = is_symbol(caddr(code));
  
      switch (type(f))
	{
	case T_CLOSURE:
	  if (has_methods(f)) break;
	  if (closure_arity_to_int(sc, f) == 2)
	    {
	      if (s1)
		{
		  if (is_safe_closure(f))
		    set_optimize_op(code, hop + ((s2) ? OP_SAFE_CLOSURE_SS : OP_SAFE_CLOSURE_SC));
		  else set_optimize_op(code, hop + ((s2) ? OP_CLOSURE_SS : OP_CLOSURE_SC));
		}
	      else
		{
		  if (!s2) break;
		  set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_CS : OP_CLOSURE_CS));
		}
	      if (s2) set_opt_sym2(code, caddr(code)); else set_opt_con2(code, caddr(code));
	      set_opt_lambda(code, f);
	      return(goto_OPT_EVAL);
	    }
	  break;
	  
	case T_CLOSURE_STAR:  /* the closure* opts assume args are not keywords, but we can check that! */
	  if ((s1) &&
	      (!has_methods(f)))
	    {
	      if (s2)
		{
		  if ((!is_keyword(cadr(code))) &&
		      (!is_keyword(caddr(code))) &&
		      (has_simple_args(closure_body(f))) &&
		      (closure_star_arity_to_int(sc, f) >= 2))
		    {
		      set_opt_sym2(code, caddr(code));
		      return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_SS : OP_CLOSURE_STAR_SX)));
		    }
		}
	      else
		{
		  set_opt_con2(code, caddr(code));
		  if ((!is_keyword(cadr(code))) &&
		      (has_simple_args(closure_body(f))) &&
		      (closure_star_arity_to_int(sc, f) >= 2))
		    return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_SC : OP_CLOSURE_STAR_SX)));
		}
	    }
	  break;
	  
	case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
	  if (is_safe_procedure(f))
	    {
	      if (s1) 
		set_optimize_op(code, hop + ((s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC));
	      else set_optimize_op(code, hop + ((s2) ? OP_SAFE_C_CS : OP_SAFE_C_C));
	    }
	  else
	    {
	      set_optimize_op(code, hop + OP_C_ALL_X);
	      annotate_args(sc, cdr(code), sc->envir);
	    }
	  set_arglist_length(code, small_int(2));
	  set_c_function(code, f);
	  return(goto_OPT_EVAL);
	  
	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:
	  if ((is_integer(cadr(code))) &&       /* !s1 obviously) */
	      (s7_integer(cadr(code)) >= 0) &&
	      (is_integer(caddr(code))) &&
	      (s7_integer(caddr(code)) >= 0))
	    return(fixup_unknown_op(sc, code, f, OP_VECTOR_CC));
	  break;
	  
	default:
	  break;
	}
    }
  return(fall_through);
}

static int unknown_all_s_ex(s7_scheme *sc, s7_pointer f)
{
  s7_pointer code;
  int num_args;

  code = sc->code;
  num_args = integer(arglist_length(code));

  if (s7_is_aritable(sc, f, num_args))
    {
      int hop;
      hop = (is_immutable_symbol(car(code))) ? 1 : 0;

      switch (type(f))
	{
	case T_CLOSURE:
	  if ((!has_methods(f)) &&
	      (closure_arity_to_int(sc, f) == num_args))
	    {
	      annotate_args(sc, cdr(code), sc->envir);
	      return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_ALL_X : OP_CLOSURE_ALL_S)));
	    }
	  break;
	  
	case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
	  if (is_safe_procedure(f))
	    set_optimize_op(code, hop + OP_SAFE_C_ALL_S);
	  else
	    {
	      set_optimize_op(code, hop + OP_C_ALL_X);
	      annotate_args(sc, cdr(code), sc->envir);
	    }
	  set_c_function(code, f);
	  return(goto_OPT_EVAL);
	  
	default:
	  break;
	}
    }
  return(fall_through);
}

static int unknown_a_ex(s7_scheme *sc, s7_pointer f)
{
  if (s7_is_aritable(sc, f, 1))
    {
      s7_pointer code;

      code = sc->code;
      set_arglist_length(code, small_int(1));
      annotate_args(sc, cdr(code), sc->envir);
      
      switch (type(f))
	{
	case T_INT_VECTOR:
	case T_FLOAT_VECTOR:
	case T_VECTOR:
	  return(fixup_unknown_op(sc, code, f, OP_VECTOR_A));
	  
	case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
	  if ((is_safe_procedure(f)) &&
	      (is_optimized(cadr(code))))
	    {
	      int op;
	      op = combine_ops(sc, E_C_P, code, cadr(code));
	      set_optimize_op(code, op);
	      if ((op == OP_SAFE_C_Z) &&
		  (is_all_x_op(optimize_op(cadr(code)))))
		set_optimize_op(code, OP_SAFE_C_A);
	      set_c_function(code, f);
	      return(goto_OPT_EVAL);
	    }

	  if ((is_pair(cadr(code))) && 
	      (caadr(code) == sc->quote_symbol))
	    set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_Q : OP_C_A);
	  else set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_A : OP_C_A);
	  set_c_function(code, f);
	  return(goto_OPT_EVAL);
	  
	case T_CLOSURE:
	  if ((!has_methods(f)) &&
	      (closure_arity_to_int(sc, f) == 1))
	    {
	      if ((is_pair(cadr(code))) && 
		  (caadr(code) == sc->quote_symbol))
		return(fixup_unknown_op(sc, code, f, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_Q : OP_CLOSURE_Q));

	      if (is_safe_closure(f))
		set_optimize_op(code, (is_global(car(code))) ? OP_SAFE_GLOSURE_A : OP_SAFE_CLOSURE_A);
	      else set_optimize_op(code, (is_global(car(code))) ? OP_GLOSURE_A : OP_CLOSURE_A);
	      set_opt_lambda(code, f);
	      return(goto_OPT_EVAL);
	    }
	  break;
	  
	case T_CLOSURE_STAR:
	  if ((!has_methods(f)) &&
	      (has_simple_args(closure_body(f))) &&
	      (closure_star_arity_to_int(sc, f) >= 1) &&
	      (!arglist_has_keyword(cdr(code))))
	    return(fixup_unknown_op(sc, code, f, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	  break;
	  
	case T_STRING:
	  return(fixup_unknown_op(sc, code, f, OP_STRING_A));
	  
	case T_PAIR:
	  return(fixup_unknown_op(sc, code, f, OP_PAIR_A));
	  
	case T_C_OBJECT:
	  return(fixup_unknown_op(sc, code, f, OP_C_OBJECT_A));
	  
	case T_LET:
	  return(fixup_unknown_op(sc, code, f, ((is_pair(cadr(code))) && (caadr(code) == sc->quote_symbol)) ? OP_ENVIRONMENT_Q : OP_ENVIRONMENT_A));
	  
	case T_HASH_TABLE:
	  return(fixup_unknown_op(sc, code, f, OP_HASH_TABLE_A));
	  
	case T_GOTO:
	  return(fixup_unknown_op(sc, code, f, OP_GOTO_A));
	  
	default:
	  break;
	}
    }
  return(fall_through);
}

static int unknown_aa_ex(s7_scheme *sc, s7_pointer f)
{
  if (s7_is_aritable(sc, f, 2))
    {
      s7_pointer code;
      
      code = sc->code;
      set_arglist_length(code, small_int(2));
      annotate_args(sc, cdr(code), sc->envir);
      
      switch (type(f))
	{
	case T_CLOSURE:
	  if ((!has_methods(f)) &&
	      (closure_arity_to_int(sc, f) == 2))
	    {
	      set_optimize_op(code, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA);
	      set_opt_lambda(code, f);
	      return(goto_OPT_EVAL);
	    }
	  break;
	  
	case T_CLOSURE_STAR:
	  if ((!has_methods(f)) &&
	      (has_simple_args(closure_body(f))) &&
	      (closure_star_arity_to_int(sc, f) >= 2) &&
	      (!arglist_has_keyword(cdr(code))))
	    return(fixup_unknown_op(sc, code, f, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	  break;
	  
	case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
	  set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_AA : OP_C_ALL_X);
	  set_c_function(code, f);
	  return(goto_OPT_EVAL);
	  
	default:
	  break;
	}
    }
  return(fall_through);
}

static int unknown_all_x_ex(s7_scheme *sc, s7_pointer f)
{
  s7_pointer code;
  int num_args;

  code = sc->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)) &&
	      (closure_arity_to_int(sc, f) == num_args))
	    {
	      annotate_args(sc, cdr(code), sc->envir);
	      if (is_safe_closure(f))
		{
		  if ((is_symbol(cadr(code))) &&
		      (num_args == 3))
		    set_optimize_op(code, OP_SAFE_CLOSURE_SAA);
		  else set_optimize_op(code, OP_SAFE_CLOSURE_ALL_X);
		}
	      else set_optimize_op(code, OP_CLOSURE_ALL_X);
	      set_opt_lambda(code, f);
	      return(goto_OPT_EVAL);
	    }
	  break;
	  
	case T_CLOSURE_STAR:
	  if ((!has_methods(f)) &&
	      (has_simple_args(closure_body(f))) &&
	      (closure_star_arity_to_int(sc, f) >= num_args) &&
	      (!arglist_has_keyword(cdr(code))))
	    {
	      annotate_args(sc, cdr(code), sc->envir);
	      return(fixup_unknown_op(sc, code, f, (is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_ALL_X : OP_CLOSURE_STAR_ALL_X));
	    }
	  break;
	  
	case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_ANY_ARGS_FUNCTION: case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION:
	  set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_ALL_X : OP_C_ALL_X);
	  annotate_args(sc, cdr(code), sc->envir);
	  set_c_function(code, f);
	  return(goto_OPT_EVAL);
	  
	default:
	  break;
	}
    }
  return(fall_through);
}


static void unwind_output_ex(s7_scheme *sc)
{
  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) &&
      (is_multiple_value(sc->value)))
    sc->value = splice_in_values(sc, multiple_value(sc->value));
}

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

static int dynamic_wind_ex(s7_scheme *sc)
{
  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->code = dynamic_wind_body(sc->code);
      sc->args = sc->nil;
      return(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->code = dynamic_wind_out(sc->code);
	      sc->args = sc->nil;
	      return(goto_APPLY);
	    }
	  else
	    {
	      if (is_multiple_value(sc->value))
		sc->value = splice_in_values(sc, multiple_value(sc->value));
	      return(goto_START);
	    }
	}
      if (is_multiple_value(sc->args))       /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */
	sc->value = splice_in_values(sc, multiple_value(sc->args));
      else sc->value = sc->args;             /* value saved above */
    }
  return(goto_START);
}

static int read_s_ex(s7_scheme *sc)
{
  /* another lint opt */
  s7_pointer port, code;

  code = sc->code;
  port = find_symbol_checked(sc, cadr(code));
  
  if (!is_input_port(port)) /* was also not stdin */
    {
      sc->value = g_read(sc, list_1(sc, port));
      return(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_symbol, port, an_open_port_string);
  
  if (is_function_port(port))
    sc->value = (*(port_input_function(port)))(sc, S7_READ, port);
  else
    {
      if ((is_string_port(port)) &&
	  (port_data_size(port) <= port_position(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:
	      return(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);
	    }
	}
    }
  /* equally read-done and read-list here */
  return(goto_START);
}
		  
static void eval_string_1_ex(s7_scheme *sc)
{
  if ((sc->tok != TOKEN_EOF) &&
      (port_position(sc->input_port) < port_data_size(sc->input_port))) /* ran past end somehow? */
    {
      unsigned char c;
      while (white_space[c = port_data(sc->input_port)[port_position(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;
}

static int string_c_ex(s7_scheme *sc)
{
  s7_int index;
  s7_pointer s, code;
  code = sc->code;

  s = find_symbol_checked(sc, car(code));
  if ((!is_string(s)) ||
      (!is_integer(cadr(code))))
    return(fall_through);
  
  index = s7_integer(cadr(code));
  if ((index < string_length(s)) &&
      (index >= 0))
    {
      if (is_byte_vector(s))
	sc->value = small_int((unsigned char)string_value(s)[index]);
      else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
      return(goto_START);
    }
  sc->value = string_ref_1(sc, s, cadr(code));
  return(goto_START);
}

static int string_a_ex(s7_scheme *sc)
{
  s7_int index;
  s7_pointer s, x, code;
  code = sc->code;

  s = find_symbol_checked(sc, car(code));
  x = c_call(cdr(code))(sc, cadr(code));
  if ((!is_string(s)) ||
      (!s7_is_integer(x)))
    return(fall_through);
  
  index = s7_integer(x);
  if ((index < string_length(s)) &&
      (index >= 0))
    {
      if (is_byte_vector(s))
	sc->value = small_int((unsigned char)string_value(s)[index]);
      else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
      return(goto_START);
    }
  sc->value = string_ref_1(sc, s, x);
  return(goto_START);
}

static int string_s_ex(s7_scheme *sc)
{
  s7_int index;
  s7_pointer s, ind, code;
  code = sc->code;

  s = find_symbol_checked(sc, car(code));
  ind = find_symbol_checked(sc, cadr(code));
  if ((!is_string(s)) ||
      (!s7_is_integer(ind)))
    return(fall_through);
  
  index = s7_integer(ind);
  if ((index < string_length(s)) &&
      (index >= 0))
    {
      if (is_byte_vector(s))
	sc->value = small_int((unsigned char)string_value(s)[index]);
      else sc->value = s7_make_character(sc, ((unsigned char *)string_value(s))[index]);
      return(goto_START);
    }
  sc->value = string_ref_1(sc, s, ind);
  return(goto_START);
}
		  

static int vector_c_ex(s7_scheme *sc)
{
  /* 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_g in optimize_expression -> vector_c
   *    but it still reports itself as unsafe, so there are higher levels possible
   */
  s7_pointer v, code;
  code = sc->code;

  v = find_symbol_checked(sc, car(code));
  if ((!s7_is_vector(v)) ||
      (!s7_is_integer(cadr(code))))  /* (v 4/3) */
    return(fall_through);

  if (vector_rank(v) == 1)
    {
      s7_int index;
      index = s7_integer(cadr(code));
      if ((index < vector_length(v)) &&
	  (index >= 0))
	{
	  sc->value = vector_getter(v)(sc, v, index);
	  return(goto_START);
	}
    }
  sc->value = vector_ref_1(sc, v, cdr(code));
  return(goto_START);
}
		  
static int vector_cc_ex(s7_scheme *sc)
{
  s7_pointer v, code;

  code = sc->code;
  v = find_symbol_checked(sc, car(code));
  if (!s7_is_vector(v))                    /* we've checked that the args are non-negative ints */
    return(fall_through);  

  if (vector_rank(v) == 2)
    {
      s7_int index;
      index = s7_integer(cadr(code)) * vector_offset(v, 0) + s7_integer(caddr(code));
      if (index < vector_length(v))
	{
	  sc->value = vector_getter(v)(sc, v, index);
	  return(goto_START);
	}
    }
  sc->value = vector_ref_1(sc, v, cdr(code));
  return(goto_START);
}

static int vector_s_ex(s7_scheme *sc)
{
  s7_pointer v, ind, code;

  code = sc->code;
  v = find_symbol_checked(sc, car(code));
  ind = find_symbol_checked(sc, cadr(code));
  if ((!s7_is_vector(v)) ||
      (!s7_is_integer(ind)))
    return(fall_through);
  
  if (vector_rank(v) == 1)
    {
      s7_int index;
      index = s7_integer(ind);
      if ((index < vector_length(v)) &&
	  (index >= 0))
	{
	  sc->value = vector_getter(v)(sc, v, index);
	  return(goto_START);
	}
    }
  sc->value = vector_ref_1(sc, v, cons(sc, ind, sc->nil));
  return(goto_START);
}

static int vector_a_ex(s7_scheme *sc)
{
  s7_pointer v, x, code;

  code = sc->code;
  v = find_symbol_checked(sc, car(code));
  if (!s7_is_vector(v))
    return(fall_through);
  
  x = c_call(cdr(code))(sc, cadr(code));
  if (s7_is_integer(x))
    {
      if (vector_rank(v) == 1)
	{
	  s7_int index;
	  index = s7_integer(x);
	  if ((index < vector_length(v)) &&
	      (index >= 0))
	    {
	      sc->value = vector_getter(v)(sc, v, index);
	      return(goto_START);
	    }
	}
    }
  sc->value = vector_ref_1(sc, v, cons(sc, x, sc->nil));
  return(goto_START);
}

static void increment_1_ex(s7_scheme *sc)
{
  /* ([set!] ctr (+ ctr 1)) */
  s7_pointer val, y;
  
  y = find_symbol(sc, car(sc->code));
  if (!is_slot(y))
    eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", car(sc->code));
  
  val = slot_value(y);
  switch (type(val))
    {
    case T_INTEGER:
      sc->value = make_integer(sc, integer(val) + 1);  /* this can't be optimized to treat y's value as a mutable integer */
      break;
      
    case T_RATIO:
      new_cell(sc, sc->value, T_RATIO);
      numerator(sc->value) = numerator(val) + denominator(val);
      denominator(sc->value) = denominator(val);
      break;
      
    case T_REAL:
      sc->value = make_real(sc, real(val) + 1.0);
      break;
      
    case T_COMPLEX:
      new_cell(sc, sc->value, T_COMPLEX);
      set_real_part(sc->value, real_part(val) + 1.0);
      set_imag_part(sc->value, imag_part(val));
      break;
      
    default:
      sc->value = g_add(sc, set_plist_2(sc, val, small_int(1)));
      break;
    }
  slot_set_value(y, sc->value);
}

static void decrement_1_ex(s7_scheme *sc)
{
  /* ([set!] ctr (- ctr 1)) */
  s7_pointer val, y;
  y = find_symbol(sc, car(sc->code));
  if (!is_slot(y))
    eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", car(sc->code));
  val = slot_value(y);
  switch (type(val))
    {
    case T_INTEGER:
      sc->value = make_integer(sc, integer(val) - 1);
      break;
      
    case T_RATIO:
      new_cell(sc, sc->value, T_RATIO);
      numerator(sc->value) = numerator(val) - denominator(val);
      denominator(sc->value) = denominator(val);
      break;
      
    case T_REAL:
      sc->value = make_real(sc, real(val) - 1.0);
      break;
      
    case T_COMPLEX:
      new_cell(sc, sc->value, T_COMPLEX);
      set_real_part(sc->value, real_part(val) - 1.0);
      set_imag_part(sc->value, imag_part(val));
      break;
      
    default:
      sc->value = g_subtract(sc, set_plist_2(sc, val, small_int(1)));
      break;
    }
  slot_set_value(y, sc->value);
}

static void set_pws_ex(s7_scheme *sc)
{
  /* ([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_no_return(sc, sc->syntax_error_symbol, "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 = find_symbol_checked(sc, value);
      
      set_car(sc->t1_1, value);
      sc->value = c_function_call(c_function_setter(obj))(sc, sc->t1_1);
    }
  else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", obj);
}


/* -------------------------------- apply functions -------------------------------- */

static void apply_c_function(s7_scheme *sc) 	                    /* -------- C-based function -------- */
{
  unsigned int len;
  len = safe_list_length(sc, sc->args);
  if (len < c_function_required_args(sc->code))
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
  if (c_function_all_args(sc->code) < len)
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
  sc->value = c_function_call(sc->code)(sc, sc->args);
}

static void apply_c_opt_args_function(s7_scheme *sc)                /* -------- 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)
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
  sc->value = c_function_call(sc->code)(sc, sc->args);
}

static void apply_c_rst_args_function(s7_scheme *sc)                /* -------- 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))
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, 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) */
}

static void apply_c_any_args_function(s7_scheme *sc)                /* -------- C-based function that can take any number of arguments -------- */
{
  sc->value = c_function_call(sc->code)(sc, sc->args);
}

static void apply_c_function_star(s7_scheme *sc)                    /* -------- C-based function with defaults (lambda*) -------- */
{
  sc->value = c_function_call(sc->code)(sc, set_c_function_call_args(sc));
}

static void apply_c_macro(s7_scheme *sc)  	                    /* -------- C-based macro -------- */
{
  int len;
  len = s7_list_length(sc, sc->args);
  
  if (len < (int)c_macro_required_args(sc->code))
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
  
  if ((int)c_macro_all_args(sc->code) < len)
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));
  
  sc->code = c_macro_call(sc->code)(sc, sc->args);
  if (is_multiple_value(sc->code)) /* can this happen? s7_values splices before returning, and `(values ...) is handled later */
    {
      push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->code));
      sc->code = car(sc->code);
    }
}

static void apply_syntax(s7_scheme *sc)                            /* -------- syntactic keyword as applicable object -------- */
{                                                                  /* current reader-cond macro uses this via (map quote ...) */
  int len;                                                         /*    ((apply lambda '((x) (+ x 1))) 4) */
  if (is_pair(sc->args))
    {
      len = s7_list_length(sc, sc->args);
      if (len == 0) eval_error_no_return(sc, sc->syntax_error_symbol, "attempt to evaluate a circular list: ~A", sc->args);
    }
  else len = 0;
  
  if (len < syntax_min_args(sc->code))
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, sc->code, sc->args));
  
  if ((syntax_max_args(sc->code) < len) &&
      (syntax_max_args(sc->code) != -1))
    s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, sc->code, sc->args));

  sc->op = (opcode_t)syntax_opcode(sc->code);         /* (apply begin '((define x 3) (+ x 2))) */
  /* I used to have elaborate checks here for embedded circular lists, but now i think that is the caller's problem */
  sc->code = sc->args;
}

static void apply_vector(s7_scheme *sc)                            /* -------- vector as applicable object -------- */
{
  /* sc->code is the vector, sc->args is the list of indices */
  if (is_null(sc->args))                  /* (#2d((1 2) (3 4))) */
    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_rank(sc->code) == 1))
    {
      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);
      else out_of_range(sc, sc->vector_ref_symbol, small_int(2), car(sc->args), (index < 0) ? its_negative_string : its_too_large_string);
    }
  else sc->value = vector_ref_1(sc, sc->code, sc->args);
}

static void apply_string(s7_scheme *sc)                            /* -------- string as applicable object -------- */
{
  if (is_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_byte_vector(sc->code))
		sc->value = small_int((unsigned char)(string_value(sc->code))[index]);
	      else sc->value = s7_make_character(sc, ((unsigned char *)string_value(sc->code))[index]);
	      return;
	    }
	}
      sc->value = string_ref_1(sc, sc->code, car(sc->args));
      return;
    }
  s7_error(sc, sc->wrong_number_of_args_symbol, 
	   set_elist_3(sc, (is_null(sc->args)) ? sc->not_enough_arguments_string : sc->too_many_arguments_string, sc->code, sc->args));
}

static int apply_pair(s7_scheme *sc)                              /* -------- 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;
      return(goto_APPLY);
    }
  if (is_null(sc->args))
    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) */
  return(goto_START);
}

static void apply_hash_table(s7_scheme *sc)                        /* -------- hash-table as applicable object -------- */
{
  if (is_null(sc->args))
    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));
}

static void apply_let(s7_scheme *sc)                               /* -------- environment as applicable object -------- */
{
  if (is_null(sc->args))
    sc->value = s7_let_ref(sc, sc->code, sc->F);         /* why #f and not ()? both are ok in s7test */
  else sc->value = s7_let_ref(sc, sc->code, car(sc->args));
  if (is_pair(cdr(sc->args)))
    sc->value = implicit_index(sc, sc->value, cdr(sc->args));
  /*    (let ((v #(1 2 3))) (let ((e (curlet))) ((e 'v) 1))) -> 2
   * so (let ((v #(1 2 3))) (let ((e (curlet))) (e 'v 1))) -> 2
   */
}

static void apply_iterator(s7_scheme *sc)                          /* -------- iterator as applicable object -------- */
{
  if (!is_null(sc->args))
    s7_wrong_number_of_args_error(sc, "too many args for iterator: ~A", sc->args);
  sc->value = s7_iterate(sc, sc->code);
}

static void apply_lambda(s7_scheme *sc)                              /* -------- normal function (lambda), or macro -------- */
{             /* load up the current args into the ((args) (lambda)) layout [via the current environment] */
	      /* not often safe closure here, and very confusing if so to get identity macro args handled correctly */
  s7_pointer x, z, e;
  unsigned long long int id;
  e = sc->envir;
  id = let_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))
	{
	  s7_pointer name, ccode;
	  name = closure_name(sc, sc->code);
	  ccode = current_code(sc);
	  s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->not_enough_arguments_string, (name == ccode) ? sc->code : name, ccode));
	}
      /* now that args are being reused as slots, the error message can't use sc->args,
       *  so fallback on current_code(sc) in this section.
       *  But that can be #f, and closure_name can be confusing in this context, so we need a better error message!
       */
      
      sym = car(x);
      val = _NFre(car(z));
      args = cdr(z);
      set_type(z, T_SLOT);
      slot_set_symbol(z, sym);
      symbol_set_local(sym, id, z);
      slot_set_value(z, val);
      set_next_slot(z, let_slots(e));
      let_set_slots(e, z);
      z = args;
    }
  if (is_null(x))
    {
      if (is_not_null(z))
	{
	  s7_pointer name, ccode;
	  name = closure_name(sc, sc->code);
	  ccode = current_code(sc);
	  s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, sc->too_many_arguments_string, (name == ccode) ? sc->code : name, ccode));
	}
    }
  else
    {
      sc->temp6 = z; /* the rest arg */
      make_slot_1(sc, sc->envir, x, z);
      sc->temp6 = sc->nil;
    }
  sc->code = closure_body(sc->code);
}

static int apply_lambda_star(s7_scheme *sc) 	                  /* -------- define* (lambda*) -------- */
{
  /* to check for and fixup unset args from defaults, we need to traverse the slots in left-to-right order
   *   but they are stored backwards in the environment, so use pending_value as a back-pointer.
   * We have to build the environment before calling lambda_star_set_args because keywords can
   *   cause any arg to be set at any point in the arg list.
   *
   * the frame-making step below could be precalculated, but where to store it?
   */
  s7_pointer z, top, nxt;
  top = NULL;
  nxt = NULL;

  for (z = closure_args(sc->code); is_pair(z); z = cdr(z))
    {
      s7_pointer car_z;
      car_z = car(z);
      if (is_pair(car_z))           /* arg has a default value of some sort */
	{
	  s7_pointer val;
	  val = cadr(car_z);
	  if ((!is_pair(val)) &&
	      (!is_symbol(val)))
	    make_slot_1(sc, sc->envir, car(car_z), val);
	  else
	    {
	      s7_pointer y;
	      add_slot(sc->envir, car(car_z), sc->undefined);
	      y = let_slots(sc->envir);
	      slot_set_expression(y, cadr(car_z));
	      slot_set_pending_value(y, sc->nil);
	      if (!top)
		{
		  top = y;
		  nxt = top;
		}
	      else
		{
		  slot_set_pending_value(nxt, y);
		  nxt = y;
		}
	    }
	}
      else
	{
	  if (!is_keyword(car_z))
	    make_slot_1(sc, sc->envir, car_z, sc->F);
	  else
	    {
	      if (car_z == sc->key_rest_symbol)
		{
		  make_slot_1(sc, sc->envir, cadr(z), sc->nil);
		  z = cdr(z);
		}
	    }
	}
    }
  if (is_symbol(z))
    make_slot_1(sc, sc->envir, z, sc->nil);
  lambda_star_set_args(sc);                     /* load up current arg vals */
  
  if (top)
    {
      /* 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 = top;
      if (lambda_star_default(sc) == goto_EVAL) return(goto_EVAL);
      pop_stack_no_op(sc);              /* get original args and code back */
    }
  sc->code = closure_body(sc->code);
  return(goto_BEGIN1);
}

static void apply_continuation(s7_scheme *sc)	                  /* -------- continuation ("call/cc") -------- */
{
  if (!call_with_current_continuation(sc))
    {
      static s7_pointer cc_err = NULL; 
      if (!cc_err) cc_err = s7_make_permanent_string("continuation can't jump into with-baffle");
      s7_error(sc, sc->baffled_symbol, set_elist_1(sc, cc_err));
    }
}

static void apply_c_object(s7_scheme *sc)                          /* -------- applicable (new-type) object -------- */
{
  sc->value = (*(c_object_ref(sc->code)))(sc, sc->code, sc->args);
}


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

static int define1_ex(s7_scheme *sc)
{	  
  /* sc->code is the symbol being defined, sc->value is its value
   *   if sc->value is a closure, car is of the form ((args...) body...)
   *   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 calls define-constant.
   */
  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_no_return(sc, sc->syntax_error_symbol, "define: ~S is immutable", sc->code);
      
      x = global_slot(sc->code); 
      if ((!is_slot(x)) ||
	  (type(sc->value) != unchecked_type(slot_value(x))) ||
	  (!s7_is_morally_equal(sc, sc->value, slot_value(x))))      /* if value is unchanged, just ignore this (re)definition */
	eval_error_no_return(sc, sc->syntax_error_symbol, "define: ~S is immutable", sc->code);   /*   can't use s7_is_equal because value might be NaN, etc */
    }
  if (symbol_has_accessor(sc->code))
    {
      s7_pointer x;
      x = find_symbol(sc, sc->code);
      if ((is_slot(x)) &&
	  (slot_has_accessor(x)))
	{
	  sc->value = bind_accessed_symbol(sc, OP_DEFINE_WITH_ACCESSOR, sc->code, sc->value);
	  if (sc->value == sc->no_value)
	    return(goto_APPLY);
	  /* if all goes well, OP_DEFINE_WITH_ACCESSOR will jump to DEFINE2 */
	}
    }
  return(fall_through);
}

static void define2_ex(s7_scheme *sc)
{
  if ((is_any_closure(sc->value)) &&
      ((!(is_let(closure_let(sc->value)))) ||
       (!(is_function_env(closure_let(sc->value))))))  /* otherwise it's (define f2 f1) or something similar */
    {
      s7_pointer new_func, new_env;
      new_func = sc->value;
      
      new_cell_no_check(sc, new_env, T_LET | T_FUNCTION_ENV);
      let_id(new_env) = ++sc->let_number;
      set_outlet(new_env, closure_let(new_func));
      closure_set_let(new_func, new_env);
      let_set_slots(new_env, sc->nil);
      funclet_set_function(new_env, sc->code);
      
      if (/* (!is_let(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 */
	  let_set_file(new_env, port_file_number(sc->input_port));
	  let_set_line(new_env, port_line_number(sc->input_port));
	}
      else
	{
	  let_set_file(new_env, 0);
	  let_set_line(new_env, 0);
	}
      
      /* 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)))
		make_slot_1(sc, new_env, caar(arg), sc->nil);
	      else make_slot_1(sc, new_env, car(arg), sc->nil);
	    }
	  let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
	}
      /* add the newly defined thing to the current environment */
      if (is_let(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); 
      sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */
    }
  else
    {
      s7_pointer lx;
      /* add the newly defined thing to the current environment */
      lx = find_local_symbol(sc, sc->code, sc->envir);
      if (is_slot(lx))
	slot_set_value(lx, sc->value);
      else s7_make_slot(sc, sc->envir, sc->code, sc->value);
    }
}


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

static void clear_all_optimizations(s7_scheme *sc, s7_pointer p)
{
  /* I believe that we would not have been optimized to begin with if the tree were circular,
   *   and this tree is supposed to be a function call + args -- a circular list here is a bug.
   */
  if (is_pair(p))
    {
      if ((is_optimized(p)) &&
	  ((optimize_op(p) & 1) == 0)) /* protect possibly shared code?  Elsewhere we assume these aren't changed */
	{
	  clear_optimized(p);
	  clear_optimize_op(p);
	  /* these apparently make no difference */
	  set_opt_con1(p, sc->nil);
	  set_opt_con2(p, sc->nil);
	}
      clear_all_optimizations(sc, cdr(p));
      clear_all_optimizations(sc, car(p));
    }
}


static bool a_is_ok(s7_scheme *sc, s7_pointer p)
{
  /* "A" here need not be a function call or "p" a pair (all_x_c etc) */
  if (is_pair(p))
    {
      if ((is_optimized(p)) &&
	  (!c_function_is_ok(sc, p)))
	return(false);
      if (car(p) != sc->quote_symbol)
	return((a_is_ok(sc, car(p))) &&
	       (a_is_ok(sc, cdr(p))));
    }
  return(true);
}

#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, cadr(P))))
#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, caddr(P))))
#define c_function_is_ok_cadr_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (c_function_is_ok(Sc, cadr(P))) && (c_function_is_ok(Sc, caddr(P))))

#define a_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (a_is_ok(Sc, cadr(P))))
#define a_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (a_is_ok(Sc, caddr(P))))
#define a_is_ok_cadddr(Sc, P) ((c_function_is_ok(Sc, P)) && (a_is_ok(Sc, cadddr(P))))


#if WITH_PROFILE
static void profile(s7_scheme *sc, s7_pointer expr)
{
  if (is_null(sc->profile_info))
    {
      sc->profile_info = s7_make_hash_table(sc, 65536);
      s7_gc_protect(sc, sc->profile_info);
    }
  if ((is_pair(expr)) &&
      (has_line_number(expr)))
    {
      s7_pointer val, key;
      key = s7_make_integer(sc, pair_line(expr));
      val = s7_hash_table_ref(sc, sc->profile_info, key);
      if (val == sc->F)
	s7_hash_table_set(sc, sc->profile_info, key, cons(sc, make_mutable_integer(sc, 1), expr));
      else integer(car(val))++;
    }
}
#endif



/* -------------------------------- eval -------------------------------- */

#if WITH_GCC
#undef new_cell
#if (!DEBUGGING)
#define new_cell(Sc, Obj, Type)			\
  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)));					\
    set_type(Obj, Type);						\
    } while (0)
#else
#define new_cell(Sc, Obj, Type)			\
  do {						\
    if ((Sc->free_heap_top <= Sc->free_heap_trigger) || (for_any_other_reason(sc, __LINE__))) {last_gc_line = __LINE__; last_gc_func = __func__; try_to_call_gc(Sc); if ((Sc->begin_hook) && (call_begin_hook(Sc))) return(Sc->F);} \
    Obj = (*(--(Sc->free_heap_top))); \
    Obj->alloc_line = __LINE__;	Obj->alloc_func = __func__;	\
    set_type(Obj, Type);	      \
    } while (0)
#endif
#endif

#if WITH_GMP
#define global_add big_add
#else
#define global_add g_add
#endif

static s7_pointer check_for_cyclic_code(s7_scheme *sc, s7_pointer code)
{
  if (cyclic_sequences(sc, code, false) == sc->T)
    eval_error(sc, "attempt to evaluate a circular list: ~A", code);
  resize_stack(sc);
  return(sc->F);
}


static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
  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 */
  while (true) 
    {
    START:
      pop_stack(sc);
      
      /* syntax_opcode can be optimize_op, 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, 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.
       *   see end of file -- I think this is too pessimistic and given rearrangement of the s7_cell layout,
       *   can be done without an increase in size.
       *
       * 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:
      /* fprintf(stderr, "%s (%d)\n", op_names[sc->op], (int)(sc->op)); */
      switch (sc->op)
	{
	case OP_NO_OP:
	  break;
	  
	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_symbol, set_elist_1(sc, make_string_wrapper(sc, "our input port got clobbered!"))));
	  
	  sc->tok = token(sc);
	  switch (sc->tok)
	    {
	    case TOKEN_EOF:
	      {
		/* (eval-string "'a ; b") gets here with 'a -> a, so we need to squelch the pending eval.
		 *   another approach would read-ahead in eval_string_1_ex, but this seems less messy.
		 */
		int top;
		top = s7_stack_top(sc) - 1;
		if (stack_op(sc->stack, top) == OP_EVAL_STRING_1)
		  vector_element(sc->stack, top) = (s7_pointer)OP_EVAL_STRING_2;
	      }
	      break;
	      
	    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);
	      break;
	    }
	  break;
	  
	  
	  /* (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 */
	  break;
	  
	  
	  /* 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 */
	      if ((!is_string_port(sc->input_port)) ||
		  (port_position(sc->input_port) < port_data_size(sc->input_port)))
		{
		  push_stack(sc, OP_READ_INTERNAL, sc->nil, sc->nil);
		}
	      else sc->tok = TOKEN_EOF;
	      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));
	  break;
	  
	  
	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));
	  break;
	  
	case OP_EVAL_STRING_1:
	  eval_string_1_ex(sc);
	  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;
	    s7_pointer lx;
	    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_range_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);
		lx = SORT_LESSP; /* cadr of sc->args */
		if (needs_copied_args(lx))
		  sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1));
		else
		  {
		    set_car(sc->t2_1, SORT_DATA(j));
		    set_car(sc->t2_2, SORT_DATA(j + 1));
		    sc->args = sc->t2_1;
		  }
		sc->code = lx;
		goto APPLY;
	      }
	    else sc->value = sc->F;
	  }
	  
	case OP_SORT1:
	  {
	    s7_int j, k;
	    s7_pointer lx;
	    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);
	    lx = SORT_LESSP;
	    if (needs_copied_args(lx))
	      sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j));
	    else
	      {
		set_car(sc->t2_1, SORT_DATA(k));
		set_car(sc->t2_2, SORT_DATA(j));
		sc->args = sc->t2_1;
	      }
	    sc->code = lx;
	    goto APPLY;
	  }
	  
	case OP_SORT2:
	  {
	    s7_int j, k;
	    k = SORT_K1;
	    j = SORT_J;
	    if (is_true(sc, sc->value))
	      {
		s7_pointer lx;
		lx = SORT_DATA(j);
		SORT_DATA(j) = SORT_DATA(k);
		SORT_DATA(k) = lx;
	      }
	    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)
	      {
		SORT_K = k - 1;
		SORT_K1 = k - 1;
		push_stack(sc, OP_SORT, sc->args, sc->code);
		goto HEAPSORT;
	      }
	    /* else fall through */
	  }

	case OP_SORT3:
	  {
	    s7_int n;
	    s7_pointer lx;
	    n = SORT_N;
	    if (n <= 0)
	      {
		sc->value = car(sc->args);
		goto START;
	      }
	    lx = SORT_DATA(0);
	    SORT_DATA(0) = SORT_DATA(n);
	    SORT_DATA(n) = lx;
	    SORT_N = n - 1;
	    SORT_K1 = 0;
	    push_stack(sc, OP_SORT3, sc->args, sc->code);
	    goto HEAPSORT;
	  }
	  
	case OP_SORT_PAIR_END:       /* sc->value is the sort vector which needs to be copied into the original list */
	  sc->value = vector_into_list(sc->value, car(sc->args));
	  break;
	  
	case OP_SORT_VECTOR_END:     /* sc->value is the sort (s7_pointer) vector which needs to be copied into the original (double/int) vector */
	  sc->value = vector_into_fi_vector(sc->value, car(sc->args));
	  break;
	  
	case OP_SORT_STRING_END:
	  sc->value = vector_into_string(sc->value, car(sc->args));
	  break;
	  
	  /* batcher networks:
	   *    ((0 2) (0 1) (1 2))
	   *    ((0 2) (1 3) (0 1) (2 3) (1 2))
	   *    etc -- see batcher in s7test.scm (from Doug Hoyte)
	   * 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
	   */
	  
	  
	  /* -------------------------------- MAP -------------------------------- */
	case OP_MAP_GATHER_1:
	  if (sc->value != sc->no_value)
	    {
	      if (is_multiple_value(sc->value))
		counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args)));
	      else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args)));
	    }
	  
	case OP_MAP_1:
	  {
	    s7_pointer x, args, code, p;
	    code = sc->code;
	    args = sc->args;
	    p = counter_list(args);
	    x = s7_iterate(sc, p);
	    
	    if (iterator_is_at_end(p))
	      {
		sc->value = safe_reverse_in_place(sc, counter_result(args));
		goto START;
	      }
	    push_stack(sc, OP_MAP_GATHER_1, args, code);
	    if (counter_capture(args) != sc->capture_let_counter)
	      {
		new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), x);
		counter_set_let(args, sc->envir);
		counter_set_slots(args, let_slots(sc->envir));
		counter_set_capture(args, sc->capture_let_counter);
	      }
	    else 
	      {
		/* the counter_slots field saves the original local let slot(s) representing the function
		 *   argument.  If the function has internal defines, they get added to the front of the
		 *   slots list, but old_frame_with_slot (maybe stupidly) assumes only the one original
		 *   slot exists when it updates its symbol_id from the (possibly changed) let_id.  So,
		 *   a subsequent reference to the parameter name causes "unbound variable", or a segfault
		 *   if the check has been optimized away.  I think each function call should start with
		 *   the original let slots, so counter_slots saves that pointer, and resets it here.
		 */
		let_set_slots(counter_let(args), counter_slots(args));
		sc->envir = old_frame_with_slot(sc, counter_let(args), x);
	      }
	    sc->code = closure_body(code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_MAP_GATHER:
	  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_set_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_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args)));
	    }
	  
	case OP_MAP:
	  {
	    s7_pointer y, iterators;
	    iterators = counter_list(sc->args);
	    sc->x = sc->nil;                     /* can't use preset args list here (as in for-each): (map list '(a b c)) */
	    for (y = iterators; is_pair(y); y = cdr(y))
	      {
		s7_pointer x;
		x = s7_iterate(sc, car(y));
		if (iterator_is_at_end(car(y)))
		  {
		    sc->value = safe_reverse_in_place(sc, counter_result(sc->args));
		    /* here and below it is not safe to pre-release sc->args (the counter) */
		    goto START;
		  }
		sc->x = cons(sc, x, sc->x);
	      }
	    sc->x = safe_reverse_in_place(sc, sc->x);
	    push_stack(sc, OP_MAP_GATHER, sc->args, sc->code);
	    sc->args = sc->x;
	    sc->x = sc->nil;
	    
	    if (needs_copied_args(sc->code))
	      sc->args = copy_list(sc, sc->args);
	    goto APPLY;
	  }
	  
	  
	  /* -------------------------------- FOR-EACH -------------------------------- */
	case OP_FOR_EACH:
	  {
	    s7_pointer x, y, iterators, saved_args;
	    iterators = car(sc->args);
	    saved_args = cdr(sc->args);
	    for (x = saved_args, y = iterators; is_pair(x); x = cdr(x), y = cdr(y))
	      {
		set_car(x, s7_iterate(sc, car(y)));
		if (iterator_is_at_end(car(y)))
		  {
		    sc->value = sc->unspecified;
		    goto START;
		  }
	      }
	    push_stack(sc, OP_FOR_EACH, sc->args, sc->code);
	    sc->args = saved_args;
	    if (needs_copied_args(sc->code))
	      sc->args = copy_list(sc, sc->args);
	    goto APPLY;
	  }
	  
	  
	  /* 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 curlet.
	   *   owlet captures, but it would require a deliberate error to use it in this context.
	   *   c_objects call object_set_let but that requires a prior curlet or sublet.  So we have
	   *   sc->capture_let_counter that is incremented every time an environment is captured, then
	   *   here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and can reuse frame.
	   */

	case OP_FOR_EACH_1:
	  {
	    s7_pointer code, counter, p, arg;
	    counter = sc->args;
	    p = counter_list(counter);
	    arg = s7_iterate(sc, p);
	    if (iterator_is_at_end(p))
	      {
		sc->value = sc->unspecified;
		goto START;
	      }
	    code = sc->code;
	    if (counter_capture(counter) != sc->capture_let_counter)
	      {
		new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg);
		counter_set_let(counter, sc->envir);
		counter_set_slots(counter, let_slots(sc->envir));
		counter_set_capture(counter, sc->capture_let_counter);
	      }
	    else 
	      {
		let_set_slots(counter_let(counter), counter_slots(counter));
		sc->envir = old_frame_with_slot(sc, counter_let(counter), arg);
	      }
	    push_stack(sc, OP_FOR_EACH_1, counter, code);
	    sc->code = closure_body(code);
	    goto BEGIN1;
	  }

	case OP_FOR_EACH_3:
	case OP_FOR_EACH_2:
	  {
	    s7_pointer code, c, lst, arg;
	    c = sc->args; /* the counter */
	    lst = counter_list(c);
	    if (!is_pair(lst))  /* '(1 2 . 3) as arg? -- counter_list can be anything here */
	      {
		sc->value = sc->unspecified;
		goto START;
	      }
	    code = sc->code;
	    arg = car(lst);
	    counter_set_list(c, cdr(lst));
	    if (sc->op == OP_FOR_EACH_3)
	      {
		counter_set_result(c, cdr(counter_result(c)));
		if (counter_result(c) == counter_list(c))
		  {
		    sc->value = sc->unspecified;
		    goto START;
		  }
		push_stack(sc, OP_FOR_EACH_2, c, code);
	      }
	    else push_stack(sc, OP_FOR_EACH_3, c, code);
	    if (counter_capture(c) != sc->capture_let_counter)
	      {
		new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg);
		counter_set_let(c, sc->envir);
		counter_set_slots(c, let_slots(sc->envir));
		counter_set_capture(c, sc->capture_let_counter);
	      }
	    else 
	      {
		let_set_slots(counter_let(c), counter_slots(c));
		sc->envir = old_frame_with_slot(sc, counter_let(c), arg);
	      }
	    sc->code = closure_body(code);
	    goto BEGIN1;
	  }

	  
	  /* -------------------------------- MEMBER -------------------------------- */
	case OP_MEMBER_IF:
	case OP_MEMBER_IF1:
	  /* code=func, args = (list original args) with opt_fast->position in cadr (the list), value = result of comparison
	   */
	  if (sc->value != sc->F)                      /* previous comparison was not #f -- return list */
	    {
	      sc->value = opt_fast(sc->args);
	      goto START;
	    }
	  if (!is_pair(cdr(opt_fast(sc->args))))           /* no more args -- return #f */
	    {
	      sc->value = sc->F;
	      goto START;
	    }
	  set_opt_fast(sc->args, cdr(opt_fast(sc->args)));     /* cdr down arg list */
	  
	  if (sc->op == OP_MEMBER_IF1)
	    {
	      /* circular list check */
	      if (opt_fast(sc->args) == opt_slow(sc->args))
		{
		  sc->value = sc->F;
		  goto START;
		}
	      set_opt_slow(sc->args, cdr(opt_slow(sc->args)));  /* cdr down the slow list (check for circular list) */
	      push_stack(sc, OP_MEMBER_IF, sc->args, sc->code);
	    }
	  else push_stack(sc, OP_MEMBER_IF1, sc->args, sc->code);

	  if (needs_copied_args(sc->code))
	    sc->args = list_2(sc, caar(sc->args), car(opt_fast(sc->args)));
	  else sc->args = set_plist_2(sc, caar(sc->args), car(opt_fast(sc->args)));
	  goto APPLY;
	  
	  
	  /* -------------------------------- ASSOC -------------------------------- */
	case OP_ASSOC_IF:
	case OP_ASSOC_IF1:
	  /* code=func, args=(list args) with f/opt_fast=list, value=result of comparison
	   *   (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =)
	   */
	  if (sc->value != sc->F)            /* previous comparison was not #f -- return (car list) */
	    {
	      sc->value = car(opt_fast(sc->args));
	      goto START;
	    }
	  if (!is_pair(cdr(opt_fast(sc->args))))     /* (assoc 3 '((1 . 2) . 3) =) or nil */
	    {
	      sc->value = sc->F;
	      goto START;
	    }
	  set_opt_fast(sc->args, cdr(opt_fast(sc->args)));  /* cdr down arg list */
	  
	  if (sc->op == OP_ASSOC_IF1)
	    {
	      /* circular list check */
	      if (opt_fast(sc->args) == opt_slow(sc->args))
		{
		  sc->value = sc->F;
		  goto START;
		}
	      set_opt_slow(sc->args, cdr(opt_slow(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(opt_fast(sc->args))))     /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
	    eval_type_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
	   */
	  if (needs_copied_args(sc->code))
	    sc->args = list_2(sc, caar(sc->args), caar(opt_fast(sc->args)));
	  else sc->args = set_plist_2(sc, caar(sc->args), caar(opt_fast(sc->args)));
	  goto APPLY;
	  
	  
	  /* -------------------------------- DO -------------------------------- */
	SAFE_DOTIMES:
	case OP_SAFE_DOTIMES:
	  {
	    int choice;
	    choice = safe_dotimes_ex(sc);
	    if (choice == goto_SAFE_DO_END_CLAUSES) goto SAFE_DO_END_CLAUSES;
	    if (choice == goto_BEGIN1) goto BEGIN1;
	    if (choice == goto_OPT_EVAL) goto OPT_EVAL;
	    if (choice == goto_START_WITHOUT_POP_STACK) goto START_WITHOUT_POP_STACK;
	    pair_set_syntax_symbol(sc->code, sc->simple_do_symbol);
	    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_END_CLAUSES;
	      }
	    push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code);
	    sc->code = opt_pair2(sc->code);
	    sc->op = (opcode_t)pair_syntax_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_END_CLAUSES;
	      }
	    push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, sc->code);
	    sc->code = opt_pair2(sc->code);
	    goto OPT_EVAL;
	  }
	  
	  
	case OP_SAFE_DOTIMES_STEP_A:
	  {
	    s7_pointer arg;
	    /* no calls?? */
	    arg = slot_value(sc->args);
	    set_car(sc->t2_1, arg);
	    set_car(sc->t2_2, sc->value);
	    c_call(opt_pair2(sc->code))(sc, sc->t2_1);
	    
	    numerator(arg)++;
	    if (numerator(arg) == denominator(arg))
	      {
		sc->code = cdr(cadr(sc->code));
		goto DO_END_CLAUSES;
	      }
	    
	    push_stack(sc, OP_SAFE_DOTIMES_STEP_A, sc->args, sc->code);
	    sc->code = caddr(opt_pair2(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_END_CLAUSES;
	      }
	    push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code);
	    
	    arg = opt_pair2(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:
	  {
	    int choice;
	    choice = safe_do_ex(sc);
	    if (choice == goto_SAFE_DO_END_CLAUSES) goto SAFE_DO_END_CLAUSES;
	    if (choice == goto_EVAL) goto EVAL;
	    if (choice == goto_DO_UNCHECKED) goto DO_UNCHECKED;
	    goto BEGIN1;
	  }

	  
	case OP_SAFE_DO_STEP:
	  {
	    s7_int step, end;
	    s7_pointer args, code, slot;
	    
	    args = sc->envir;
	    code = sc->code;
	    slot = dox_slot1(args);
	    
	    step = s7_integer(slot_value(slot)) + 1;
	    slot_set_value(slot, make_integer(sc, step));
	    end = s7_integer(slot_value(dox_slot2(args)));

	    if ((step == end) ||
		((step > end) &&
		 (opt_cfunc(caadr(code)) == geq_2)))
		{
		  sc->code = cdadr(code);
		  goto DO_END_CLAUSES;
		}
	    push_stack(sc, OP_SAFE_DO_STEP, sc->args, code);
	    sc->code = opt_pair2(code);
	    goto BEGIN1;
	  }
	  
	  
	SIMPLE_DO_P:
	case OP_SIMPLE_DO_P:
	  sc->op = OP_SIMPLE_DO_P;
	  goto SIMPLE_DO;

	SIMPLE_DO_E:
	case OP_SIMPLE_DO_E:
	  sc->op = OP_SIMPLE_DO_E;
	  goto SIMPLE_DO;

	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 = find_symbol_checked(sc, init);
	    else
	      {
		if (is_pair(init))
		  sc->value = c_call(init)(sc, cdr(init));
		else sc->value = init;
	      }
	    dox_set_slot1(sc->envir, make_slot_1(sc, sc->envir, 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, T_SLOT);
		slot_set_symbol(slot, sc->dox_slot_symbol);
		slot_set_value(slot, end);
		sc->args = slot;
	      }
	    dox_set_slot2(sc->envir, sc->args);
	    set_car(sc->t2_1, slot_value(dox_slot1(sc->envir)));
	    set_car(sc->t2_2, slot_value(dox_slot2(sc->envir)));
	    if (is_true(sc, c_call(caadr(code))(sc, sc->t2_1)))
	      {
		sc->code = cdadr(code);
		goto DO_END_CLAUSES;
	      }
	    
	    if (sc->op == OP_SIMPLE_DO_P)
	      {
		push_stack(sc, OP_SIMPLE_DO_STEP_P, sc->args, code);
		sc->code = caddr(code);
		goto EVAL;
	      }

	    set_opt_pair2(code, cddr(code));
	    if ((is_null(cdr(opt_pair2(code)))) &&
		(is_pair(car(opt_pair2(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? */
	      {
		int choice;
		choice = simple_do_ex(sc, code);
		if (choice == goto_START) goto START;
		if (choice == goto_BEGIN1) goto BEGIN1;
		if (choice == goto_DO_END_CLAUSES) goto DO_END_CLAUSES;
	      }

	    if (sc->op == OP_SIMPLE_DO_E)
	      push_stack(sc, OP_SIMPLE_DO_STEP_E, sc->args, code);
	    else
	      {
		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 = opt_pair2(code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_SIMPLE_DO_STEP_P:
	case OP_SIMPLE_DO_STEP:
	  {
	    s7_pointer step, ctr, end, code;
	    
	    ctr = dox_slot1(sc->envir);
	    end = dox_slot2(sc->envir);
	    code = sc->code;
	    
	    step = caddr(caar(code));
	    if (is_symbol(cadr(step)))
	      {
		set_car(sc->t2_1, slot_value(ctr));
		set_car(sc->t2_2, caddr(step));
	      }
	    else
	      {
		set_car(sc->t2_2, slot_value(ctr));
		set_car(sc->t2_1, cadr(step));
	      }
	    slot_set_value(ctr, c_call(step)(sc, sc->t2_1));
	    
	    set_car(sc->t2_1, slot_value(ctr));
	    set_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_END_CLAUSES;
	      }

	    push_stack(sc, sc->op, sc->args, code);
	    if (sc->op == OP_SIMPLE_DO_STEP_P)
	      {
		code = caddr(code);
		set_current_code(sc, code);
		sc->op = (opcode_t)pair_syntax_op(code);
		sc->code = cdr(code);
		goto START_WITHOUT_POP_STACK;
	      }

	    sc->code = opt_pair2(code);
	    goto BEGIN1;
	  }
	  
	case OP_SIMPLE_DO_STEP_E:
	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)))
	     * we checked in check_do that the step expr is s+1
	     */
	    s7_pointer val, ctr, end, code;
	    s7_int index;
	    
	    code = sc->code;
	    ctr = dox_slot1(sc->envir);
	    val = slot_value(ctr);
	    end = slot_value(dox_slot2(sc->envir));
	    
	    if (is_integer(val))
	      {
		slot_set_value(ctr, make_integer(sc, index = integer(val) + 1));
		if (is_integer(end))
		  {
		    if (index == integer(end))
		      {
			sc->code = cdr(cadr(code));
			goto DO_END_CLAUSES;
		      }
		  }
		else
		  {
		    set_car(sc->t2_1, slot_value(ctr));
		    set_car(sc->t2_2, end);
		    if (is_true(sc, g_equal_2(sc, sc->t2_1)))
		      {
			sc->code = cdr(cadr(code));
			goto DO_END_CLAUSES;
		      }
		  }
	      }
	    else
	      {
		set_car(sc->t1_1, val); /* add_s1 ignores cadr(args) */
		slot_set_value(ctr, g_add_s1(sc, sc->t1_1));
		set_car(sc->t2_1, slot_value(ctr));
		set_car(sc->t2_2, end);
		if (is_true(sc, g_equal_2(sc, sc->t2_1)))
		  {
		    sc->code = cdr(cadr(code));
		    goto DO_END_CLAUSES;
		  }
	      }

	    push_stack(sc, sc->op, sc->args, code);
	    if (sc->op == OP_SIMPLE_DO_STEP_E)
	      {
		sc->code = car(opt_pair2(code));
		goto OPT_EVAL;
	      }
	    sc->code = opt_pair2(code);
	    goto BEGIN1;
	  }
	  
	  
	DOTIMES_P:
	case OP_DOTIMES_P:
	  {
	    int choice;
	    choice = dotimes_p_ex(sc);
	    if (choice == goto_DO_END_CLAUSES) goto DO_END_CLAUSES;
	    if (choice == goto_DO_UNCHECKED) goto DO_UNCHECKED;
	    goto EVAL;
	  }
	  
	case OP_DOTIMES_STEP_P:
	  {
	    s7_pointer ctr, now, end, code, end_test;
	    
	    code = sc->code;
	    ctr = dox_slot1(sc->envir);
	    now = slot_value(ctr);
	    end = slot_value(dox_slot2(sc->envir));
	    end_test = opt_pair2(code);
	    
	    if (is_integer(now))
	      {
		slot_set_value(ctr, make_integer(sc, integer(now) + 1));
		now = slot_value(ctr);
		if (is_integer(end))
		  {
		    if ((integer(now) == integer(end)) ||
			((integer(now) > integer(end)) &&
			 (opt_cfunc(end_test) == geq_2)))
			{
			  sc->code = cdadr(code);
			  goto DO_END_CLAUSES;
			}
		  }
		else
		  {
		    set_car(sc->t2_1, now);
		    set_car(sc->t2_2, end);
		    if (is_true(sc, c_call(end_test)(sc, sc->t2_1)))
		      {
			sc->code = cdadr(code);
			goto DO_END_CLAUSES;
		      }
		  }
	      }
	    else
	      {
		set_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)) */
		set_car(sc->t2_1, slot_value(ctr));
		set_car(sc->t2_2, end);
		if (is_true(sc, c_call(end_test)(sc, sc->t2_1)))
		  {
		    sc->code = cdadr(code);
		    goto DO_END_CLAUSES;
		  }
	      }
	    push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
	    code = caddr(code);
	    set_current_code(sc, code);
	    sc->op = (opcode_t)pair_syntax_op(code);
	    sc->code = cdr(code);
	    goto START_WITHOUT_POP_STACK;
	  }
	  
	  
	DOX:
	case OP_DOX:
	  {
	    int choice;
	    choice = dox_ex(sc);
	    if (choice == goto_DO_END_CLAUSES) goto DO_END_CLAUSES;
	    if (choice == goto_START) goto START;
	    if (choice == goto_BEGIN1) goto BEGIN1;
	    if (choice == goto_START_WITHOUT_POP_STACK) goto START_WITHOUT_POP_STACK;

	    push_stack_no_args(sc, OP_DOX_STEP, sc->code);
	    sc->code = cddr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_DOX_STEP:
	  {
	    s7_pointer slot;
	    
	    for (slot = let_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
	      if (is_pair(slot_expression(slot)))
		slot_set_value(slot, c_call(slot_expression(slot))(sc, car(slot_expression(slot))));
	    
	    if (is_true(sc, c_call(cdr(sc->code))(sc, opt_pair2(sc->code))))
	      {
		sc->code = cdadr(sc->code);
		goto DO_END_CLAUSES;
	      }
	    push_stack_no_args(sc, OP_DOX_STEP, sc->code);
	    sc->code = cddr(sc->code);
	    goto BEGIN1;
	  }
	  
	case OP_DOX_STEP_P:
	  {
	    s7_pointer slot;
	    
	    for (slot = let_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
	      if (is_pair(slot_expression(slot)))
		slot_set_value(slot, c_call(slot_expression(slot))(sc, car(slot_expression(slot))));
	    
	    if (is_true(sc, c_call(cdr(sc->code))(sc, opt_pair2(sc->code))))
	      {
		sc->code = cdadr(sc->code);
		goto DO_END_CLAUSES;
	      }
	    push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);
	    sc->code = caddr(sc->code);
	    sc->op = (opcode_t)pair_syntax_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) opt_slot1(P)
        #define DO_VAR_NEW_VALUE(P) cdr(P)
        #define DO_VAR_SET_NEW_VALUE(P, Val) set_cdar(P, Val)
        #define DO_VAR_STEP_EXPR(P) car(P)
	  
	DO_STEP:
	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_let_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_SET_NEW_VALUE(sc->args, sc->value);  /* save current value */
	  sc->args = cdr(sc->args);                   /* go to next step var */
	  goto DO_STEP1;
	  
	  
	case OP_DO:    /* sc->code is the stuff after "do" */
	  if (is_null(check_do(sc)))
	    {
	      s7_pointer op;
	      op = car(opt_back(sc->code));
	      if (op == sc->dox_symbol)	         goto DOX;
	      if (op == sc->safe_dotimes_symbol) goto SAFE_DOTIMES;
	      if (op == sc->dotimes_p_symbol)    goto DOTIMES_P;
	      if (op == sc->safe_do_symbol)	 goto SAFE_DO;
	      if (op == sc->simple_do_a_symbol)  goto SIMPLE_DO_A;
	      if (op == sc->simple_do_e_symbol)  goto SIMPLE_DO_E;
	      if (op == sc->simple_do_symbol)    goto SIMPLE_DO;
	      goto SIMPLE_DO_P;
	    }
	  
	DO_UNCHECKED:
	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 */
	  
	  
	case OP_DO_INIT:
	  if (do_init_ex(sc) == goto_EVAL)
	    goto EVAL;
	  /* fall through */
	  
	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_pair(sc->code))
		{
		  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 BEGIN1;
		}
	      else
		{
		  /* no body? */
		  if (is_null(car(sc->args)))
		    goto DO_END;
		  goto DO_STEP;
		}
	    }
	  
	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) */
	      free_cell(sc, 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 */
	    }
	  goto BEGIN1;
	  
	  
	SAFE_DO_END_CLAUSES:
	  if (is_null(sc->code))
	    {
	      /* sc->args = sc->nil; */
	      sc->envir = free_let(sc, sc->envir);
	      sc->value = sc->nil;
	      goto START;
	    }
	  goto DO_END_CODE;
	  
	DO_END_CLAUSES:
	  if (is_null(sc->code))
	    {
	      sc->value = sc->nil;
	      goto START;
	    }
	DO_END_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->code = car(sc->code);
	  if (is_pair(sc->code))
	    goto EVAL;
	  if (is_symbol(sc->code))
	    sc->value = find_symbol_checked(sc, sc->code);
	  else sc->value = sc->code;
	  goto START;
	  
	  
	  /* -------------------------------- BEGIN -------------------------------- */
	case OP_BEGIN:
	  if (!is_proper_list(sc, sc->code))       /* proper list includes nil, I think */
	    eval_error(sc, "unexpected dot? ~A", sc->code);
	   
	  if ((!is_null(sc->code)) &&              /* so check for it here */
	      (!is_null(cdr(sc->code))) &&
	      (is_overlaid(sc->code)) &&
	      (has_opt_back(sc->code)))
	    pair_set_syntax_symbol(sc->code, sc->begin_unchecked_symbol);
	  
	case OP_BEGIN_UNCHECKED:
	  /* if ((sc->begin_hook) && (call_begin_hook(sc))) return(sc->F); */
	  if (is_null(sc->code))                   /* (begin) -> () */
	    {
	      sc->value = sc->nil;
	      goto START;
	    }
	  
	case OP_BEGIN1:
	  if ((sc->begin_hook) && (call_begin_hook(sc))) return(sc->F);
	BEGIN1:
#if DEBUGGING
	  if (!s7_is_list(sc, sc->code)) abort();
#endif
	  if (is_pair(cdr(sc->code)))              /* sc->code can be nil here, but cdr(nil)->#<unspecified> */
	    push_stack_no_args(sc, OP_BEGIN1, cdr(sc->code));
	  sc->code = car(sc->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 %d %d\n", DISPLAY_80(sc->code), (typesflag(sc->code) == SYNTACTIC_PAIR), (is_optimized(sc->code))); */

	  if (typesflag(sc->code) == SYNTACTIC_PAIR)  /* xor is not faster here */
	    {
#if WITH_PROFILE
	      profile(sc, sc->code);
#endif
	      set_current_code(sc, sc->code);         /* in case an error occurs, this helps tell us where we are */
	      sc->op = (opcode_t)pair_syntax_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 */
	    }
	  
	  if (is_optimized(sc->code))
	    {
	      s7_pointer code;
	      /* fprintf(stderr, "    %s\n", opt_names[optimize_op(sc->code)]); */

	    OPT_EVAL:
#if WITH_PROFILE
	      profile(sc, sc->code);
#endif
	      code = sc->code;
	      set_current_code(sc, code);
	      
	      switch (optimize_op(code))
		{
		  /* -------------------------------------------------------------------------------- */
		case OP_SAFE_C_C:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_C:
		  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:
		  set_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:
		  set_car(sc->t1_1, find_symbol_checked(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 = find_symbol_checked(sc, car(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_1, val);
		    sc->value = c_call(code)(sc, sc->t2_1);
		    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))
		      set_car(p, find_symbol_checked(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);
		    set_car(sc->t2_1, find_symbol_checked(sc, car(args)));
		    set_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);
		    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
		    set_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);
		    set_car(sc->t2_1, find_symbol_checked(sc, car(args)));
		    set_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);
		    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
		    set_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);
		    set_car(sc->t2_1, cadr(car(args)));
		    set_car(sc->t2_2, cadr(cadr(args)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_CQ:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_CQ:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, car(args));
		    set_car(sc->t2_2, cadr(cadr(args)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_QC:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_QC:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, cadr(car(args)));
		    set_car(sc->t2_2, 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;
		  /* I think a_is_ok of cadr here and below is redundant -- they'll be checked when Z is
		   *    because we cleared the hop bit after combine_ops.
		   */
		  
		case HOP_SAFE_C_Z:
		  check_stack_size(sc);
		  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;
		  
		case HOP_SAFE_C_CZ:
		  check_stack_size(sc);
		  /* it's possible in a case like this to overflow the stack -- s7test has a deeply
		   *   nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cz -- if we're close
		   *   to the stack end at the start, it runs off the end.  Normally the stack increase in
		   *   the reader protects us, but a call/cc can replace the original stack with a much smaller one.
		   * How to minimize the cost of this check?
		   */
		  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;
		  
		case HOP_SAFE_C_ZC:
		  check_stack_size(sc);
		  push_stack(sc, OP_SAFE_C_ZC_1, caddr(code), code); /* need ZC_1 here in case multiple values encountered */
		  sc->code = cadr(code);
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_C_SZ:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_SZ:
		  check_stack_size(sc);
		  push_stack(sc, OP_SAFE_C_SZ_1, find_symbol_checked(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_ZS:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_ZS:
		  check_stack_size(sc);
		  push_stack(sc, OP_EVAL_ARGS_P_3, sc->nil, code);
		  sc->code = cadr(code);
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_C_opAq:
		  if (!a_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opAq:
		  {
		    s7_pointer arg;
		    arg = cadr(code);
		    set_car(sc->a1_1, c_call(cdr(arg))(sc, cadr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->a1_1));
		    sc->value = c_call(code)(sc, sc->t1_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opAAq:
		  if (!a_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opAAq:
		  {
		    s7_pointer arg;
		    arg = cadr(code);
		    set_car(sc->a2_1, c_call(cdr(arg))(sc, cadr(arg)));
		    set_car(sc->a2_2, c_call(cddr(arg))(sc, caddr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->a2_1));
		    sc->value = c_call(code)(sc, sc->t1_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opAAAq:
		  if (!a_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opAAAq:
		  {
		    s7_pointer arg;
		    arg = cadr(code);
		    set_car(sc->a3_1, c_call(cdr(arg))(sc, cadr(arg)));
		    set_car(sc->a3_2, c_call(cddr(arg))(sc, caddr(arg)));
		    set_car(sc->a3_3, c_call(cdddr(arg))(sc, cadddr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->a3_1));
		    sc->value = c_call(code)(sc, sc->t1_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_S_opAq:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opAq:
		  {
		    s7_pointer arg;
		    arg = caddr(code);
		    set_car(sc->a1_1, c_call(cdr(arg))(sc, cadr(arg)));
		    set_car(sc->t2_2, c_call(arg)(sc, sc->a1_1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_S_opAAq:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opAAq:
		  {
		    s7_pointer arg;
		    arg = caddr(code);
		    set_car(sc->a2_1, c_call(cdr(arg))(sc, cadr(arg)));
		    set_car(sc->a2_2, c_call(cddr(arg))(sc, caddr(arg)));
		    set_car(sc->t2_2, c_call(arg)(sc, sc->a2_1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_S_opAAAq:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opAAAq:
		  {
		    s7_pointer arg, p;
		    p = caddr(code);
		    arg = cdr(p);
		    set_car(sc->a3_1, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_2, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_3, c_call(arg)(sc, car(arg)));
		    set_car(sc->t2_2, c_call(p)(sc, sc->a3_1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_S_opSZq:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opSZq:
		  push_stack(sc, OP_SAFE_C_SZ_SZ, find_symbol_checked(sc, cadr(caddr(code))), code);
		  sc->code = caddr(caddr(code));
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_C_AZ:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AZ:
		  push_stack(sc, OP_SAFE_C_SZ_1, c_call(cdr(code))(sc, cadr(code)), code);
		  sc->code = caddr(code);
		  goto OPT_EVAL;
		  /* s: h_safe_c_s_op_s_opssqq: 204308 */
		  
		  
		case OP_SAFE_C_ZA:
		  if (!a_is_ok(sc, 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;
		  
		case HOP_SAFE_C_ZZ:
		  /* most of the component Z's here are very complex:
		   *    264600: (+ (* even-amp (oscil (vector-ref evens k) (+ even-freq val))) (* odd-amp...
		   */
		  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 (!a_is_ok(sc, 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 (!a_is_ok(sc, 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 (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AZA:
		  push_stack(sc, OP_SAFE_C_AZA_1, c_call(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;
		  
		case HOP_SAFE_C_SSZ:
		  push_stack(sc, OP_SAFE_C_SSZ_1, find_symbol_checked(sc, cadr(code)), code);
		  sc->code = cadddr(code);
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_C_AAZ:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AAZ:
		  push_op_stack(sc, c_call(cdr(code))(sc, cadr(code)));
		  push_stack(sc, OP_SAFE_C_AAZ_1, c_call(cddr(code))(sc, caddr(code)), code);
		  sc->code = cadddr(code);
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_C_ZZA:
		  if (!a_is_ok(sc, 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 (!a_is_ok(sc, 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 (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AZZ:
		  push_stack(sc, OP_SAFE_C_AZZ_1, c_call(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;
		  
		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_A:
		  if (!a_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_A:
		  set_car(sc->a1_1, c_call(cdr(code))(sc, cadr(code)));
		  sc->value = c_call(code)(sc, sc->a1_1);
		  goto START;
		  
		  
		case OP_SAFE_C_AA:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AA:
		  set_car(sc->a2_1, c_call(cdr(code))(sc, cadr(code)));
		  set_car(sc->a2_2, c_call(cddr(code))(sc, caddr(code)));
		  sc->value = c_call(code)(sc, sc->a2_1);
		  goto START;
		  
		  
		case OP_SAFE_C_AAA:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AAA:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_2, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_3, c_call(arg)(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_SSA:
		  if (!a_is_ok_cadddr(sc, code)) break;
		  
		case HOP_SAFE_C_SSA:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, find_symbol_checked(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_2, find_symbol_checked(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_3, c_call(arg)(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_SAS:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_SAS:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, find_symbol_checked(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_2, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_3, find_symbol_checked(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_CSA:
		  if (!a_is_ok_cadddr(sc, code)) break;
		  
		case HOP_SAFE_C_CSA:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, car(arg));
		    arg = cdr(arg);
		    set_car(sc->a3_2, find_symbol_checked(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_3, c_call(arg)(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_SCA:
		  if (!a_is_ok_cadddr(sc, code)) break;
		  
		case HOP_SAFE_C_SCA:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, find_symbol_checked(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a3_2, car(arg));
		    arg = cdr(arg);
		    set_car(sc->a3_3, c_call(arg)(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_CAS:
		  if (!a_is_ok_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_CAS:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a3_1, car(arg));
		    arg = cdr(arg);
		    set_car(sc->a3_2, c_call(arg)(sc, car(arg)));
		    set_car(sc->a3_3, find_symbol_checked(sc, cadr(arg)));
		    sc->value = c_call(code)(sc, sc->a3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_AAAA:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_AAAA:
		  {
		    s7_pointer arg;
		    arg = cdr(code);
		    set_car(sc->a4_1, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a4_2, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a4_3, c_call(arg)(sc, car(arg)));
		    arg = cdr(arg);
		    set_car(sc->a4_4, c_call(arg)(sc, car(arg)));
		    sc->value = c_call(code)(sc, sc->a4_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_ALL_X:
		  if (!a_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))
		      set_car(p, c_call(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:
		  {
		    /* (let-set! gen 'fm fm);  many of these are handled in safe_closure_star_s0 */
		    s7_pointer val1, args;
		    args = cdr(code);
		    val1 = find_symbol_checked(sc, car(args));
		    set_car(sc->t3_3, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t3_2, opt_con1(args));
		    set_car(sc->t3_1, val1);
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		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_checked(sc, car(args));
		    set_car(sc->t3_3, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t3_2, opt_con1(args));
		    set_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_checked(sc, car(args));
		    set_car(sc->t3_2, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t3_3, opt_con2(args));
		    set_car(sc->t3_1, val1);
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_SCC:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_SCC:
		  {
		    /* (make-env E :length 100) */
		    s7_pointer args;
		    args = cdr(code);
		    
		    set_car(sc->t3_1, find_symbol_checked(sc, car(args)));
		    set_car(sc->t3_2, opt_con1(args));
		    set_car(sc->t3_3, opt_con2(args));
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_CSC:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_CSC:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    
		    set_car(sc->t3_2, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t3_1, car(args));
		    set_car(sc->t3_3, opt_con2(args));
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		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_checked(sc, opt_sym2(args));
		    set_car(sc->t3_2, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t3_3, val1);
		    set_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_checked(sc, car(args));
		    val2 = find_symbol_checked(sc, opt_sym1(args));
		    set_car(sc->t3_3, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t3_1, val1);
		    set_car(sc->t3_2, val2);
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opCq:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCq:
		  set_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_opSq:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq:
		  {
		    s7_pointer args;
		    args = cadr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(args)));
		    set_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_op_opSq_q:
		  if ((!c_function_is_ok(sc, code)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, cadr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_opSq_q:
		  {
		    s7_pointer outer, args;
		    outer = cadr(code);
		    args = cadr(outer);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t1_1, c_call(args)(sc, sc->t1_1));
		    set_car(sc->t1_1, c_call(outer)(sc, sc->t1_1));
		    sc->value = c_call(code)(sc, sc->t1_1);
		    goto START;
		  }
		  
		case OP_SAFE_C_op_S_opSq_q:
		  if ((!c_function_is_ok(sc, code)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, caddr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_S_opSq_q:
		  {
		    /* (exp (* r (cos x))) */
		    s7_pointer outer, args;
		    outer = cadr(code);
		    args = caddr(outer);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_2, c_call(args)(sc, sc->t1_1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(outer)));
		    set_car(sc->t1_1, c_call(outer)(sc, sc->t2_1));
		    sc->value = c_call(code)(sc, sc->t1_1);
		    goto START;
		  }


		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);
		  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);
		  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, find_symbol_checked(sc, cadr(code)), code);
		  sc->code = caddr(code);
		  goto EVAL;
		  
		  
		case OP_SAFE_C_AP:
		  if ((!c_function_is_ok(sc, code)) || (!a_is_ok(sc, cadr(code)))) break;
		  
		case HOP_SAFE_C_AP:
		  push_stack(sc, OP_EVAL_ARGS_P_2, c_call(cdr(code))(sc, cadr(code)), code);
		  sc->code = caddr(code);
		  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:
		  push_stack(sc, OP_SAFE_C_PP_1, sc->nil, code);
		  sc->code = cadr(code);
		  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);
		  goto EVAL;
		  
		  
		case OP_SAFE_C_opSSq:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq:
		  {
		    s7_pointer args, val1;
		    args = cadr(code);
		    val1 = find_symbol_checked(sc, cadr(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(args)));
		    set_car(sc->t2_1, val1);
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSCq:
		  {
		    s7_pointer args;
		    args = cadr(code);
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_2, caddr(args));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCSq:
		  {
		    s7_pointer args;
		    args = cadr(code);
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(args)));
		    set_car(sc->t2_1, cadr(args));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSQq:
		  {
		    s7_pointer args;
		    args = cadr(code);
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_2, cadr(caddr(args)));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opSq:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, car(args));
		    set_car(sc->t1_1, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t1_1));
		    set_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_caddr(sc, code))break;
		  
		case HOP_SAFE_C_S_opCq:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, car(args));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, opt_pair1(args))); /* any number of constants here */
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_C_opSq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t1_1));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_C_opCq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_2, c_call(cadr(args))(sc, opt_pair1(args))); /* any # of args */
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_C_opCSq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t2_1, opt_con1(args));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_C_opSSq:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, opt_sym1(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t2_1, val);
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCSq_C:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(car(args))));
		    set_car(sc->t2_1, cadr(car(args)));
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq_C:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, cadr(car(args)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(car(args))));
		    set_car(sc->t2_1, val);
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq_S:
		  {
		    s7_pointer args, val, val1;
		    args = cdr(code);
		    val = find_symbol_checked(sc, cadr(car(args)));
		    val1 = find_symbol_checked(sc, cadr(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(car(args))));
		    set_car(sc->t2_1, val);
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, cadr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_opSSq_q_C:
		  {
		    /* code: (> (magnitude (- old new)) 0.001) */
		    s7_pointer arg;
		    arg = cadr(cadr(code));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->t2_1));
		    set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1));
		    set_car(sc->t2_2, caddr(code));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_op_opSSq_q_S:
		  if ((!c_function_is_ok(sc, code)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, cadr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_opSSq_q_S:
		  {
		    /* code: (> (magnitude (- old new)) s) */
		    s7_pointer arg;
		    arg = cadr(cadr(code));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->t2_1));
		    set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_op_opSq_q_C:
		  if ((!c_function_is_ok(sc, code)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, cadr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_opSq_q_C:
		  {
		    s7_pointer arg;
		    arg = cadr(cadr(code));
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->t1_1));
		    set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1));
		    set_car(sc->t2_2, caddr(code));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_op_opSq_q_S:
		  if ((!c_function_is_ok(sc, code)) || (!c_function_is_ok(sc, cadr(code))) || (!c_function_is_ok(sc, cadr(cadr(code))))) break;
		  
		case HOP_SAFE_C_op_opSq_q_S:
		  {
		    s7_pointer arg;
		    arg = cadr(cadr(code));
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(arg)));
		    set_car(sc->t1_1, c_call(arg)(sc, sc->t1_1));
		    set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t1_1));
		    set_car(sc->t2_2, find_symbol_checked(sc, 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)) || (!c_function_is_ok(sc, caddr(code))) || (!c_function_is_ok(sc, cadr(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 = find_symbol_checked(sc, cadr(val1));                  /* b */
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(val1)));       /* c */
		    set_car(sc->t2_1, val);
		    val = find_symbol_checked(sc, caddr(args));                 /* d */
		    set_car(sc->t2_1, c_call(val1)(sc, sc->t2_1));    /* (- b c) */
		    set_car(sc->t2_2, val);
		    set_car(sc->t2_2, c_call(args)(sc, sc->t2_1));    /* (* ...) */
		    set_car(sc->t2_1, find_symbol_checked(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)) || (!c_function_is_ok(sc, caddr(code))) || (!c_function_is_ok(sc, caddr(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 = find_symbol_checked(sc, cadr(val1));                  /* b */
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(val1)));       /* c */
		    set_car(sc->t2_1, val);
		    val = find_symbol_checked(sc, cadr(args));                  /* d */
		    set_car(sc->t2_2, c_call(val1)(sc, sc->t2_1));    /* (- b c) */
		    set_car(sc->t2_1, val);
		    set_car(sc->t2_2, c_call(args)(sc, sc->t2_1));    /* (* ...) */
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(code)));        /* a */
		    sc->value = c_call(code)(sc, sc->t2_1);        /* (+ ...) */
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_S_op_opSSq_opSSqq:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_S_op_opSSq_opSSqq:
		  {
		    /* (* s (f3 (f1 a b) (f2 c d))) */
		    s7_pointer args, f1, op1, op2;
		    
		    args = caddr(code);
		    op1 = cadr(args);
		    op2 = caddr(args);
		    
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(op1)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(op1)));
		    f1 = c_call(op1)(sc, sc->t2_1);
		    
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(op2)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(op2)));
		    set_car(sc->t2_2, c_call(op2)(sc, sc->t2_1));
		    
		    set_car(sc->t2_1, f1);
		    set_car(sc->t2_2, c_call(args)(sc, sc->t2_1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSCq_S:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSCq_S:
		  {
		    s7_pointer args, val1;
		    args = cdr(code);
		    val1 = find_symbol_checked(sc, cadr(args));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_2, caddr(car(args)));
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSCq_C:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_2, caddr(car(args)));
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCSq_S:
		  {
		    s7_pointer args, val1;
		    args = cdr(code);
		    val1 = find_symbol_checked(sc, cadr(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(car(args))));
		    set_car(sc->t2_1, cadr(car(args)));
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t2_1));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opSCq:
		  {
		    s7_pointer val1, args;
		    args = cdr(code);
		    val1 = find_symbol_checked(sc, car(args));
		    set_car(sc->t2_1, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t2_2, opt_con2(args));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_C_opSCq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, find_symbol_checked(sc, opt_sym1(args)));
		    set_car(sc->t2_2, opt_con2(args));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_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_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_S_opSSq:
		  {
		    /* (* a (- b c)) */
		    s7_pointer val1, val2, args;
		    args = cdr(code);
		    val1 = find_symbol_checked(sc, car(args));
		    val2 = find_symbol_checked(sc, opt_sym1(args));
		    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym2(args)));
		    set_car(sc->t2_1, val2);
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_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_caddr(sc, 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 = find_symbol_checked(sc, car(args));                     /* a */
		    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym2(args)));           /* b */
		    set_car(sc->t2_1, opt_con1(args));                       /* 1 */
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1)); /* (- 1 b) */
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_S:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(car(args))));
		    sc->temp3 = c_call(car(args))(sc, sc->t1_1);
		    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_1, sc->temp3);
		    sc->temp3 = sc->nil;
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSq_P:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_P:
		  {
		    s7_pointer args;
		    args = cadr(code);
		    set_car(sc->t1_1, find_symbol_checked(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_opSq_Q:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_Q:
		  {
		    s7_pointer arg1;  /* (let-ref (cdr v) 'x) */
		    arg1 = cadr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(arg1)));
		    set_car(sc->t2_1, c_call(arg1)(sc, sc->t1_1));
		    set_car(sc->t2_2, cadr(caddr(code)));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSq_Q_S:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_Q_S:
		  {
		    s7_pointer arg1, arg3;  /* (let-set! (cdr v) 'x y) */
		    arg1 = cadr(code);
		    arg3 = find_symbol_checked(sc, cadddr(code));
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(arg1)));
		    set_car(sc->t3_1, c_call(arg1)(sc, sc->t1_1));
		    set_car(sc->t3_2, cadr(caddr(code)));
		    set_car(sc->t3_3, arg3);
		    sc->value = c_call(code)(sc, sc->t3_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opCq_S:
		  if (!c_function_is_ok_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCq_S:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, cadr(args));
		    set_car(sc->t2_1, c_call(car(args))(sc, cdr(car(args))));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opCq_C:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, c_call(car(args))(sc, cdr(car(args))));
		    set_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_cadr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_C:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_1, c_call(car(args))(sc, sc->t1_1));
		    set_car(sc->t2_2, cadr(args));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_C_op_S_opCqq:
		  if (!a_is_ok(sc, code)) break;
		  
		case HOP_SAFE_C_C_op_S_opCqq:
		  {
		    /* (define (hi a) (< 1.0 (+ a (* a 2)))) */
		    s7_pointer args, arg1, arg2;
		    args = cdr(code);     /* C_op_S_opCqq */
		    arg1 = cadr(args);    /* op_S_opCqq */
		    arg2 = caddr(arg1);   /* opCq */
		    set_car(sc->t2_2, c_call(arg2)(sc, cdr(arg2)));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg1)));
		    set_car(sc->t2_2, c_call(arg1)(sc, sc->t2_1));
		    set_car(sc->t2_1, car(args));
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSq_opSq:
		  if (!c_function_is_ok_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_opSq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(car(args))));
		    sc->temp3 = c_call(car(args))(sc, sc->t1_1);
		    args = cadr(args);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(args)));
		    set_car(sc->t2_2, c_call(args)(sc, sc->t1_1));
		    set_car(sc->t2_1, sc->temp3);
		    sc->temp3 = sc->nil;
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opCq_opCq:
		  if (!c_function_is_ok_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opCq_opCq:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    set_car(sc->t2_1, c_call(car(args))(sc, cdr(car(args))));
		    set_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_cadr_caddr(sc, 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);
		    set_car(sc->t2_1, find_symbol_checked(sc, cadar(args)));
		    set_car(sc->t2_2, find_symbol_checked(sc, caddar(args)));
		    set_car(sc->t2_2, c_call(car(args))(sc, sc->t2_1));
		    set_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_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSCq_opSCq:
		  {
		    s7_pointer args, val2;
		    args = cdr(code);
		    val2 = find_symbol_checked(sc, cadr(cadr(args)));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_2, caddr(car(args)));
		    sc->temp3 = c_call(car(args))(sc, sc->t2_1);
		    set_car(sc->t2_1, val2);
		    set_car(sc->t2_2, caddr(cadr(args)));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_car(sc->t2_1, sc->temp3);
		    sc->temp3 = sc->nil;
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSSq_opSSq:
		  if (!c_function_is_ok_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq_opSSq:
		  {
		    s7_pointer args, val3, val4;
		    args = cdr(code);
		    val3 = find_symbol_checked(sc, caddr(car(args)));
		    val4 = find_symbol_checked(sc, caddr(cadr(args)));
		    
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_2, val3);
		    sc->temp3 = c_call(car(args))(sc, sc->t2_1);
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(cadr(args))));
		    set_car(sc->t2_2, val4);
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_car(sc->t2_1, sc->temp3);
		    sc->temp3 = sc->nil;
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSSq_opSq:
		  if (!c_function_is_ok_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq_opSq:
		  {
		    s7_pointer args, val3;
		    args = cdr(code);
		    val3 = find_symbol_checked(sc, caddr(car(args)));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(car(args))));
		    set_car(sc->t2_2, val3);
		    val3 = c_call(car(args))(sc, sc->t2_1);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(cadr(args))));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t1_1));
		    set_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_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSq_opSSq:
		  {
		    s7_pointer args, val3;
		    args = cdr(code);
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(car(args))));
		    val3 = c_call(car(args))(sc, sc->t1_1);
		    set_car(sc->t2_2, find_symbol_checked(sc, caddr(cadr(args))));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(cadr(args))));
		    set_car(sc->t2_2, c_call(cadr(args))(sc, sc->t2_1));
		    set_car(sc->t2_1, val3);
		    sc->value = c_call(code)(sc, sc->t2_1);
		    goto START;
		  }
		  
		  
		case OP_SAFE_C_opSSq_opCq:
		  if (!c_function_is_ok_cadr_caddr(sc, code)) break;
		  
		case HOP_SAFE_C_opSSq_opCq:
		  {
		    s7_pointer arg1, arg2, val3;
		    arg1 = cadr(code);
		    arg2 = caddr(code);
		    val3 = find_symbol_checked(sc, caddr(arg1));
		    set_car(sc->t2_1, find_symbol_checked(sc, cadr(arg1)));
		    set_car(sc->t2_2, val3);
		    set_car(sc->t2_1, c_call(arg1)(sc, sc->t2_1));
		    set_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:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_S:
		  sc->args = list_1(sc, find_symbol_checked(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:
		  read_s_ex(sc);
		  goto START;

		  
		case OP_C_A:
		  if (!a_is_ok_cadr(sc, code)) break;
		  
		case HOP_C_A:
		  sc->args = list_1(sc, c_call(cdr(code))(sc, cadr(code)));
		  sc->value = c_call(code)(sc, sc->args);
		  goto START;
		  
		  
		case OP_C_Z:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_Z:
		  push_stack(sc, OP_C_P_1, sc->nil, code);
		  sc->code = cadr(code);
		  goto OPT_EVAL;
		  
		  
		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);
		  goto EVAL;
		  
		  
		case OP_C_SS:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_SS:
		  sc->args = list_2(sc, find_symbol_checked(sc, cadr(code)), find_symbol_checked(sc, caddr(code)));
		  sc->value = c_call(code)(sc, sc->args);
		  goto START;
		  
		  
		case OP_C_SZ:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_SZ:
		  push_stack(sc, OP_C_SP_1, find_symbol_checked(sc, cadr(code)), code);
		  sc->code = caddr(code);
		  goto OPT_EVAL;
		  
		  
		case OP_C_SP:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_SP:
		  push_stack(sc, OP_C_SP_1, find_symbol_checked(sc, cadr(code)), code);
		  sc->code = caddr(code);
		  goto EVAL;
		  
		  
		case OP_APPLY_SS:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_APPLY_SS:
		  sc->code = find_symbol_checked(sc, cadr(code)); /* global search here was slower */
		  sc->args = find_symbol_checked(sc, opt_sym2(code));
		  if (!is_proper_list(sc, sc->args))        /* (apply + #f) etc */
		    return(apply_list_error(sc, sc->args));
		  if (needs_copied_args(sc->code))
		    sc->args = copy_list(sc, sc->args);
		  goto APPLY;
		  
		  
		case OP_C_S_opSq:
		  if ((!c_function_is_ok(sc, code)) || (!indirect_c_function_is_ok(sc, caddr(code)))) break;
		  
		case HOP_C_S_opSq:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    val = find_symbol_checked(sc, car(args));
		    set_car(sc->t1_1, find_symbol_checked(sc, opt_sym1(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_S_opCq:
		  if ((!c_function_is_ok(sc, code)) || (!indirect_c_function_is_ok(sc, caddr(code)))) break;
		  
		case HOP_C_S_opCq:
		  {
		    s7_pointer args, val;
		    args = cdr(code);
		    sc->temp3 = find_symbol_checked(sc, car(args));
		    val = c_call(cadr(args))(sc, opt_pair1(args));
		    sc->args = list_2(sc, sc->temp3, val);
		    sc->temp3 = sc->nil;
		    sc->value = c_call(code)(sc, sc->args);
		    goto START;
		  }
		  
		  
		case OP_C_SCS:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_SCS:
		  {
		    s7_pointer a1, a2;
		    a1 = cdr(code);
		    a2 = cdr(a1);
		    sc->args = list_3(sc, find_symbol_checked(sc, car(a1)), car(a2), find_symbol_checked(sc, cadr(a2))); /* was unchecked? */
		    sc->value = c_call(code)(sc, sc->args);
		    goto START;
		  }
		  
		  
		case OP_C_ALL_X:
		  if (!c_function_is_ok(sc, code)) break;
		  
		case HOP_C_ALL_X:
		  { /* (set-cdr! lst ()) */
		    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))
		      set_car(p, c_call(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;
		    args = opt_pair2(code);
		    go = make_goto(sc);
		    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);
		    goto BEGIN1;
		  }
		  
		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, f, args, tag;
		    
		    args = cddr(code);
		    
		    /* defer making the error lambda */
		    /* z = cdadr(args); make_closure_with_let(sc, y, car(z), cdr(z), sc->envir); */
		    
		    /* check catch tag */
		    f = cadr(code);
		    if (!is_pair(f))                     /* (catch #t ...) or (catch sym ...) */
		      {
			if (is_symbol(f))
			  tag = find_symbol_checked(sc, f);
			else tag = f;
		      }
		    else tag = cadr(f);                  /* (catch 'sym ...) */
		    
		    new_cell(sc, p, T_CATCH);            /* the catch object sitting on the stack */
		    catch_tag(p) = tag;
		    catch_goto_loc(p) = 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... */
		    
		    push_stack(sc, OP_CATCH_1, code, p); /* code ignored here, except by GC */
		    new_frame(sc, sc->envir, sc->envir);
		    sc->code = cddar(args);
		    goto BEGIN1;
		  }
		  
		  
		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_set_goto_loc(p, s7_stack_top(sc));
		    catch_all_set_op_loc(p, (int)(sc->op_stack_now - sc->op_stack));
		    catch_all_set_result(p, opt_con2(code));
		    push_stack_no_args(sc, OP_CATCH_ALL, code);
		    sc->code = opt_pair1(cdr(code));                   /* the body of the first lambda */
		    goto BEGIN1;                                  /* removed one_liner check here -- rare */
		  }
		  
		  
		  /* -------------------------------------------------------------------------------- */
		case OP_THUNK:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 0)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_THUNK:
		  check_stack_size(sc);
		  /* this recursion check is consistent with the other unsafe closure calls, but we're probably in big trouble:
		   *   (letrec ((a (lambda () (cons 1 (b)))) (b (lambda () (a)))) (b))
		   * unfortunately the alternative is a segfault when we wander off the end of the stack.
		   *
		   * It seems that we could use the hop bit here (since it is always off) to choose between BEGIN1 and OPT_EVAL or EVAL,
		   *   but the EVAL choice gains nothing in time, and the OPT_EVAL choice is too tricky -- it is a two-level optimization,
		   *   so if the inner (car(closure_body)) gets unopt'd for some reason, the outer HOP_THUNK never finds
		   *   out, and peculiar things start to happen.  (Also, is_h_optimized would need to be smarter).
		   */
		  new_frame(sc, closure_let(opt_lambda(code)), sc->envir);
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_THUNK:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 0)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_SAFE_THUNK: /* no frame needed */
		  /* (let ((x 1)) (let () (define (f) x) (let ((x 0)) (define (g) (set! x 32) (f)) (g)))) */
		  sc->envir = closure_let(opt_lambda(code));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;


		case OP_SAFE_THUNK_E:
		  if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_SAFE_THUNK_E:
		  sc->envir = closure_let(opt_lambda(code));
		  sc->code = car(closure_body(opt_lambda(code)));
		  goto OPT_EVAL;


		case OP_SAFE_THUNK_P:
		  if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_SAFE_THUNK_P:
		  sc->envir = closure_let(opt_lambda(code));
		  sc->code = car(closure_body(opt_lambda(code)));
		  sc->op = (opcode_t)pair_syntax_op(sc->code);
		  sc->code = cdr(sc->code);
		  goto START_WITHOUT_POP_STACK;
		  
		  
		case OP_SAFE_CLOSURE_S:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_S:
		  /* since a tail call is safe, we can't change the current env's let_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_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_S_P:
		  if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_S_P:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = car(closure_body(opt_lambda(code)));
		  sc->op = (opcode_t)pair_syntax_op(sc->code);
		  sc->code = cdr(sc->code);
		  goto START_WITHOUT_POP_STACK;

		  
		case OP_SAFE_GLOSURE_S:
		  if ((symbol_id(car(code)) != 0) ||(opt_any1(code) != slot_value(global_slot(car(code)))))
		    {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_GLOSURE_S:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_GLOSURE_S_E:
		  if ((symbol_id(car(code)) != 0) || (opt_any1(code) != slot_value(global_slot(car(code)))))
		    {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_GLOSURE_S_E:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = car(closure_body(opt_lambda(code)));
		  goto OPT_EVAL;
		  
		  
		case OP_SAFE_CLOSURE_C:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_C:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), cadr(code));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_Q:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_Q:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), cadr(cadr(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_GLOSURE_P:
		  if ((symbol_id(car(code)) != 0) || (opt_any1(code) != slot_value(global_slot(car(code))))) break;
		  
		case HOP_SAFE_GLOSURE_P:
		  push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->nil, code);
		  sc->code = cadr(code);
		  goto EVAL;
		  
		  
		case OP_SAFE_CLOSURE_A:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  if (!indirect_c_function_is_ok(sc, cadr(code))) break;
		  
		case HOP_SAFE_CLOSURE_A:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), c_call(cdr(code))(sc, cadr(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_GLOSURE_A:
		  if ((symbol_id(car(code)) != 0) || (opt_any1(code) != slot_value(global_slot(car(code)))))
		    {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  if (!indirect_c_function_is_ok(sc, cadr(code))) break;
		  
		case HOP_SAFE_GLOSURE_A:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), c_call(cdr(code))(sc, cadr(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_SS:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_SS:
		  sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), 
						       find_symbol_checked(sc, cadr(code)), 
						       find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_SC:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_SC:
		  sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, cadr(code)), opt_con2(code));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_CS:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_CS:
		  sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), cadr(code), find_symbol_checked(sc, opt_sym2(code)));
		  sc->code = closure_body(opt_lambda(code));
		  goto BEGIN1;
		  
		  
		case OP_SAFE_CLOSURE_SA:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_AA); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_SA:
		  {
		    s7_pointer args;
		    args = cddr(code);
		    args = c_call(args)(sc, car(args));
		    sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, cadr(code)), args);
		    sc->code = closure_body(opt_lambda(code));
		    goto BEGIN1;
		  }
		  
		  
		case OP_SAFE_CLOSURE_AA:
		  if (!closure_is_ok(sc, code, MATCH_SAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_AA); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_AA:
		  {
		    s7_pointer args, y, z;
		    args = cdr(code);
		    y = c_call(args)(sc, car(args));
		    args = cdr(args);
		    z = c_call(args)(sc, car(args));
		    sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), y, z);
		    sc->code = closure_body(opt_lambda(code));
		    goto BEGIN1;
		  }
		  
		  
		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 = c_call(args)(sc, car(args));
		    args = cdr(args);
		    z = c_call(args)(sc, car(args));
		    sc->envir = old_frame_with_three_slots(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, cadr(code)), y, z);
		    sc->code = closure_body(opt_lambda(code));
		    goto BEGIN1;
		  }
		  
		  
		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, env, x, z;
		    int num_args;
		    unsigned long long int id;
		    
		    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))
		      set_car(p, c_call(args)(sc, car(args)));
		    clear_list_in_use(sc->args);
		    sc->code = opt_lambda(code);
		    
		    id = ++sc->let_number;
		    env = closure_let(sc->code);
		    let_id(env) = id;
		    
		    for (x = let_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_op(code, OP_UNKNOWN_GG); 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 = find_symbol_checked(sc, cadr(code));
		    val2 = find_symbol_checked(sc, opt_sym2(code)); /* caddr */
		    sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), val1);
		    
		    x = next_slot(let_slots(closure_let(opt_lambda(code))));
		    slot_set_value(x, val2);
		    symbol_set_local(slot_symbol(x), let_id(sc->envir), x);
		    fill_safe_closure_star(sc, next_slot(x), cddr(closure_args(opt_lambda(code))));
		    goto BEGIN1;
		  }
		  

		case OP_SAFE_CLOSURE_STAR_SC:
		  if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_STAR_SC:
		  {
		    s7_pointer x;
		    sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, cadr(code)));
		    
		    x = next_slot(let_slots(closure_let(opt_lambda(code))));
		    slot_set_value(x, caddr(code));
		    symbol_set_local(slot_symbol(x), let_id(sc->envir), x);
		    fill_safe_closure_star(sc, next_slot(x), cddr(closure_args(opt_lambda(code))));
		    goto BEGIN1;
		  }

		  
		case OP_SAFE_CLOSURE_STAR_SA:
		  if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 2)) 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 = c_call(arg)(sc, car(arg));
		    sc->envir = old_frame_with_two_slots(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, cadr(code)), arg);
		    
		    sc->code = closure_body(opt_lambda(code));
		    goto BEGIN1;
		  }
		  
		  
		case OP_SAFE_CLOSURE_STAR_ALL_X:
		  if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, integer(arglist_length(code)))) 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_let(opt_lambda(code));
		    for (args = cdr(code), p = let_slots(e), orig_args = closure_args(opt_lambda(code));
			 is_pair(args);
			 args = cdr(args), orig_args = cdr(orig_args), p = next_slot(p))
		      slot_set_pending_value(p, c_call(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_set_pending_value(p, cadr(defval));
			    else slot_set_pending_value(p, defval);
			  }
			else slot_set_pending_value(p, sc->F);
		      }
		    
		    /* we have to put off the actual environment update in case this is a tail recursive call */
		    let_id(e) = ++sc->let_number;
		    for (p = let_slots(e); is_slot(p); p = next_slot(p))
		      {
			slot_set_value(p, slot_pending_value(p));
			symbol_set_local(slot_symbol(p), let_id(e), p);
		      }
		    
		    sc->envir = e;
		    sc->code = closure_body(opt_lambda(code));
		    goto BEGIN1;
		  }
		  
		  
		case OP_SAFE_CLOSURE_STAR:
		  if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 0)) {set_optimize_op(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_let(opt_lambda(code));
		  let_id(sc->envir) = ++sc->let_number;
		  fill_safe_closure_star(sc, let_slots(closure_let(opt_lambda(code))), closure_args(opt_lambda(code)));
		  goto BEGIN1;

		  
		case OP_SAFE_CLOSURE_STAR_S0:
		  if (find_symbol_unexamined(sc, car(code)) != opt_any1(code)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_STAR_S0:
		  /* here we know we have (let-set! arg1 'name arg2) (with-env arg1 ...) as the safe closure body.
		   *   since no errors can come from the first, there's no need for the procedure env.
		   *   so do the set and with-env by hand, leaving with the env body.
		   */
		  {
		    s7_pointer e;
		    e = find_symbol_checked(sc, cadr(code));         /* S of S0 above */
		    if (e == sc->rootlet)
		      sc->envir = sc->nil;
		    else
		      {
			if (!is_let(e))
			  eval_type_error(sc, "with-let takes an environment argument: ~A", e);
			sc->envir = e;
			set_with_let_let(e);
		      }
		    
		    if (e != sc->rootlet)
		      {
			s7_pointer p;
			let_id(e) = ++sc->let_number;
			for (p = let_slots(e); is_slot(p); p = next_slot(p))
			  {
			    s7_pointer sym;
			    sym = slot_symbol(p);
			    symbol_set_local(sym, sc->let_number, p);
			  }
			slot_set_value(local_slot(opt_sym1(cdr(code))), real_zero); /* "arg2" above */
		      }
		    sc->code = opt_pair2(cdr(code));
		    goto BEGIN1;
		  }
		  
		  
		case OP_SAFE_CLOSURE_STAR_S:
		  if (!closure_star_is_ok(sc, code, MATCH_SAFE_CLOSURE_STAR, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_SAFE_CLOSURE_STAR_S:
		  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(code)), find_symbol_checked(sc, opt_sym2(code)));
		  /* that sets the first arg to the passed symbol value; now set default values, if any */
		  fill_safe_closure_star(sc, next_slot(let_slots(closure_let(opt_lambda(code)))), cdr(closure_args(opt_lambda(code))));
		  goto BEGIN1;
		  
		  
		  /* -------------------------------------------------------------------------------- */
		  
		case OP_GOTO:
		  set_opt_goto(code, find_symbol_checked(sc, car(code)));
		  if (!is_goto(opt_goto(code)))	{set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_GOTO:
		  sc->args = sc->nil;
		  sc->code = opt_goto(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_opt_goto(code, find_symbol_checked(sc, car(code)));
		  if (!is_goto(opt_goto(code)))
		    {
		      set_optimize_op(code, OP_UNKNOWN_G);
		      goto OPT_EVAL;
		    }
		  
		case HOP_GOTO_C:
		  /* (return #t) -- recognized via OP_UNKNOWN_G, opt_goto(code) is the function [parallels OP_CLOSURE_C] */
		  sc->args = cdr(code);
		  sc->code = opt_goto(code);
		  call_with_exit(sc);
		  goto START;
		  
		  
		case OP_GOTO_S:
		  set_opt_goto(code, find_symbol_checked(sc, car(code)));
		  if (!is_goto(opt_goto(code))) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_GOTO_S:
		  sc->args = list_1(sc, find_symbol_checked(sc, cadr(code)));
		  /* I think this needs listification because call_with_exit might call dynamic unwinders etc. */
		  sc->code = opt_goto(code);
		  call_with_exit(sc);
		  goto START;
		  
		  
		case OP_GOTO_A:
		  set_opt_goto(code, find_symbol_checked(sc, car(code)));
		  if (!is_goto(opt_goto(code))) {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  
		case HOP_GOTO_A:
		  sc->args = list_1(sc, c_call(cdr(code))(sc, cadr(code)));
		  sc->code = opt_goto(code);
		  call_with_exit(sc);
		  goto START;
		  /* for T_CONTINUATION, set sc->args to list_1(sc, ...) as in goto (and code?), then call_with_current_continuation */
		  
		  
		case OP_CLOSURE_C:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_C:
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), cadr(sc->code));
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_Q:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_Q:
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), cadr(cadr(sc->code)));
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_A:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  if (!indirect_c_function_is_ok(sc, cadr(code))) break;
		  
		case HOP_CLOSURE_A:
		  sc->value = c_call(cdr(code))(sc, cadr(code));
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), sc->value);
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_GLOSURE_A:
		  if ((symbol_id(car(code)) != 0) || (opt_lambda_unchecked(code) != slot_value(global_slot(car(code)))))
		    {set_optimize_op(code, OP_UNKNOWN_A); goto OPT_EVAL;}
		  if (!indirect_c_function_is_ok(sc, cadr(code))) break;
		  
		case HOP_GLOSURE_A:
		  sc->value = c_call(cdr(code))(sc, cadr(code));
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), sc->value);
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_GLOSURE_P:
		  if ((symbol_id(car(code)) != 0) || (opt_lambda_unchecked(code) != slot_value(global_slot(car(code))))) break;
		  
		case HOP_GLOSURE_P:
		  push_stack(sc, OP_CLOSURE_P_1, sc->nil, code);
		  sc->code = cadr(code);
		  goto EVAL;
		  
		  
		case OP_GLOSURE_S:
		  if ((symbol_id(car(code)) != 0) || (opt_any1(code) != slot_value(global_slot(car(code)))))
		    {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_GLOSURE_S:
		  sc->value = find_symbol_checked(sc, opt_sym2(code));
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), sc->value);
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_S:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_S:
		  sc->value = find_symbol_checked(sc, opt_sym2(code));
		  check_stack_size(sc);
		  code = opt_lambda(code);
		  new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), sc->value);
		  sc->code = closure_body(code);
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_SS:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_SS:		  /* only called if one of these symbols has an accessor */
		  unsafe_closure_2(sc, find_symbol_checked(sc, cadr(code)), find_symbol_checked(sc, opt_sym2(code)));
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_SC:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_SC:
		  unsafe_closure_2(sc, find_symbol_checked(sc, cadr(code)), opt_con2(code));
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_CS:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_CS:
		  unsafe_closure_2(sc, cadr(code), find_symbol_checked(sc, opt_sym2(code)));
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_AA:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, 2)) {set_optimize_op(code, OP_UNKNOWN_AA); goto OPT_EVAL;}
		  if ((is_optimized(cadr(code))) && (!indirect_c_function_is_ok(sc, cadr(code)))) break;
		  if ((is_optimized(caddr(code))) && (!indirect_c_function_is_ok(sc, caddr(code)))) break;
		  
		case HOP_CLOSURE_AA:
		  {
		    s7_pointer args;
		    args = cdr(code);
		    sc->temp2 = c_call(args)(sc, car(args));
		    unsafe_closure_2(sc, sc->temp2, c_call(cdr(args))(sc, cadr(args)));
		    goto BEGIN1;
		  }
		  
		  
		case OP_CLOSURE_ALL_S:
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, integer(arglist_length(code)))) {set_optimize_op(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 = opt_lambda(code);
		    /* we need to get the slot names from the current function, but the values from the calling environment */
		    new_frame(sc, closure_let(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_checked(sc, car(args)));
		    sc->envir = e;
		    sc->z = sc->nil;
		    sc->code = closure_body(func);
		    goto BEGIN1;
		  }
		  
		  
		case OP_CLOSURE_ALL_X:
		  check_stack_size(sc);
		  if (!closure_is_ok(sc, code, MATCH_UNSAFE_CLOSURE, integer(arglist_length(code)))) {set_optimize_op(code, OP_UNKNOWN_ALL_X); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_ALL_X:
		  {
		    s7_pointer args, p, func, e;
		    func = opt_lambda(code);
		    new_frame(sc, closure_let(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 = c_call(args)(sc, car(args));
			add_slot_checked(e, car(p), val); /* can't use add_slot here -- all_x_c_* hit trigger? */
		      }
		    sc->envir = e;
		    sc->z = sc->nil;
		    sc->code = closure_body(func);
		    goto BEGIN1;
		  }
		  /* -------------------------------------------------------------------------------- */
		  
		case OP_CLOSURE_STAR_ALL_X:
		  if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, integer(arglist_length(code))))
		    {
		      set_optimize_op(code, OP_UNKNOWN_ALL_X);
		      goto OPT_EVAL;
		    }
		  
		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 = opt_lambda(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))
		      set_car(new_args, c_call(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))
			      set_car(new_args, cadr(defval));
			    else set_car(new_args, defval);
			  }
			else set_car(new_args, sc->F);
		      }
		    sc->code = opt_lambda(code);
		    unsafe_closure_star(sc);
		    goto BEGIN1;
		  }
		  
		  
		case OP_CLOSURE_STAR_SX:
		  if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 2)) {set_optimize_op(code, OP_UNKNOWN_GG); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_STAR_SX:
		  {
		    s7_pointer val1, val2, args;
		    args = cddr(closure_args(opt_lambda(code)));
		    val1 = find_symbol_checked(sc, cadr(code));
		    val2 = caddr(code);
		    if (is_symbol(val2))
		      val2 = find_symbol_checked(sc, val2);
		    if (is_null(args))
		      {
			set_car(sc->t2_1, val1);
			set_car(sc->t2_2, val2);
			code = opt_lambda(sc->code);
			args = closure_args(code);
			new_frame_with_two_slots(sc, closure_let(code), sc->envir, 
						 (is_pair(car(args))) ? caar(args) : car(args), car(sc->t2_1),
						 (is_pair(cadr(args))) ? caadr(args) : cadr(args), car(sc->t2_2));
			sc->code = closure_body(code);
		      }
		    else
		      {
			sc->args = list_2(sc, val2, val1);
			fill_closure_star(sc, args);
			unsafe_closure_star(sc);
		      }
		    goto BEGIN1;
		  }
		  
		  
		case OP_CLOSURE_STAR:
		  if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 0)) {set_optimize_op(code, OP_UNKNOWN); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_STAR:
		  /* (let () (define* (hi (a 1)) (list a)) (define (ho) (hi)) (ho)) */
		  sc->args = sc->nil;
		  fill_closure_star(sc, closure_args(opt_lambda(code)));
		  unsafe_closure_star(sc);
		  goto BEGIN1;
		  
		  
		case OP_CLOSURE_STAR_S:
		  if (!closure_star_is_ok(sc, code, MATCH_UNSAFE_CLOSURE_STAR, 1)) {set_optimize_op(code, OP_UNKNOWN_G); goto OPT_EVAL;}
		  
		case HOP_CLOSURE_STAR_S:
		  sc->args = list_1(sc, find_symbol_checked(sc, opt_sym2(code)));
		  fill_closure_star(sc, cdr(closure_args(opt_lambda(code))));
		  unsafe_closure_star(sc);
		  goto BEGIN1;

		  
		  /* -------------------------------------------------------------------------------- */
		case OP_UNKNOWN:
		case HOP_UNKNOWN:
		  if (unknown_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;
		  
		case OP_UNKNOWN_G:
		case HOP_UNKNOWN_G:
		  if (unknown_g_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;

		case OP_UNKNOWN_GG:
		case HOP_UNKNOWN_GG:
		  if (unknown_gg_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;
		  
		case OP_UNKNOWN_ALL_S:
		case HOP_UNKNOWN_ALL_S:
		  if (unknown_all_s_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;
		  
		case OP_UNKNOWN_A:
		case HOP_UNKNOWN_A:
		  if (unknown_a_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;

		case OP_UNKNOWN_AA:
		case HOP_UNKNOWN_AA:
		  if (unknown_aa_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;
		  
		case OP_UNKNOWN_ALL_X:
		case HOP_UNKNOWN_ALL_X:
		  if (unknown_all_x_ex(sc, find_symbol_checked(sc, car(code))) == goto_OPT_EVAL)
		    goto OPT_EVAL;
		  break;
		  /* -------------------------------------------------------------------------------- */

		  
		case OP_VECTOR_C:
		case HOP_VECTOR_C:
		  if (vector_c_ex(sc) == goto_START) goto START;
		  break;
		  
		case OP_VECTOR_CC:
		case HOP_VECTOR_CC:
		  if (vector_cc_ex(sc) == goto_START) goto START;
		  break;
		  
		case OP_VECTOR_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_VECTOR_A:
		  if (vector_a_ex(sc) == goto_START) goto START;
		  break;

		case OP_VECTOR_S:
		case HOP_VECTOR_S:
		  if (vector_s_ex(sc) == goto_START) goto START;
		  break;
		  

		case OP_STRING_C:
		case HOP_STRING_C:
		  if (string_c_ex(sc) == goto_START) goto START;
		  break;
		  
		case OP_STRING_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_STRING_A:
		  if (string_a_ex(sc) == goto_START) goto START;
		  break;
		  
		case OP_STRING_S:
		case HOP_STRING_S:
		  if (string_s_ex(sc) == goto_START) goto START;
		  break;

		  
		case OP_HASH_TABLE_C:
		case HOP_HASH_TABLE_C:
		  {
		    s7_pointer s;
		    s = find_symbol_checked(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_checked(sc, car(code));
		    if (!is_hash_table(s)) break;
		    sc->value = s7_hash_table_ref(sc, s, find_symbol_checked(sc, cadr(code)));
		    goto START;
		  }
		  
		  
		case OP_HASH_TABLE_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_HASH_TABLE_A:
		  {
		    s7_pointer s;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_hash_table(s)) break;
		    sc->value = s7_hash_table_ref(sc, s, c_call(cdr(code))(sc, cadr(code)));
		    goto START;
		  }
		  
		  
		case OP_ENVIRONMENT_C:
		case HOP_ENVIRONMENT_C:
		  {
		    s7_pointer s;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_let(s)) break;
		    sc->value = s7_let_ref(sc, s, cadr(code));
		    goto START;
		  }
		  
		  
		case OP_ENVIRONMENT_S:
		case HOP_ENVIRONMENT_S:
		  {
		    s7_pointer s;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_let(s)) break;
		    sc->value = s7_let_ref(sc, s, find_symbol_checked(sc, cadr(code)));
		    goto START;
		  }
		  
		  
		case OP_ENVIRONMENT_Q:
		case HOP_ENVIRONMENT_Q:
		  {
		    s7_pointer s, sym;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_let(s)) break;
		    sym = cadr(cadr(code));
		    if (is_symbol(sym))
		      sc->value = let_ref_1(sc, s, sym);
		    else return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sym, a_symbol_string)); /* (e '(1)) */
		    goto START;
		  }
		  
		  
		case OP_ENVIRONMENT_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_ENVIRONMENT_A:
		  {
		    s7_pointer s, sym;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_let(s)) break;
		    sym = c_call(cdr(code))(sc, cadr(code));
		    if (is_symbol(sym))
		      sc->value = let_ref_1(sc, s, sym);
		    else return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sym, a_symbol_string)); /* (e expr) where expr->#f */
		    goto START;
		  }
		  
		  
		case OP_PAIR_C:
		case HOP_PAIR_C:
		  {
		    s7_pointer s;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_pair(s)) break; /* this used to check is_integer(cadr(code)) but surely an error is correct if s is a pair? */
		    sc->value = list_ref_1(sc, s, cadr(code));
		    goto START;
		  }
		  
		  
		case OP_PAIR_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_PAIR_A:
		  {
		    s7_pointer s, x;
		    s = find_symbol_checked(sc, car(code));
		    if (!is_pair(s)) break;
		    x = c_call(cdr(code))(sc, cadr(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_checked(sc, car(code));
		    if (!is_pair(s)) break;
		    ind = find_symbol_checked(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_checked(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;
		    c = find_symbol_checked(sc, car(code));
		    if (!is_c_object(c)) break;
		    sc->value = (*(c_object_ref(c)))(sc, c, cdr(code));
		    goto START;
		  }
		  
		  
		case OP_C_OBJECT_A:
		  if (!indirect_cq_function_is_ok(sc, cadr(code))) break;
		case HOP_C_OBJECT_A:
		  {
		    s7_pointer c;
		    c = find_symbol_checked(sc, car(code));
		    if (!is_c_object(c)) break;
		    set_car(sc->t1_1, c_call(cdr(code))(sc, cadr(code)));
		    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;
		    c = find_symbol_checked(sc, car(code));
		    if (!is_c_object(c)) break;
		    set_car(sc->t1_1, find_symbol_checked(sc, cadr(code)));
		    sc->value = (*(c_object_ref(c)))(sc, c, sc->t1_1);
		    goto START;
		  }
		  
		default:
		  fprintf(stderr, "bad op in opt_eval: op %u, is_opt: %d, %s\n", optimize_op(code), is_optimized(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.
	       */
#if DEBUGGING
	      /* we hit this in zauto (cdr-constants ...) h_vector_s|c (there is no difference here between hop_ and op_)
	       */
	      if ((is_h_optimized(sc->code)) &&
		  (optimize_op(sc->code) != HOP_VECTOR_C) &&
		  (optimize_op(sc->code) != HOP_VECTOR_S))
		fprintf(stderr, "%s[%d]: clearing %s in %s\n", __func__, __LINE__, opt_names[optimize_op(sc->code)], DISPLAY(sc->code));
#endif
	      clear_all_optimizations(sc, code);
	      /* and fall into the normal evaluator */
	    }
	  
	  /* fprintf(stderr, "trail: %s\n", DISPLAY(sc->code)); */
	  {
	    s7_pointer code, carc;
	    code = sc->code;
	    
	    if (is_pair(code))
	      {

#if WITH_PROFILE
		profile(sc, code);
#endif
		set_current_code(sc, code);
		carc = car(code);
		
		if (typesflag(carc) == SYNTACTIC_TYPE)
		  {
		    set_syntactic_pair(code);      /* leave other bits (T_LINE_NUMBER) intact */
		    set_car(code, syntax_symbol(slot_value(initial_slot(carc)))); /* clear possible optimization confusion */
		    sc->op = (opcode_t)symbol_syntax_op(car(code));
		    pair_set_syntax_op(code, sc->op);
		    sc->code = cdr(code);
		    goto START_WITHOUT_POP_STACK;
		  }
		
		/* -------------------------------------------------------------------------------- */
		/* trailers */
		if (is_symbol(carc))
		  {
		    /* car is a symbol, sc->code a list */
		    sc->value = find_global_symbol_checked(sc, carc);
		    sc->code = cdr(code);
		    /* 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 but that list can be circular: carc: #1=(#1# #1#)!
			 *   and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff
			 */
			if (sc->stack_end >= sc->stack_resize_trigger)
			  check_for_cyclic_code(sc, code);
			push_stack(sc, OP_EVAL_ARGS, sc->nil, cdr(code));
			if (typesflag(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_symbol) &&        /* ('and #f) */
				((!is_pair(cdr(carc))) ||          /* ((quote . #\h) (2 . #\i)) ! */
				 (is_syntactic(cadr(carc)))))
			      return(apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)));
			    sc->op = (opcode_t)symbol_syntax_op(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 = _NFre(carc);
			sc->code = cdr(code);
			/* drop into OP_EVAL_ARGS */
		      }
		  }
	      }
	    else /* sc->code is not a pair */
	      {
		if (is_symbol(code))
		  {
		    sc->value = find_symbol_checked(sc, code);
		    pop_stack(sc);
		    if (sc->op != OP_EVAL_ARGS)
		      goto START_WITHOUT_POP_STACK;
		    /* drop into OP_EVAL_ARGS */
		  }
		else
		  {
		    /* sc->code is not a pair or a symbol */
		    sc->value = _NFre(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 */
		  sc->args = copy_list_with_arglist_error(sc, 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)) */
	      if (!is_syntax(sc->value))
		eval_error(sc, "attempt to evaluate: ~A?", sc->code);
	      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);
	  
	  sc->args = sc->nil;
	  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;
	    new_cell(sc, x, T_PAIR);
	    new_cell_no_check(sc, y, T_PAIR);
	    set_car(x, sc->code);
	    set_cdr(x, sc->args);
	    set_car(y, sc->value);
	    set_cdr(y, x);
	    sc->args = safe_reverse_in_place(sc, y);
	    sc->code = pop_op_stack(sc);
	    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);
	    new_cell(sc, x, T_PAIR);
	    set_car(x, sc->value);
	    set_cdr(x, sc->args);
	    if (!is_null(sc->args))
	      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_2:
	  /* from HOP_SAFE_C_SP||CP|QP, handled like P_1 case above
	   *   primarily involves generators: (outa i (nrcos gen)) etc
	   */
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	case OP_EVAL_ARGS_P_2_MV:
	  sc->args = cons(sc, sc->args, sc->value);
	  sc->code = c_function_base(opt_cfunc(sc->code));
	  goto APPLY;
	  
	  
	case OP_EVAL_ARGS_SSP_1:
	  /* from HOP_SAFE_C_SSP */
	  set_car(sc->t3_3, sc->value);
	  set_car(sc->t3_1, find_symbol_checked(sc, cadr(sc->code)));
	  set_car(sc->t3_2, find_symbol_checked(sc, caddr(sc->code)));
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	case OP_EVAL_ARGS_SSP_MV:
	  sc->args = cons(sc, find_symbol_checked(sc, cadr(sc->code)), cons(sc, find_symbol_checked(sc, caddr(sc->code)), sc->value));
	  sc->code = c_function_base(opt_cfunc(sc->code));
	  goto APPLY;
	  
	  
	case OP_EVAL_ARGS_P_3:
	  set_car(sc->t2_2, find_symbol_checked(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.
	   */
	  set_car(sc->t2_1, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	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, find_symbol_checked(sc, caddr(sc->code)), sc->w);
	  sc->code = c_function_base(opt_cfunc(sc->code));
	  goto APPLY;
	  
	  
	case OP_EVAL_ARGS_P_4:
	  set_car(sc->t2_1, sc->value);
	  set_car(sc->t2_2, sc->args);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	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(opt_cfunc(sc->code));
	  goto APPLY; /* (define (hi) (log (values 1 2) 3)) ? */
	  
	  
	case OP_SAFE_C_ZC_1:
	  set_car(sc->t2_1, sc->value);
	  set_car(sc->t2_2, sc->args);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	case OP_SAFE_C_SZ_1:
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	case OP_SAFE_C_SZ_SZ:
	  /* S_opSZq actually, in (nominal second, only actual) SZ, S=args, Z=value,
	   *   SZ from the SP combiner for SZ
	   */
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  set_car(sc->t2_2, c_call(caddr(sc->code))(sc, sc->t2_1));
	  set_car(sc->t2_1, find_symbol_checked(sc, cadr(sc->code)));
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	case OP_SAFE_C_ZA_1:
	  set_car(sc->t2_2, c_call(cddr(sc->code))(sc, caddr(sc->code)));
	  set_car(sc->t2_1, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	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:
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	  
	case OP_SAFE_C_ZAA_1:
	  set_car(sc->a3_1, sc->value);
	  set_car(sc->a3_2, c_call(cddr(sc->code))(sc, caddr(sc->code)));
	  set_car(sc->a3_3, c_call(cdddr(sc->code))(sc, cadddr(sc->code)));
	  sc->value = c_call(sc->code)(sc, sc->a3_1);
	  break;
	  
	  
	case OP_SAFE_C_AZA_1:
	  set_car(sc->t3_3, c_call(cdddr(sc->code))(sc, cadddr(sc->code)));
	  set_car(sc->t3_2, sc->value);
	  set_car(sc->t3_1, sc->args);
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	case OP_SAFE_C_SSZ_1:
	  set_car(sc->t3_1, sc->args);
	  set_car(sc->t3_3, sc->value);
	  set_car(sc->t3_2, find_symbol_checked(sc, caddr(sc->code)));
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	case OP_SAFE_C_AAZ_1:
	  set_car(sc->t3_1, pop_op_stack(sc));
	  set_car(sc->t3_2, sc->args);
	  set_car(sc->t3_3, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	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:
	  set_car(sc->a3_1, pop_op_stack(sc));
	  set_car(sc->a3_2, sc->value);
	  set_car(sc->a3_3, c_call(cdddr(sc->code))(sc, cadddr(sc->code)));
	  sc->value = c_call(sc->code)(sc, sc->a3_1);
	  break;
	  
	  
	case OP_SAFE_C_ZAZ_1:
	  push_op_stack(sc, sc->value);
	  push_stack(sc, OP_SAFE_C_ZAZ_2, c_call(cddr(sc->code))(sc, caddr(sc->code)),  sc->code);
	  sc->code = cadddr(sc->code);
	  goto OPT_EVAL;
	  
	  
	case OP_SAFE_C_ZAZ_2:
	  set_car(sc->t3_1, pop_op_stack(sc));
	  set_car(sc->t3_2, sc->args);
	  set_car(sc->t3_3, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	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:
	  set_car(sc->t3_1, sc->args);
	  set_car(sc->t3_2, pop_op_stack(sc));
	  set_car(sc->t3_3, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  
	  
	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:
	  set_car(sc->t3_1, sc->args);
	  set_car(sc->t3_2, pop_op_stack(sc));
	  set_car(sc->t3_3, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t3_1);
	  break;
	  

	case OP_SAFE_C_opSq_P_1:
	  /* this is the no-multiple-values case */
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	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(opt_cfunc(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 = find_symbol_checked(sc, val);
	    
	    new_cell(sc, x, T_PAIR);
	    new_cell_no_check(sc, y, T_PAIR);
	    set_car(x, sc->value);
	    set_cdr(x, sc->args);
	    set_car(y, val);
	    set_cdr(y, x);
	    sc->args = safe_reverse_in_place(sc, y);
	    sc->code = pop_op_stack(sc);
	    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
	   *
	   * (#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, T_PAIR);
	    set_car(x, sc->value);
	    set_cdr(x, sc->args);
	    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, T_PAIR);
	    set_car(x, sc->value);
	    set_cdr(x, sc->args);
	    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) */
	    {
	      s7_pointer car_code;
	      
	    EVAL_ARGS_PAIR:
	      car_code = car(sc->code);
	      
	      /* switch statement here is much slower for some reason */
	      if (is_pair(car_code))
		{
		  if (sc->stack_end >= sc->stack_resize_trigger)
		    check_for_cyclic_code(sc, sc->code);

		  /* all 3 of these push_stacks can result in stack overflow, see above 64065 */
		  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 (is_symbol(car_code))
		    sc->value = find_symbol_checked(sc, car_code);
		  else sc->value = _NFre(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);
		      if (is_pair(car_code))
			{
			  if (sc->stack_end >= sc->stack_resize_trigger)
			    check_for_cyclic_code(sc, sc->code);

			  push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value);
			  sc->code = car_code;
			  goto EVAL;
			}
		      
		      /* get the last arg */
		      if (is_symbol(car_code))
			val = find_symbol_checked(sc, car_code);
		      else val = car_code;
		      sc->temp4 = val;
		      
		      /* get the current arg, which is not a list */
		      sc->code = pop_op_stack(sc);
		      new_cell(sc, x, T_PAIR);
		      new_cell_no_check(sc, y, T_PAIR);
		      set_car(x, sc->value);
		      set_cdr(x, sc->args);
		      set_car(y, val);
		      set_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, T_PAIR);
		      set_car(x, sc->value);
		      set_cdr(x, sc->args);
		      sc->args = x;
		      goto EVAL_ARGS_PAIR;
		    }
		}
	      else
		{
		  /* here we've reached the last arg (sc->code == nil), it is not a pair */
		  s7_pointer x, val;
		  
		  if (!is_null(cdr(sc->code)))
		    improper_arglist_error(sc);
		  
		  sc->code = pop_op_stack(sc);
		  if (is_symbol(car_code))
		    val = find_symbol_checked(sc, car_code); /* this has to precede the set_type below */
		  else val = car_code;
		  sc->temp4 = val;
		  new_cell(sc, x, T_PAIR);
		  set_car(x, val);
		  set_cdr(x, sc->args);
		  
		  if (!is_null(sc->args))
		    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);
		  /* 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.
		   */
		}
	    }
	  
	  /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower.
	   *   the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead,
	   *   and the function-local overhead currently otherwise 0 (I assume because the compiler can simply plug it in here).
	   */
	APPLY:
	  /* fprintf(stderr, "apply %s to %s\n", DISPLAY(sc->code), DISPLAY(sc->args)); */
	  switch (type(sc->code))
	    {
	    case T_C_FUNCTION:          apply_c_function(sc);           goto START;
	    case T_C_ANY_ARGS_FUNCTION: apply_c_any_args_function(sc);  goto START;
	    case T_C_FUNCTION_STAR:     apply_c_function_star(sc);      goto START;
	    case T_C_OPT_ARGS_FUNCTION: apply_c_opt_args_function(sc);  goto START;
	    case T_C_RST_ARGS_FUNCTION: apply_c_rst_args_function(sc);  goto START;
	    case T_C_MACRO:  	        apply_c_macro(sc);	        goto EVAL;
	    case T_CONTINUATION:        apply_continuation(sc);         goto START;
	    case T_GOTO:	        call_with_exit(sc);	        goto START;
	    case T_C_OBJECT:	        apply_c_object(sc);	        goto START;
	    case T_INT_VECTOR:
	    case T_FLOAT_VECTOR:
	    case T_VECTOR: 	        apply_vector(sc);	        goto START;
	    case T_STRING:	        apply_string(sc);	        goto START;
	    case T_HASH_TABLE:	        apply_hash_table(sc);           goto START;
	    case T_ITERATOR:	        apply_iterator(sc);	        goto START;	      
	    case T_LET:	                apply_let(sc);	                goto START;
	    case T_SYNTAX:	        apply_syntax(sc);	        goto START_WITHOUT_POP_STACK;
	    case T_PAIR:	        
	      if (apply_pair(sc) == goto_APPLY) goto APPLY; 
	      goto START;

	    case T_MACRO:
	      if (is_expansion(sc->code))
		push_stack(sc, OP_EXPANSION, sc->nil, sc->nil);
	      else push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
	      new_frame(sc, closure_let(sc->code), sc->envir);
	      apply_lambda(sc);
	      goto BEGIN1;
	      
	    case T_BACRO: 
	      push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
	      new_frame(sc, sc->envir, sc->envir);       /* like let* -- we'll be adding macro args, so might as well sequester things here */
	      apply_lambda(sc);
	      goto BEGIN1;
	      
	    case T_CLOSURE:
	      check_stack_size(sc);
	      new_frame(sc, closure_let(sc->code), sc->envir);
	      apply_lambda(sc);
	      goto BEGIN1;
	      
	    case T_MACRO_STAR:
	      push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
	      new_frame(sc, closure_let(sc->code), sc->envir);
	      if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
	      goto BEGIN1;
	      
	    case T_BACRO_STAR:
	      push_stack(sc, OP_EVAL_MACRO, sc->nil, sc->nil);
	      new_frame(sc, sc->envir, sc->envir);
	      if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
	      goto BEGIN1;
	      
	    case T_CLOSURE_STAR:
	      check_stack_size(sc);
	      sc->envir = new_frame_in_env(sc, closure_let(sc->code));
	      if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
	      goto BEGIN1;

	    default:
	      return(apply_error(sc, sc->code, sc->args));
	    }
	  
	  
	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)) */
	  
	  
	case OP_LAMBDA_STAR_DEFAULT:
	  /* sc->args is the current closure arg list position, sc->value is the default expression's value */
	  slot_set_value(sc->args, sc->value);
	  sc->args = slot_pending_value(sc->args);
	  if (lambda_star_default(sc) == goto_EVAL) goto EVAL;
	  pop_stack_no_op(sc);
	  sc->code = closure_body(sc->code); 
	  goto BEGIN1;
	  
	  
	case OP_MACROEXPAND_1:
	  sc->args = cdar(sc->code);
	  sc->code = sc->value;
	  goto MACROEXPAND;
	  
	case OP_MACROEXPAND:
	  /* mimic APPLY above, but don't push OP_EVAL_MACRO or OP_EXPANSION
	   *   (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3))
	   */
	  if ((!is_pair(sc->code)) ||
	      (!is_pair(car(sc->code))))
	    eval_error(sc, "macroexpand argument is not a macro call: ~A", sc->code);
	  if (!is_null(cdr(sc->code)))
	    eval_error(sc, "macroexpand: too many arguments: ~A", sc->code);
	  
	  if (is_pair(caar(sc->code)))                            /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
	    {
	      push_stack(sc, OP_MACROEXPAND_1, sc->nil, sc->code);
	      sc->code = caar(sc->code);
	      goto EVAL;
	    }
	  
	  sc->args = cdar(sc->code);
	  if (!is_symbol(caar(sc->code)))
	    eval_error(sc, "macroexpand argument is not a macro call: ~A", sc->code);
	  sc->code = find_symbol_checked(sc, caar(sc->code));
	  
	MACROEXPAND:
	  switch (type(sc->code))
	    {
	    case T_MACRO:
	      new_frame(sc, closure_let(sc->code), sc->envir);
	      apply_lambda(sc);
	      goto BEGIN1;
	      
	    case T_BACRO:
	      new_frame(sc, sc->envir, sc->envir);
	      apply_lambda(sc);
	      goto BEGIN1;
	      
	    case T_MACRO_STAR:
	      new_frame(sc, closure_let(sc->code), sc->envir);
	      if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
	      goto BEGIN1;
	      
	    case T_BACRO_STAR:
	      new_frame(sc, sc->envir, sc->envir);
	      if (apply_lambda_star(sc) == goto_EVAL) goto EVAL;
	      goto BEGIN1;
	      
	    case T_C_MACRO:
	      sc->value = c_macro_call(sc->code)(sc, sc->args);
	      goto START;
	    }
	  eval_error(sc, "macroexpand argument is not a macro call: ~A", sc->args);
	  
	  
	case OP_QUOTE:
	case OP_QUOTE_UNCHECKED:
	  /* I think a quoted list in another list can be applied to a function, come here and
	   *   be changed to unchecked, set-cdr! or something clobbers the argument so we get
	   *   here on the next time around with the equivalent of (quote . 0) so unchecked
	   *   quote needs more thought.
	   */
	  check_quote(sc);
	  sc->value = car(sc->code);
	  break;
	  
	  
	case OP_DEFINE_FUNCHECKED:
	  define_funchecked(sc);
	  break;
	  
	case OP_DEFINE_CONSTANT1:
	  sc->code = car(sc->code);
	  if (is_pair(sc->code)) sc->code = car(sc->code); /* (define-constant (ex3 a)...) */
	  if (is_symbol(sc->code))
	    set_immutable(sc->code);
	  break;
	  
	case OP_DEFINE_CONSTANT:
	  if ((!is_pair(sc->code)) || (!is_pair(cdr(sc->code)))) /* (define-constant) */
	    eval_error(sc, "define-constant: not enough arguments: ~S", sc->code);

	  if ((is_symbol(car(sc->code))) &&                /* (define-constant abs abs): "abs will not be touched" */
	      (car(sc->code) == cadr(sc->code)) &&
	      (symbol_id(car(sc->code)) == 0) &&           /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */
	      (is_null(cddr(sc->code))))
	    {
	      set_immutable(car(sc->code));
	      sc->value = find_symbol_checked(sc, car(sc->code));
	      goto START;
	    }
	  push_stack(sc, OP_DEFINE_CONSTANT1, sc->nil, sc->code);
	  
	case OP_DEFINE_STAR:
	case OP_DEFINE:
	  check_define(sc);
	  
	case OP_DEFINE_CONSTANT_UNCHECKED:
	case OP_DEFINE_STAR_UNCHECKED:
	case OP_DEFINE_UNCHECKED:
	  if (define_unchecked_ex(sc) == goto_EVAL) goto EVAL;

	case OP_DEFINE1:
	  if (define1_ex(sc) == goto_APPLY) goto APPLY;
	  
	case OP_DEFINE_WITH_ACCESSOR:
	  define2_ex(sc);
	  break;
	  
	  
	  /* -------------------------------- 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
	   * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0))
	   */
	  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 = find_symbol_checked(sc, caar(sc->code));
	    val = c_call(cdr(sc->code))(sc, cadr(sc->code)); /* this call can step on sc->Tx_x */
	    set_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)))
	      set_car(sc->t2_1, find_symbol_checked(sc, cadar(sc->code)));
	    set_car(sc->t2_2, val);
	    sc->value = c_function_call(c_function_setter(obj))(sc, sc->t2_1);
	  }
	  break;
	  
	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;
	  
	    
	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) */
	  sc->temp8 = sc->value;
	  if (set_pair_p_3(sc, find_symbol(sc, caar(sc->code)), c_call(cadar(sc->code))(sc, cdadar(sc->code)), sc->temp8))
	    goto APPLY;
	  break;
	    
	    
	case OP_SET_PAIR_C:        /* ([set!] (name (+ len 1)) #\r) */
	  {
	    s7_pointer value;
	    value = cadr(sc->code);
	    if (is_symbol(value))
	      value = find_symbol_checked(sc, value);
	    if (set_pair_p_3(sc, find_symbol(sc, caar(sc->code)), c_call(cadar(sc->code))(sc, cdadar(sc->code)), value))
	      goto APPLY;
	  }
	  break;
	    
	    
	case OP_SET_LET_S:       /* (set! (*s7* 'print-length) i) */
	  if (set_pair_p_3(sc, find_symbol(sc, caar(sc->code)), cadr(cadar(sc->code)), find_symbol_checked(sc, cadr(sc->code))))
	    goto APPLY;
	  break;
	    
	    
	case OP_SET_LET_ALL_X:  /* (set! (hook 'result) 123) or (set! (H 'c) 32) */
	  if (set_pair_p_3(sc, find_symbol(sc, caar(sc->code)), cadr(cadar(sc->code)), c_call(cdr(sc->code))(sc, cadr(sc->code))))
	    goto APPLY;
	  break;
	    
	    
	case OP_SET_PAIR_ZA:    /* unknown setter pair, but value is easy */
	  sc->value = c_call(cdr(sc->code))(sc, cadr(sc->code));
	  /* fall through */
	    
	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 second can be a quoted symbol) to get here)
	     *   the inner list is a proper list, with no embedded list at car.
	     */
	    s7_pointer arg, value;
	    value = sc->value;
	    arg = cadar(sc->code);
	    if (is_symbol(arg))
	      arg = find_symbol_checked(sc, arg);
	    else
	      {
		if (is_pair(arg))
		  arg = cadr(arg); /* can only be (quote ...) in this case */
	      }
	    if (set_pair_p_3(sc, find_symbol(sc, caar(sc->code)), arg, value))
	      goto APPLY;
	  }
	  break;
	    
	    
	case OP_SET_PAIR:
	  {
	    /* ([set!] (procedure-setter g) s) or ([set!] (str 0) #\a) */
	    s7_pointer obj, arg, value;
	    value = cadr(sc->code);
	    if (is_symbol(value))
	      value = find_symbol_checked(sc, value);
	    
	    arg = cadar(sc->code);
	    if (is_symbol(arg))
	      arg = find_symbol_checked(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 (set_pair_p_3(sc, obj, arg, value))
	      goto APPLY;
	  }
	  break;

	  
	  /* 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! (mus-clipping) #f) */
	  set_pws_ex(sc);
	  break;
	  
	case OP_INCREMENT_1:
	  increment_1_ex(sc);
	  break;
	  
	case OP_DECREMENT_1:
	  decrement_1_ex(sc);
	  break;
	  
        #define SET_CASE(Op, Code)						\
	  case Op:							\
	    {								\
	      s7_pointer lx;						\
	      lx = find_symbol(sc, _TSet(car(sc->code)));		\
	      if (!is_slot(lx)) eval_type_error(sc, "set! ~A: unbound variable", sc->code); \
	      Code;							\
	      sc->value = slot_value(lx);				\
	      goto START;						\
	    }
	  
	    SET_CASE(OP_SET_SYMBOL_C, slot_set_value(lx, cadr(sc->code)))
	    
	    SET_CASE(OP_SET_SYMBOL_Q, slot_set_value(lx, cadr(cadr(sc->code))))
	    
	    SET_CASE(OP_SET_SYMBOL_A, slot_set_value(lx, c_call(cdr(sc->code))(sc, cadr(sc->code))))
	    
	    SET_CASE(OP_SET_SYMBOL_S, slot_set_value(lx, find_symbol_checked(sc, cadr(sc->code))))
	    
	    SET_CASE(OP_SET_CONS, slot_set_value(lx, cons(sc, find_symbol_checked(sc, opt_sym2(sc->code)), slot_value(lx))))  /* ([set!] bindings (cons v bindings)) */
	    
	    SET_CASE(OP_SET_SYMBOL_opCq, slot_set_value(lx, c_call(cadr(sc->code))(sc, opt_pair2(sc->code))))
	    
	    /* here we know the symbols do not have accessors, at least at optimization time */
	    SET_CASE(OP_SET_SYMBOL_opSq,
		     do {						\
		       set_car(sc->t1_1, find_symbol_checked(sc, opt_sym2(sc->code))); \
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t1_1)); \
		     } while (0))
	    
	    SET_CASE(OP_SET_SYMBOL_opSSq,
		     do {						\
		       set_car(sc->t2_1, find_symbol_checked(sc, car(opt_pair2(sc->code)))); \
		       set_car(sc->t2_2, find_symbol_checked(sc, cadr(opt_pair2(sc->code)))); \
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
		     } while (0))
	    
	    SET_CASE(OP_SET_SYMBOL_opSSSq,
		     do {						\
		       set_car(sc->t3_1, find_symbol_checked(sc, car(opt_pair2(sc->code)))); \
		       set_car(sc->t3_2, find_symbol_checked(sc, opt_sym1(opt_pair2(sc->code)))); \
		       set_car(sc->t3_3, find_symbol_checked(sc, opt_sym2(opt_pair2(sc->code)))); \
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t3_1)); \
		     } while (0))
	    
	    SET_CASE(OP_INCREMENT_SS,                                       /* ([set!] x (+ x i)) */
		     do {						\
		       set_car(sc->t2_1, slot_value(lx));		\
		       set_car(sc->t2_2, find_symbol_checked(sc, cadr(opt_pair2(sc->code)))); \
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
		     } while (0))
	    
	    SET_CASE(OP_INCREMENT_SSS,                                      /* ([set!] x (+ x y z)) -- nearly always involves reals */
		     do {						\
		       s7_pointer x1; s7_pointer x2; s7_pointer x3;	\
		       x1 = slot_value(lx);				\
		       x2 = find_symbol_checked(sc, opt_sym1(opt_pair2(sc->code))); \
		       x3 = find_symbol_checked(sc, opt_sym2(opt_pair2(sc->code))); \
		       if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) \
			 slot_set_value(lx, make_real(sc, real(x1) + real(x2) + real(x3))); \
		       else {						\
		         set_car(sc->t3_1, x1); set_car(sc->t3_2, x2); set_car(sc->t3_3, x3); \
			 slot_set_value(lx, global_add(sc, sc->t3_1));	\
		       }						\
		     } while (0))
	    
	    SET_CASE(OP_INCREMENT_SA,
		     do {						\
		       s7_pointer arg;					\
		       arg = opt_pair2(sc->code);				\
		       set_car(sc->t2_2, c_call(arg)(sc, car(arg)));	\
		       set_car(sc->t2_1, slot_value(lx));		\
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->t2_1)); \
		     } while (0))
	    
	    SET_CASE(OP_INCREMENT_SAA,                                      /* (set! sum (+ sum (expt k i) (expt (- k) i))) -- oops */
		     do {					\
		       s7_pointer arg;					\
		       arg = opt_pair2(sc->code); /* cddr(value) */		\
		       set_car(sc->a3_3, c_call(cdr(arg))(sc, cadr(arg))); \
		       set_car(sc->a3_2, c_call(arg)(sc, car(arg)));	\
		       set_car(sc->a3_1, slot_value(lx));		\
		       slot_set_value(lx, c_call(cadr(sc->code))(sc, sc->a3_1)); \
		     } while (0))
	    
	    
	case OP_SET_SAFE:
	  {
	    s7_pointer lx;
	    lx = find_symbol(sc, _TSet(sc->code)); /* SET_CASE above looks for car(sc->code) */
	    if (!is_slot(lx)) eval_type_error(sc, "set! ~A: unbound variable", sc->code);
	    slot_set_value(lx, sc->value);
	    sc->value = slot_value(lx);
	  }
	  break;
	  
	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;
	  
	  
	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_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 = opt_pair2(sc->code); /* caddr(cadr(sc->code)); */
		goto OPT_EVAL;
	      }
	    eval_type_error(sc, "set! ~A: unbound variable", sc->code);
	  }
	  
	case OP_INCREMENT_SZ_1:
	  set_car(sc->t2_1, slot_value(sc->args));
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(cadr(sc->code))(sc, sc->t2_1);
	  slot_set_value(sc->args, sc->value);
	  break;
	  
	  
	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_symbol, 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_function);
		      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;
		}
	    }
	  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_function);
		      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 */
	    {
	      int choice;
	      choice = set_pair_ex(sc);
	      if (choice == goto_EVAL) goto EVAL;
	      if (choice == goto_START) goto START;
	      if (choice == goto_APPLY) goto APPLY;
	      goto EVAL_ARGS;
	    }
	  /* fall through */
	  
	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 = find_symbol_checked(sc, x);
	    else sc->value = _NFre(x);
	    sc->code = car(sc->code);
	  }
	  
	  
	case OP_SET1:
	  {
	    s7_pointer lx;
	    /* if unbound variable hook here, we need the binding, not the current value */
	    lx = find_symbol(sc, _TSet(sc->code));
	    if (is_slot(lx))
	      {
		if (slot_has_accessor(lx))
		  {
		    s7_pointer func;
		    func = slot_accessor(lx);
		    if (is_procedure_or_macro(func))
		      {
			if (is_c_function(func))
			  {
			    set_car(sc->t2_1, sc->code);
			    set_car(sc->t2_2, sc->value);
			    sc->value = c_function_call(func)(sc, sc->t2_1);
			    if (sc->value == sc->error_symbol) /* backwards compatibility... (but still used I think in g_features_set) */
			      return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(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, lx); /* op, args, code */
			    sc->code = func;
			    goto APPLY;
			  }
		      }
		  }
		else
		  {
		    if (is_syntax(slot_value(lx)))
		      eval_error(sc, "can't set! ~A", sc->code);
		  }
		slot_set_value(lx, sc->value);
		goto START;
	      }
	    eval_type_error(sc, "set! ~A: unbound variable", sc->code);
	  }
	  
	case OP_SET_WITH_ACCESSOR:
	  if (sc->value == sc->error_symbol) /* backwards compatibility... */
	    return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't set ~S"), sc->args)));
	  slot_set_value(sc->code, sc->value);
	  break;

	case OP_SET_WITH_LET_1:
	  /* here sc->value is the new value for the settee, args has the (as yet unevaluated) let and settee-expression. */
	  /* fprintf(stderr, "with_let_1: %s %s %s\n", DISPLAY(sc->value), DISPLAY(sc->code), DISPLAY(sc->args)); */
	  if (is_symbol(car(sc->args)))
	    {
	      s7_pointer p;
	      p = list_2(sc, cadr(sc->args), sc->value);
	      sc->value = find_symbol_checked(sc, car(sc->args));
	      sc->args = p;
	      /* fall through */
	    }
	  else
	    {
	      sc->code = car(sc->args);
	      sc->args = list_2(sc, cadr(sc->args), sc->value);
	      push_stack(sc, OP_SET_WITH_LET_2, sc->args, sc->code);
	      goto EVAL;
	    }

	case OP_SET_WITH_LET_2:
	  /* fprintf(stderr, "with_let_2: value: %s, code: %s, args: %s\n", DISPLAY(sc->value), DISPLAY(sc->code), DISPLAY(sc->args)); */
	  if (is_symbol(car(sc->args)))
	    {
	      let_set_1(sc, sc->value, car(sc->args), cadr(sc->args));
	      sc->value = cadr(sc->args);
	      goto START;
	    }

	  /* avoid double evaluation */
	  if ((is_symbol(cadr(sc->args))) ||
	      (is_pair(cadr(sc->args))))
	    sc->code = cons(sc, sc->set_symbol, list_2(sc, car(sc->args), list_2(sc, sc->quote_symbol, cadr(sc->args))));
	  else sc->code = cons(sc, sc->set_symbol, sc->args);
	  activate_let(sc);  /* this activates sc->value, so the set! will happen in that environment */
	  goto EVAL;

	  
	  
	  /* -------------------------------- IF -------------------------------- */
	case OP_IF:
	  check_if(sc);
	  
	case OP_IF_UNCHECKED:
	  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 = find_symbol_checked(sc, sc->code);
	  else sc->value = sc->code;
	  break;
	  
	  
        #define IF_CASE(Op, Code)						\
	  case Op ## _P:   Code {sc->code = cadr(sc->code); goto EVAL;} else {sc->value = sc->unspecified; goto START;} \
	  case Op ## _P_P: Code {sc->code = cadr(sc->code); goto EVAL;} else {sc->code = caddr(sc->code); goto EVAL;}
	  
	  IF_CASE(OP_IF_S, if (is_true(sc, find_symbol_checked(sc, car(sc->code)))))
	    
	  IF_CASE(OP_IF_NOT_S, if (is_false(sc, find_symbol_checked(sc, opt_sym2(sc->code)))))
	    
	  IF_CASE(OP_IF_A, if (is_true(sc, c_call(sc->code)(sc, car(sc->code)))))
	    
	  IF_CASE(OP_IF_CC, if (is_true(sc, c_call(car(sc->code))(sc, opt_pair2(sc->code)))))
	    
	  IF_CASE(OP_IF_IS_PAIR, if (is_pair(find_symbol_checked(sc, opt_sym2(sc->code)))))
	    
	  IF_CASE(OP_IF_IS_SYMBOL, if (is_symbol(find_symbol_checked(sc, opt_sym2(sc->code)))))
	    
	  IF_CASE(OP_IF_CS, set_car(sc->t1_1, find_symbol_checked(sc, opt_sym2(sc->code))); \
		    if (is_true(sc, c_call(car(sc->code))(sc, sc->t1_1))))
	    
	  IF_CASE(OP_IF_CSQ, set_car(sc->t2_1, find_symbol_checked(sc, opt_sym3(sc->code))); \
		    set_car(sc->t2_2, opt_con2(sc->code));		\
		    if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
	    
	  IF_CASE(OP_IF_CSS, set_car(sc->t2_1, find_symbol_checked(sc, opt_sym3(sc->code))); \
		    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym2(sc->code)));
		    if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
	    
	  IF_CASE(OP_IF_CSC, set_car(sc->t2_1, find_symbol_checked(sc, opt_sym3(sc->code))); \
		    set_car(sc->t2_2, opt_con2(sc->code));		\
		    if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))
	    
	  IF_CASE(OP_IF_S_opCq, set_car(sc->t2_2, c_call(opt_pair2(sc->code))(sc, cdr(opt_pair2(sc->code)))); \
		    set_car(sc->t2_1, find_symbol_checked(sc, opt_sym3(sc->code))); \
	            if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))))

	  IF_CASE(OP_IF_opSSq, {s7_pointer args; s7_pointer val1;	\
		args = opt_pair2(sc->code);					\
		val1 = find_symbol_checked(sc, cadr(args));		\
		set_car(sc->t2_2, find_symbol_checked(sc, opt_sym3(sc->code))); \
		set_car(sc->t2_1, val1);				\
		set_car(sc->t1_1, c_call(args)(sc, sc->t2_1));}		\
	        if (is_true(sc, c_call(car(sc->code))(sc, sc->t1_1))))
	    
	  IF_CASE(OP_IF_AND2, if ((is_true(sc, c_call(opt_pair2(sc->code))(sc, car(opt_pair2(sc->code))))) && \
				    (is_true(sc, c_call(opt_and_2_test(sc->code))(sc, car(opt_and_2_test(sc->code)))))))
	    
	    
	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_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:
	  push_stack_no_args(sc, OP_IF_PP, opt_con2(sc->code));
	  sc->code = car(sc->code);
	  goto OPT_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_ANDP_P:
	  push_stack_no_args(sc, OP_IF_PP, cadr(sc->code));
	  sc->code = cdar(sc->code);
	  goto AND_P;
	  
	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:
	  push_stack_no_args(sc, OP_IF_PP, cadr(sc->code));
	  sc->code = cdar(sc->code);
	  goto OR_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_PP:
	  if (is_true(sc, sc->value))
	    goto EVAL;
	  sc->value = sc->unspecified;
	  break;
	  
	  
	case OP_IF_P_FEED:
	  /* actually cond right now: (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */
	  push_stack_no_args(sc, OP_IF_P_FEED_1, sc->code);
	  sc->code = caar(sc->code);
	  goto EVAL;
	  
	case OP_IF_P_FEED_1:
	  if (is_true(sc, sc->value))
	    {
	      if (is_multiple_value(sc->value))
		sc->code = cons(sc, opt_lambda2(sc->code), multiple_value(sc->value));
	      else
		{
		  new_frame_with_slot(sc, sc->envir, sc->envir, caadr(opt_lambda2(sc->code)), sc->value);
		  sc->code = caddr(opt_lambda2(sc->code));
		}
	      goto EVAL;
	    }
	  sc->value = sc->nil; /* since it's actually cond -- perhaps push as sc->args above */
	  break;
	  
	  
	case OP_WHEN:
	  check_when(sc);
	  
	case OP_WHEN_UNCHECKED:
	  push_stack_no_args(sc, OP_WHEN1, cdr(sc->code));
	  sc->code = car(sc->code);
	  goto EVAL;
	  
	case OP_WHEN1:
	  if (is_true(sc, sc->value)) goto BEGIN1;
	  sc->value = sc->unspecified;
	  break;
	  
	case OP_WHEN_S:
	  if (is_true(sc, find_symbol_checked(sc, car(sc->code))))
	    {
	      sc->code = cdr(sc->code);
	      goto BEGIN1;
	    }
	  sc->value = sc->unspecified;
	  break;
	  
	  
	case OP_UNLESS:
	  check_unless(sc);
	  
	case OP_UNLESS_UNCHECKED:
	  push_stack_no_args(sc, OP_UNLESS1, cdr(sc->code));
	  sc->code = car(sc->code);
	  goto EVAL;
	  
	case OP_UNLESS1:
	  if (is_false(sc, sc->value)) goto BEGIN1;
	  sc->value = sc->unspecified;
	  break;
	  
	case OP_UNLESS_S:
	  if (is_false(sc, find_symbol_checked(sc, car(sc->code))))
	    {
	      sc->code = cdr(sc->code);
	      goto BEGIN1;
	    }
	  sc->value = sc->unspecified;
	  break;
	  
	  
	case OP_SAFE_C_P_1:
	  set_car(sc->t1_1, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t1_1);
	  break;
	  
	  
	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 OP_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 (or maybe just collect the args and concatenate at the end?)
	   */
	  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 */
	  set_car(sc->t2_1, sc->args);
	  set_car(sc->t2_2, sc->value);
	  sc->value = c_call(sc->code)(sc, sc->t2_1);
	  break;
	  
	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);
	  sc->code = c_function_base(opt_cfunc(sc->code));
	  goto APPLY;
	  
	case OP_SAFE_C_PP_5:
	  /* 1 mv, 2, normal */
	  sc->args = s7_append(sc, sc->args, list_1(sc, sc->value));
	  sc->code = c_function_base(opt_cfunc(sc->code));
	  goto APPLY;
	  
	case OP_SAFE_C_PP_6:
	  /* both mv */
	  sc->args = s7_append(sc, sc->args, sc->value);
	  /*
	   * c_call(sc->code) here is g_add_2, but we have any number of args from a values call
	   *   the original (unoptimized) function is (hopefully) c_function_base(opt_cfunc(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(opt_cfunc(sc->code));
	  goto APPLY;
	  
	  
	case OP_C_P_1:
	  sc->value = c_call(sc->code)(sc, list_1(sc, sc->value));
	  break;
	  
	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(opt_cfunc(sc->code)); /* see comment above */
	  sc->args = copy_list(sc, sc->value);
	  goto APPLY;
	  
	  
	case OP_SAFE_CLOSURE_P_1:
	  sc->envir = old_frame_with_slot(sc, closure_let(opt_lambda(sc->code)), sc->value);
	  sc->code = closure_body(opt_lambda(sc->code));
	  goto BEGIN1;
	  
	case OP_CLOSURE_P_1:
	  /* sc->value is presumably the argument value */
	  check_stack_size(sc);
	  sc->code = opt_lambda(sc->code);
	  new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
	  sc->code = closure_body(sc->code);
	  goto BEGIN1;
	  
	case OP_CLOSURE_P_2:
	  /* here we got multiple values */
	  sc->code = opt_lambda(sc->code);
	  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));
	  break;
	  
	case OP_C_SP_2:
	  /* op_c_sp_1 -> mv case: (map + (values '(1 2 3) #(1 2 3))) */
	  sc->code = c_function_base(opt_cfunc(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 BEGIN1;
	  
	  
	case OP_NAMED_LET_NO_VARS:
	  new_frame(sc, sc->envir, sc->envir);
	  sc->args = make_closure(sc, sc->nil, cddr(sc->code), T_CLOSURE); /* sc->args is a temp here */
	  make_slot_1(sc, sc->envir, car(sc->code), sc->args);
	  sc->code = cddr(sc->code);
	  goto BEGIN1;
	  
	  
	case OP_LET_C:
	  /* one var, init is constant, incoming sc->code is '(((var val))...)! */
	  new_frame_with_slot(sc, sc->envir, sc->envir, opt_sym3(sc->code), opt_con2(sc->code));
	  sc->code = cdr(sc->code);
	  goto BEGIN1;
	  
	case OP_LET_S:
	  /* one var, init is symbol, incoming sc->code is '(((var sym))...) */
	  sc->value = find_symbol_checked(sc, opt_sym2(sc->code));
	  new_frame_with_slot(sc, sc->envir, sc->envir, opt_sym3(sc->code), sc->value);
	  sc->code = cdr(sc->code);
	  goto BEGIN1;
	  
	  
	case OP_LET_opSq:
	  {
	    s7_pointer binding;
	    binding = caar(sc->code);
	    set_car(sc->t1_1, find_symbol_checked(sc, opt_sym2(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_opSq_P:
	  {
	    s7_pointer binding;
	    binding = caar(sc->code);
	    set_car(sc->t1_1, find_symbol_checked(sc, opt_sym2(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 */
#if DEBUGGING
	  {
	    s7_pointer old_code, old_env; /* trying to define lots of Snd function safe -- they crash here if they aren't actually safe */
	    old_code = sc->code;          /*   so, add a bandage while I track them down... */
	    old_env = sc->envir;
	    sc->value = c_call(opt_pair2(sc->code))(sc, cdr(opt_pair2(sc->code)));
	    if ((sc->code != old_code) ||
		(sc->envir != old_env))
	      fprintf(stderr, "something changed: %s -> %s, %s -> %s\n",
		      DISPLAY(old_code), DISPLAY(sc->code),
		      DISPLAY(old_env), DISPLAY(sc->envir));
	    new_frame_with_slot(sc, sc->envir, sc->envir, opt_sym3(old_code), sc->value);
	    sc->code = cdr(old_code);
	    goto BEGIN1;
	  }
#else
	  sc->value = c_call(opt_pair2(sc->code))(sc, cdr(opt_pair2(sc->code)));
	  new_frame_with_slot(sc, sc->envir, sc->envir, opt_sym3(sc->code), sc->value);
	  sc->code = cdr(sc->code);
	  goto BEGIN1;
#endif
	  
	  
	case OP_LET_opSSq:  /* one var, init is safe_c_ss */
	  {
	    s7_pointer largs, in_val;
	    largs = opt_pair2(sc->code);                                 /* cadr(caar(sc->code)); */
	    in_val = find_symbol_checked(sc, cadr(largs));
	    set_car(sc->t2_2, find_symbol_checked(sc, opt_sym3(sc->code))); /* caddr(largs)); */
	    set_car(sc->t2_1, in_val);
	    sc->value = c_call(largs)(sc, sc->t2_1);
	    new_frame_with_slot(sc, sc->envir, sc->envir, caaar(sc->code), sc->value);
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_LET_Z:
	  push_stack(sc, OP_LET_Z_1, opt_sym2(cdr(sc->code)), cadr(sc->code));
	  sc->code = opt_pair2(sc->code);
	  goto OPT_EVAL;
	  
	case OP_LET_Z_1:
	  new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value);
	  goto EVAL;
	  
	  
	case OP_LET_ONE:
	  /* one var */
	  {
	    s7_pointer p;
	    p = caar(sc->code);
	    sc->value = cadr(p);
	    if (is_pair(sc->value))
	      {
		push_stack(sc, OP_LET_ONE_1, car(p), cdr(sc->code)); /* args code */
		sc->code = sc->value;
		goto EVAL;
	      }
	    if (is_symbol(sc->value))
	      sc->value = find_symbol_checked(sc, sc->value);
	    sc->code = cdr(sc->code);
	    sc->args = car(p);
	    /* drop through */
	  }
	  
	case OP_LET_ONE_1:
	  new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value);
	  goto BEGIN1;
	  
	  
	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);
	    goto BEGIN1;
	  }
	  
	  
	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_let(sc);
	    sc->args = frame;
	    for (p = car(sc->code); is_pair(p); p = cdr(p))
	      add_slot(frame, caar(p), find_symbol_checked(sc, cadar(p)));
	    sc->let_number++;
	    sc->envir = frame;
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_LET_ALL_opSq:
	  {
	    s7_pointer p, frame;
	    frame = make_simple_let(sc);
	    sc->args = frame;
	    for (p = car(sc->code); is_pair(p); p = cdr(p))
	      {
		s7_pointer cp;
		cp = cadar(p);
		set_car(sc->t1_1, find_symbol_checked(sc, cadr(cp)));
		add_slot(frame, caar(p), c_call(cp)(sc, sc->t1_1));
	      }
	    sc->let_number++;
	    sc->envir = frame;
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  /* it is possible to save the frame+slots in a copied symbol+syntax pair, then reuse them
	   *  on every call here, but the savings in GC+allocation+setup is less than the cost in
	   *  marking the saved stuff past its actual life!  (If the code is removed from the heap,
	   *  the frame has to be saved on the permanent_objects list).
	   */
	case OP_LET_ALL_X:
	  {
	    s7_pointer p, frame;
	    frame = make_simple_let(sc);
	    sc->args = frame;
	    for (p = car(sc->code); is_pair(p); p = cdr(p))
	      {
		s7_pointer arg;
		arg = cdar(p);
		arg = c_call(arg)(sc, car(arg));
		add_slot(frame, caar(p), arg);
	      }
	    sc->let_number++;
	    sc->envir = frame;
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	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, T_PAIR);
	    set_car(x, sc->code);
	    set_cdr(x, sc->nil);
	    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_let(sc->x));
		    funclet_set_function(closure_let(sc->x), car(sc->code));
		    make_slot_1(sc, sc->envir, car(sc->code), sc->x);
		    sc->code = cddr(sc->code);
		    sc->x = sc->nil;
		  }
		else sc->code = cdr(sc->code);
		goto BEGIN1;
	      }
	  }
	  
	LET1:
	case OP_LET1:
	  {
	    s7_pointer x, y;
	    
	    new_cell(sc, x, T_PAIR);
	    set_car(x, sc->value); /* the first time (now handled above), this saves the entire let body across the evaluations -- we pick it up later */
	    set_cdr(x, sc->args);
	    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_op 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 = find_symbol_checked(sc, x);
		else sc->value = _NFre(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->y = y;
	    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, sc->w = safe_reverse_in_place(sc, sc->w), cddr(sc->code), T_CLOSURE);
		  sc->w = sc->nil;
		  if (is_safe_closure(sc->x))
		    {
		      s7_pointer arg, new_env;
		      new_env = new_frame_in_env(sc, sc->envir);
		      closure_set_let(sc->x, new_env);
		      for (arg = closure_args(sc->x); is_pair(arg); arg = cdr(arg))
			make_slot_1(sc, new_env, car(arg), sc->nil);
		      let_set_slots(new_env, reverse_slots(sc, let_slots(new_env)));
		    }
		  make_slot_1(sc, sc->envir, 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);
		      
		      set_type(y, T_SLOT);
		      slot_set_symbol(y, sym);
		      slot_set_value(y, val);
		      set_next_slot(y, let_slots(sc->envir));
		      let_set_slots(sc->envir, y);
		      symbol_set_local(sym, let_id(sc->envir), y);
		      
		      y = args;
		    }
		  sc->code = cddr(sc->code);
		}
	      else
		{
		  s7_pointer e;
		  unsigned long long int id;
		  
		  e = sc->envir;
		  id = let_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);
		      
		      set_type(y, T_SLOT);
		      slot_set_symbol(y, sym);
		      symbol_set_local(sym, id, y);
		      slot_set_value(y, val);
		      set_next_slot(y, let_slots(e));
		      let_set_slots(e, y);
		      
		      y = args;
		    }
		  sc->code = cdr(sc->code);
		}
	    }
	    sc->y = sc->nil;
	    goto BEGIN1;
	  }
	  
	  
	  /* -------------------------------- 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 = c_call(arg)(sc, car(arg));
		new_frame_with_slot(sc, sc->envir, sc->envir, caar(p), arg);
	      }
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_NAMED_LET_STAR:
	  push_stack(sc, OP_LET_STAR1, sc->code, cadr(sc->code));
	  sc->code = opt_con2(sc->code);
	  goto EVAL;
	  
	  
	case OP_LET_STAR2:
	  push_stack(sc, OP_LET_STAR1, sc->code, car(sc->code));
	  sc->code = opt_con2(sc->code);
	  goto EVAL;
	  
	  
	case OP_LET_STAR:
	  check_let_star(sc);
	  
	case OP_LET_STAR_UNCHECKED:
	  if (is_symbol(car(sc->code)))
	    {
	      s7_pointer cx;
	      cx = 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);
		  make_slot_1(sc, sc->envir, cx, make_closure(sc, sc->nil, sc->code, T_CLOSURE_STAR));
		  goto BEGIN1;
		}
	    }
	  else
	    {
	      if (is_null(car(sc->code)))
		{
		  sc->envir = new_frame_in_env(sc, sc->envir);
		  sc->code = cdr(sc->code);
		  goto BEGIN1;
		}
	    }
	  
	  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;
	  
	  
	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.  (much later -- this worries me... Could we defer making the slot?)
	   */
	  while (true)
	    {
	      new_frame_with_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 = find_symbol_checked(sc, x);
		  else sc->value = _NFre(x);
		}
	      else break;
	    }
	  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 */
	      make_slot_1(sc, sc->envir, 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);
	  goto BEGIN1;
	  
	  
	  /* -------------------------------- LETREC -------------------------------- */
	  
	case OP_LETREC:
	  check_letrec(sc, true);
	  
	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!
	   * but this assumes the environment is not changed by evaluating the exprs?
	   * (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling env, not the current env
	   * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2)
	   *
	   * I think I need to check here that slot_pending_value is set (using the is_checked bit below).
	   */
	  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 = make_slot_1(sc, sc->envir, caar(x), sc->undefined);
		  slot_set_pending_value(slot, sc->undefined);
		  slot_set_expression(slot, cadar(x));
		  set_checked_slot(slot);
		}
	      sc->args = let_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 BEGIN1;
	  
	  
	case OP_LETREC1:
	  slot_set_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 = let_slots(sc->envir); is_slot(slot); slot = next_slot(slot))
		if (is_checked_slot(slot))
		  slot_set_value(slot, slot_pending_value(slot));
	      sc->code = cdr(sc->code);
	      goto BEGIN1;
	    }
	  
	  
	  /* -------------------------------- LETREC* -------------------------------- */
	  
	case OP_LETREC_STAR:
	  check_letrec(sc, false);
	  
	case OP_LETREC_STAR_UNCHECKED:
	  /* get all local vars and set to #<undefined>
	   * eval each member of values list and assign immediately, as in let*
	   * eval body
	   */
	  sc->envir = new_frame_in_env(sc, sc->envir);
	  if (is_pair(car(sc->code)))
	    {
	      s7_pointer x, p, q;
	      for (x = car(sc->code); is_not_null(x); x = cdr(x))
		{
		  s7_pointer slot;
		  slot = make_slot_1(sc, sc->envir, caar(x), sc->undefined);
		  slot_set_expression(slot, cadar(x));
		}
	      /* these are reversed, and for letrec*, they need to be in order, so... (reverse_in_place on the slot list) */
	      p = let_slots(sc->envir);
	      x = sc->nil;
	      while (is_slot(p))
		{
		  q = next_slot(p);
		  set_next_slot(p, x);
		  x = p;
		  p = q;
		}
	      let_set_slots(sc->envir, x);
	      sc->args = let_slots(sc->envir);
	      push_stack(sc, OP_LETREC_STAR1, sc->args, sc->code);
	      sc->code = slot_expression(sc->args);
	      goto EVAL;
	    }
	  sc->code = cdr(sc->code);
	  goto BEGIN1;
	  
	  
	case OP_LETREC_STAR1:
	  {
	    s7_pointer slot;
	    slot = sc->args;
	    slot_set_value(slot, sc->value);
	    slot = next_slot(slot);
	    if (is_slot(slot))
	      {
		push_stack(sc, OP_LETREC_STAR1, slot, sc->code);
		sc->code = slot_expression(slot);
		goto EVAL;
	      }
	    else
	      {
		sc->code = cdr(sc->code);
		goto BEGIN1;
	      }
	  }
	  
	  
	  /* -------------------------------- 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))
	    {
	      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))
		{
		  if ((car(sc->code) == sc->feed_to_symbol) &&
		      (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
		    {
		      /* old form (pre 6-June-16): this causes a double evaluation:
		       *   (let ((x 'y) (y 32)) (cond ((values x y) => list))) -> '(32 32)
		       *   but it should be '(y 32)
		       * it's also extremely slow: make/eval a list?!
		       *
		       *   if (is_multiple_value(sc->value)) 
		       *     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_symbol, sc->value));
		       *   goto EVAL;
		       */
		      if (is_multiple_value(sc->value))                             /* (cond ((values 1 2) => +)) */
			{
			  sc->args = multiple_value(sc->value);
			  clear_multiple_value(sc->args);
			}
		      else sc->args = list_1(sc, sc->value);
		      if (is_symbol(cadr(sc->code)))
			{
			  sc->code = find_symbol_checked(sc, cadr(sc->code));      /* car is => */
			  if (needs_copied_args(sc->code))
			    sc->args = copy_list(sc, sc->args);
			  goto APPLY;
			}
		      else 
			{
			  /* need to evaluate the target function */
			  push_stack(sc, OP_COND1_1, sc->args, sc->code);
			  sc->code = cadr(sc->code);
			  sc->args = sc->nil;
			  goto EVAL;
			}
		    }
		  goto BEGIN1;
		}
	      eval_error(sc, "cond: unexpected dot? ~A", sc->code); /* (cond (#t . 1)) etc */
	    }
	  sc->code = cdr(sc->code);
	  if (is_null(sc->code))
	    {
	      sc->value = sc->unspecified; /* changed 31-Dec-15 */
	      /* r7rs sez the value if no else clause is unspecified, and this choice makes cond consistent with if and case,
	       *   and rewrite choices between the three are simpler if they are consistent.
	       */
	      goto START;
	    }
	  
	  push_stack_no_args(sc, OP_COND1, sc->code);
	  sc->code = caar(sc->code);
	  goto EVAL;

	case OP_COND1_1:
	  sc->code = sc->value;
	  if (needs_copied_args(sc->code))
	    sc->args = copy_list(sc, sc->args);
	  goto APPLY;
	  
	case OP_COND_SIMPLE:
	  push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
	  sc->code = caar(sc->code);
	  goto EVAL;
	  
	  
	case OP_COND1_SIMPLE:
	  while (true)
	    {
	      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;
		    }
		  goto BEGIN1;
		}
	      
	      sc->code = cdr(sc->code);
	      if (is_null(sc->code))
		{
		  sc->value = sc->unspecified; 
		  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 = find_symbol_checked(sc, sc->value);
	    }
	  
	  
	case OP_COND_S:
	  {
	    s7_pointer val = NULL, p;
	    if (is_pair(caar(sc->code)))
	      val = find_symbol_checked(sc, cadaar(sc->code));
	    for (p = sc->code; is_pair(p); p = cdr(p))
	      {
		s7_pointer ap;
		ap = caar(p);
		if (is_pair(ap))
		  {
		    set_car(sc->t1_1, val);
		    sc->value = c_call(ap)(sc, sc->t1_1);
		  }
		else sc->value = sc->T;
		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;
		      }
		    goto BEGIN1;
		  }
	      }
	    sc->value = sc->unspecified; 
	  }
	  break;
	  
	case OP_COND_ALL_X_2:
	  {
	    s7_pointer p;
	    p = sc->code;
	    sc->value = c_call(car(p))(sc, caar(p));
	    if (!is_true(sc, sc->value))
	      {
		p = cdr(p);
		sc->value = c_call(car(p))(sc, caar(p));
		if (!is_true(sc, sc->value))
		  {
		    sc->value = sc->unspecified; 
		    goto START;
		  }
	      }
	    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;
	      }
	    goto BEGIN1;
	  }
	  
	case OP_COND_ALL_X:
	  {
	    s7_pointer p;
	    for (p = sc->code; is_pair(p); p = cdr(p))
	      {
		sc->value = c_call(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;
		      }
		    goto BEGIN1;
		  }
	      }
	    sc->value = sc->unspecified; 
	  }
	  break;

	  
	  /* -------------------------------- 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 = find_global_symbol_checked(sc, p);
		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 (c_callee(sc->code)) /* all c_callee's are set via all_x_eval which can return nil */
	    {
	      sc->value = c_call(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;
	    }
	  
	case OP_AND_P2:
	  /* we know c_callee is set on sc->code, and there are only two branches */
	  sc->value = c_call(sc->code)(sc, car(sc->code));
	  if (is_false(sc, sc->value))
	    goto START;
	  sc->code = cadr(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 = find_symbol_checked(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 (c_callee(sc->code))
	    {
	      sc->value = c_call(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;
	    }
	  
	case OP_OR_P2:
	  /* we know c_callee is set on sc->code, and there are only two branches */
	  sc->value = c_call(sc->code)(sc, car(sc->code));
	  if (is_true(sc, sc->value))
	    goto START;
	  sc->code = cadr(sc->code);
	  goto EVAL;

	  /* by going direct without a push_stack on the last one we get tail calls,
	   *   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.
	   */
	  
	  
	  /* -------------------------------- 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)
	   */
	  if (is_multiple_value(sc->value))
	    {
	      /* a normal macro's result is evaluated (below) and its value replaces the macro invocation,
	       *   so if a macro returns multiple values, evaluate each one, then replace the macro
	       *   invocation with (apply values evaluated-results-in-a-list).  We need to save the
	       *   new list of results, and where we are in the macro's output list, so code=macro output,
	       *   args=new list.  If it returns (values), should we use #<unspecified>?  I think that
	       *   happens now without generating a multiple_value object:
	       *       (define-macro (hi) (values)) (hi) -> #<unspecified>
	       *
	       *   (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19
	       *   (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3
	       */
	      push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value));
	      sc->code = car(sc->value);
	    }
	  else sc->code = sc->value;
	  goto EVAL;
	  
	  
	case OP_EVAL_MACRO_MV:
	  if (is_null(sc->code)) /* end of values list */
	    {
	      sc->value = splice_in_values(sc, multiple_value(safe_reverse_in_place(sc, cons(sc, sc->value, sc->args))));
	      goto START;
	    }
	  push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), cdr(sc->code));
	  sc->code = car(sc->code);
	  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 
	    {
	      if (is_pair(sc->value))
		annotate_expansion(sc->value);
	    }
	  break;
	  
	  
	case OP_DEFINE_MACRO_WITH_ACCESSOR:
	  if (sc->value == sc->error_symbol) /* backwards compatibility... */
	    return(s7_error(sc, sc->error_symbol, set_elist_3(sc, make_string_wrapper(sc, "can't define-macro ~S to ~S"), car(sc->args), cadr(sc->args))));
	  sc->code = sc->value;
	  if ((!is_pair(sc->code)) ||
	      (!is_pair(car(sc->code))) ||
	      (!is_symbol(caar(sc->code))))
	    eval_error(sc, "define-macro: ~S does not look like a macro?", sc->code);
	  sc->value = make_macro(sc);
	  break;
	  
	  
	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, sc->op);
	  if (symbol_has_accessor(caar(sc->code)))
	    {
	      s7_pointer x;
	      x = find_symbol(sc, caar(sc->code));
	      if ((is_slot(x)) &&
		  (slot_has_accessor(x)))
		{
		  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;
		}
	    }
	  sc->value = make_macro(sc);
	  break;
	  
	  
	case OP_LAMBDA:
	  check_lambda(sc);
	  
	case OP_LAMBDA_UNCHECKED:
	  make_closure_with_let(sc, sc->value, car(sc->code), cdr(sc->code), sc->envir);
	  break;
	  
	  
	case OP_LAMBDA_STAR:
	  check_lambda_star(sc);
	  
	case OP_LAMBDA_STAR_UNCHECKED:
	  sc->value = make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE_STAR);
	  break;
	  
	  
	  /* -------------------------------- 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 = find_symbol_checked(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:
	  {
	    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_symbol) &&
		    (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
		  {
		    sc->code = list_2(sc, cadr(sc->code), list_2(sc, sc->quote_symbol, sc->value));
		    goto EVAL;
		  }
		goto BEGIN1;
	      }
	    
	    /* no match found */
	    sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */
	  }
	  break;
	  
	case OP_CASE_SIMPLE:
	  /* assume symbol as selector, all keys are simple, and no => */
	  {
	    s7_pointer x, y, selector;
	    selector = find_symbol_checked(sc, car(sc->code));
	    for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	      {
		y = opt_key(x);
		if (!is_pair(y)) /* else? */
		  {
		    sc->code = cdar(x);
		    goto BEGIN1;
		  }
		do {
		  if (car(y) == selector)
		    {
		      sc->code = cdar(x);
		      goto BEGIN1;
		    }
		  y = cdr(y);
		} while (is_pair(y));
	      }
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	case OP_CASE_SIMPLER:
	  /* assume symbol as selector, all keys are simple, and no => and no else */
	  {
	    s7_pointer x, y, selector;
	    selector = find_symbol_checked(sc, car(sc->code));
	    for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	      {
		y = opt_key(x);
		do {
		  if (car(y) == selector)
		    {
		      sc->code = cdar(x);
		      goto BEGIN1;
		    }
		  y = cdr(y);
		} while (is_pair(y));
	      }
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	case OP_CASE_SIMPLER_1:
	  /* assume symbol as selector, all keys are simple, and no => and no else, bodies are 1 liners */
	  {
	    s7_pointer x, y, selector;
	    selector = find_symbol_checked(sc, car(sc->code));
	    for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	      {
		y = opt_key(x);
		do {
		  if (car(y) == selector)
		    {
		      sc->code = opt_clause(x); /* cadar(x); */
		      goto EVAL;
		    }
		  y = cdr(y);
		} while (is_pair(y));
	      }
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	case OP_CASE_SIMPLER_SS:
	  /* 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 = find_symbol_checked(sc, car(args));
	    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
	    set_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 = opt_key(x);
		do {
		  if (car(y) == selector)
		    {
		      sc->code = opt_clause(x); /* cadar(x); */
		      goto EVAL;
		    }
		  y = cdr(y);
		} while (is_pair(y));
	      }
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	case OP_CASE_SIMPLEST_SS:
	  {
	    s7_pointer x, selector, args;
	    args = cdar(sc->code);
	    x = find_symbol_checked(sc, car(args));
	    set_car(sc->t2_2, find_symbol_checked(sc, cadr(args)));
	    set_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 (opt_key(x) == selector)
		{
		  sc->code = cdar(x);
		  goto BEGIN1;
		}
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	case OP_CASE_SIMPLEST:
	  /* assume symbol as selector, all keys are simple and singletons, and no => and no else, bodies are 1 liners */
	  {
	    s7_pointer x, selector;
	    selector = find_symbol_checked(sc, car(sc->code));
	    for (x = cdr(sc->code); is_pair(x); x = cdr(x))
	      if (opt_key(x) == selector)
		{
		  sc->code = opt_clause(x); /* cadar(x); */
		  goto EVAL;
		}
	    sc->value = sc->unspecified;
	  }
	  break;
	  
	  
	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:
	case OP_CATCH_2:
	  break;
	  
	case OP_DEACTIVATE_GOTO:
	  call_exit_active(sc->args) = false;      /* as we leave the call-with-exit body, deactivate the exiter */
	  break;
	  
	  
	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, ERROR_QUIT_JUMP);
	  return(sc->value); /* not executed I hope */
	  
	  
	case OP_GET_OUTPUT_STRING:          /* from get-output-string -- return a new string */
	  sc->value = s7_make_string_with_length(sc, (const char *)port_data(sc->code), port_position(sc->code));
	  break;
	  
	  
	case OP_GET_OUTPUT_STRING_1:        /* from call-with-output-string and with-output-to-string -- return the port string directly */
	  if ((!is_output_port(sc->code)) ||
	      (port_is_closed(sc->code)))
	    simple_wrong_type_argument_with_type(sc, sc->with_output_to_string_symbol, sc->code, make_string_wrapper(sc, "an open string output port"));
	  
	  if (port_position(sc->code) >= port_data_size(sc->code))
	    resize_port_data(sc->code, port_position(sc->code) + 1); /* need room for the trailing #\null */
	  sc->value = make_string_uncopied_with_length(sc, (char *)port_data(sc->code), port_position(sc->code));
	  string_value(sc->value)[port_position(sc->code)] = 0;
	  port_data(sc->code) = NULL;
	  port_data_size(sc->code) = 0;
	  port_needs_free(sc->code) = false;
	  /* fall through */
	  
	case OP_UNWIND_OUTPUT:
	  unwind_output_ex(sc);
	  break;

	case OP_UNWIND_INPUT:
	  unwind_input_ex(sc);
	  break;
	  
	case OP_DYNAMIC_WIND:
	  if (dynamic_wind_ex(sc) == goto_APPLY) goto APPLY;
	  break;
	  
	  
	  /* -------------------------------- with-let --------------------------------
	   *
	   * the extra set! to pull in args, or fixup the outlet is annoying, but
	   *   but with-let is hard to do right -- what if env is chained as in class/objects?
	   * also, currently a mock-let is an error -- perhaps add the method checks?
	   *   but unless 'values, that would require a 'with-let method (it's not a function)
	   */
	case OP_WITH_LET_S:
	  {
	    s7_pointer e;
	    e = find_symbol_checked(sc, car(sc->code));
	    if (e == sc->rootlet)
	      sc->envir = sc->nil;
	    else
	      {
		s7_pointer p;
		if (!is_let(e))
		  eval_type_error(sc, "with-let takes an environment argument: ~A", e);
		set_with_let_let(e);
		let_id(e) = ++sc->let_number;
		sc->envir = e;
		/* if the let in question has 10,000 names (e.g. *gtk*) this loop (which can't be avoided currently)
		 *   will be noticeable in a few cases.  So, instead of saying (with-let *gtk* ...) use something
		 *   equivalent to (with-let (sublet *gtk*) ...) which is cleaner anyway.  (In my timing tests, even
		 *   when pounding on this one block, the loop only amounts to 1% of the time.  Normally it's
		 *   negligible).
		 */
		for (p = let_slots(e); is_slot(p); p = next_slot(p))
		  {
		    s7_pointer sym;
		    sym = slot_symbol(p);
		    if (symbol_id(sym) != sc->let_number)
		      symbol_set_local(sym, sc->let_number, p);
		  }
	      }
	    sc->code = cdr(sc->code);
	    goto BEGIN1;
	  }
	  
	  
	case OP_WITH_LET:
	  check_with_let(sc);
	  
	case OP_WITH_LET_UNCHECKED:
	  sc->value = car(sc->code);
	  if (!is_pair(sc->value))
	    {
	      if (is_symbol(sc->value))
		sc->value = find_symbol_checked(sc, sc->value);
	      sc->code = cdr(sc->code);
	      
	      if (!is_pair(sc->code))
		{
		  if (!is_let(sc->value))            /* (with-let e abs) */
		    eval_type_error(sc, "with-let 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_LET1, sc->nil, cdr(sc->code));
	      sc->code = sc->value;                          /* eval env arg */
	      goto EVAL;
	    }
	  
	case OP_WITH_LET1:
	  activate_let(sc);
	  goto BEGIN1;
	  
	  
	case OP_WITH_BAFFLE:
	  if (!is_proper_list(sc, sc->code))
	    eval_error(sc, "with-baffle: unexpected dot? ~A", sc->code);
	  
	  if ((!is_null(sc->code)) &&
	      (is_overlaid(sc->code)) &&
	      (has_opt_back(sc->code)))
	    pair_set_syntax_symbol(sc->code, sc->with_baffle_unchecked_symbol);
	  
	case OP_WITH_BAFFLE_UNCHECKED:
	  if (is_null(sc->code))
	    {
	      sc->value = sc->nil;
	      goto START;
	    }
	  new_frame(sc, sc->envir, sc->envir);
	  make_slot_1(sc, sc->envir, sc->baffle_symbol, make_baffle(sc));
	  goto BEGIN1;
	  
	  
	  /* -------------------------------- the reader -------------------------------- */
	  
	POP_READ_LIST:
	  /* push-stack OP_READ_LIST is always no_code and sc->op is always OP_READ_LIST (and not used), sc->envir is apparently not needed here
	   */
	  sc->stack_end -= 4;
	  sc->args = sc->stack_end[2];
	  
	READ_LIST:
	case OP_READ_LIST:        /* sc->args is sc->nil at first */
	  {
	    s7_pointer x;
	    new_cell(sc, x, T_PAIR);
	    set_car(x, sc->value);
	    set_cdr(x, sc->args);
	    sc->args = x;
	  }
	  
	case OP_READ_NEXT:       /* 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);
	    
	  READ_C:
	    switch (c)
	      {
	      case '(':
		c = port_read_white_space(pt)(sc, pt);  /* sc->tok = token(sc) */
		switch (c)
		  {
		  case '(':  sc->tok = TOKEN_LEFT_PAREN;                break;
		  case ')':  sc->value = sc->nil; goto READ_LIST;       /* was tok = TOKEN_RIGHT_PAREN */
		  case '.':  sc->tok = read_dot(sc, pt);                break;
		  case '\'': sc->tok = TOKEN_QUOTE;                     break;
		  case ';':  sc->tok = port_read_semicolon(pt)(sc, pt); break;
		  case '"':  sc->tok = TOKEN_DOUBLE_QUOTE;              break;
		  case '`':  sc->tok = TOKEN_BACK_QUOTE;                break;
		  case ',':  sc->tok = read_comma(sc, pt);              break;
		  case '#':  sc->tok = read_sharp(sc, pt);              break;
		  case '\0': case EOF: sc->tok = TOKEN_EOF;             break;
		    
		  default:
		    {
		      s7_pointer x;
		      sc->strbuf[0] = c;
		      push_stack_no_code(sc, OP_READ_LIST, sc->args);
		      check_stack_size(sc);
		      sc->value = port_read_name(pt)(sc, pt);
		      new_cell(sc, x, T_PAIR);
		      set_car(x, sc->value);
		      set_cdr(x, sc->nil);
		      sc->args = x;
		      c = port_read_white_space(pt)(sc, pt);
		      goto READ_C;
		    }
		  }
		
		if (sc->tok == TOKEN_ATOM)
		  {
		    s7_pointer x;
		    push_stack_no_code(sc, OP_READ_LIST, sc->args);
		    check_stack_size(sc);
		    sc->value = port_read_name(pt)(sc, pt);
		    new_cell(sc, x, T_PAIR);
		    set_car(x, sc->value);
		    set_cdr(x, sc->nil);
		    sc->args = x;
		    c = port_read_white_space(pt)(sc, pt);
		    goto READ_C;
		  }
		
		if (sc->tok == TOKEN_RIGHT_PAREN)
		  {
		    sc->value = sc->nil;
		    goto READ_LIST;
		  }
		
		if (sc->tok == TOKEN_DOT)
		  {
		    do {c = inchar(pt);} while ((c != ')') && (c != EOF));
		    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);
		push_stack_no_code(sc, OP_READ_LIST, sc->nil);
		check_stack_size(sc);
		sc->value = read_expression(sc);
		if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
		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, pt);
		if (sc->value == sc->F)                                /* can happen if input code ends in the middle of a string */
		  return(string_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);
		if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
		goto START; /* read_unquote */
		
	      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;  /* read_unquote */
		
	      case '#':
		sc->tok = read_sharp(sc, pt);
		break;
		
	      case '\0':
	      case EOF:
		return(missing_close_paren_error(sc));
	      
	      default:
		sc->strbuf[0] = c;
		sc->value = port_read_name(pt)(sc, pt);
		goto READ_LIST;
	      }
	  }
	  
	READ_TOK:
	  switch (sc->tok)
	    {
	    case TOKEN_RIGHT_PAREN:
	      /* sc->args can't be null here */
	      sc->value = safe_reverse_in_place(sc, sc->args);
	      if (is_symbol(car(sc->value)))
		{
		  pair_set_line(sc->value, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
		  set_has_line_number(sc->value);	      /* sc->input_port above can't be nil(?) -- it falls back on stdin now */
		  
		  if ((is_expansion(car(sc->value))) &&
		      (expansion_ex(sc) == goto_APPLY))
		    goto APPLY;
		  if (is_pair(cdr(sc->value)))
		    {
		      set_opt_back(sc->value);
		      set_overlay(cdr(sc->value));
		    }
		}
	      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);
	      goto READ_LIST;
	      
	    case TOKEN_SHARP_CONST:
	      sc->value = port_read_sharp(sc->input_port)(sc, sc->input_port);
	      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;
	      
	    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(string_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 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;
	    }
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	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);
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	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_symbol, sc->value);
	  set_opt_back(sc->value);
	  set_overlay(cdr(sc->value));
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	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.
	   */
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	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);
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	case OP_READ_BYTE_VECTOR:
	  if (!is_proper_list(sc, sc->value))       /* #u8(1 . 2) */
	    return(read_error(sc, "byte-vector constant data is not a proper list"));
	  sc->value = g_byte_vector(sc, sc->value);
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	case OP_READ_UNQUOTE:
	  /* here if sc->value is a constant, the unquote is pointless (should we complain?) */
	  if ((is_pair(sc->value)) ||
	      (is_symbol(sc->value)))
	    sc->value = list_2(sc, sc->unquote_symbol, sc->value);
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	case OP_READ_APPLY_VALUES:
	  if (is_symbol(sc->value))
	    {
	      s7_pointer lst;
	      lst = list_2(sc, sc->qq_apply_values_function, sc->value);
	      set_unsafe_optimize_op(lst, HOP_C_S);
	      set_c_function(lst, sc->qq_apply_values_function);
	      sc->value = list_2(sc, sc->unquote_symbol, lst);
	    }
	  else sc->value = list_2(sc, sc->unquote_symbol, list_2(sc, sc->qq_apply_values_function, sc->value));
	  if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST;
	  break;
	  
	  
	default:
	  fprintf(stderr, "unknown operator: " INT_FORMAT " in %s\n", sc->op, DISPLAY(current_code(sc)));
#if DEBUGGING
	  fprintf(stderr, "stack size: %u\n", sc->stack_size);
	  if (sc->stack_end < sc->stack_start) 
	    fprintf(stderr, "%sstack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
	  if (sc->stack_end >= sc->stack_start + sc->stack_size) 
	    fprintf(stderr, "%sstack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT);
	  abort();
#endif
	  return(sc->F);
	}
    }
  return(sc->F);
}

#if WITH_GCC
#undef new_cell
#if (!DEBUGGING)
#define new_cell(Sc, Obj, Type)			\
  do {									\
    if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
    Obj = (*(--(Sc->free_heap_top)));					\
    set_type(Obj, Type);						\
  } while (0)
#else
#define new_cell(Sc, Obj, Type)			\
  do {									\
    if ((Sc->free_heap_top <= Sc->free_heap_trigger) || (for_any_other_reason(sc, __LINE__))) {last_gc_line = __LINE__; last_gc_func = __func__; try_to_call_gc(Sc);} \
    Obj = (*(--(Sc->free_heap_top)));					\
    Obj->alloc_line = __LINE__;	Obj->alloc_func = __func__;		\
    set_type(Obj, Type);						\
  } while (0)
#endif
#endif


/* needed in s7_gmp_init and s7_init, initialized in s7_init before we get to gmp */
static s7_pointer pl_bt, pl_p, pl_bc, pcl_bc, pcl_bs, pl_bn, pl_sf, pcl_bt, pcl_i, pcl_t, pcl_r, pcl_n, pcl_s, pcl_v, pcl_f, pcl_c, pl_tl;




/* -------------------------------- multiprecision arithmetic -------------------------------- */

#if WITH_GMP
static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION; /* global for libs */
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);
  
  /* 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.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1);
  else snprintf(tmp, len, "%c.%s%c%d", str[0], (char *)(str + 1), (radix <= 10) ? 'E' : '@', ep - 1);
  
  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, "(complex %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;
    }
  else (*nlen) = safe_strlen(str);
  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 (is_t_big_integer(p))
    {
      mpz_t n;
      mpz_init_set_si(n, 1);
      result = (mpz_cmp(n, big_integer(p)) == 0);
      mpz_clear(n);
    }
  else
    {
      if (is_t_big_real(p))
	{
	  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, 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, 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, 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, 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, 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, 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, T_BIG_REAL);
  add_bigreal(sc, x);
  
  switch (type(p))
    {
    case T_INTEGER:
      if (sizeof(s7_int) == sizeof(long int))
	mpfr_init_set_si(big_real(x), integer(p), GMP_RNDN);
      else mpfr_init_set_ld(big_real(x), (long double)integer(p), 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, 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, 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, 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, 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, T_BIG_COMPLEX);
  add_bignumber(sc, x);
  mpc_init(big_complex(x));

  switch (type(p))
    {
    case T_INTEGER:
      if (sizeof(s7_int) == sizeof(long int))
	mpc_set_si(big_complex(x), integer(p), MPC_RNDNN);
      else mpc_set_d(big_complex(x), (double)integer(p), 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, 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, 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, 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, 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, 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 64-bit machines, s7_int already fits (if it's long long int).  
 *   I guess we can catch the 4-byte long int (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
    {
      /* 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_int_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, 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 (mpz_fits_slong_p(n))
    return(mpz_get_si(n));

  if ((hidden_sc->safety > 0) &&
      (sizeof(s7_int) == sizeof(long int)))
    {
      char *str;
      str = mpz_get_str(NULL, 10, n);
      s7_warn(hidden_sc, 256, "can't convert %s to s7_int\n", str);
      free(str);
    }

  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_int_min)
    return(s7_int_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));
}


static mpq_t *s7_ints_to_mpq(s7_int num, s7_int den)
{
  /* den here always comes from denominator(x) so it is not negative */
  mpq_t *n;
  n = (mpq_t *)malloc(sizeof(mpq_t));
  mpq_init(*n);
  if (sizeof(s7_int) == sizeof(long int))
    mpq_set_si(*n, num, 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)
{
  /* den here always comes from denominator(x) or some positive constant so it is not negative */
  s7_pointer x;
  new_cell(sc, x, T_BIG_RATIO);
  add_bigratio(sc, x);
  mpq_init(big_ratio(x));
  if (sizeof(s7_int) == sizeof(long int))
    mpq_set_si(big_ratio(x), num, 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 (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 */

    case T_BIG_RATIO:
      if (is_big_number(x))
	{
	  if (is_t_big_ratio(x))
	    {
	      if (copy)
		return(mpq_to_big_ratio(sc, big_ratio(x)));
	      return(x);
	    }
	  return(mpz_to_big_ratio(sc, big_integer(x)));
	}
      if (is_t_integer(x))
	return(s7_ratio_to_big_ratio(sc, integer(x), 1));
      return(s7_ratio_to_big_ratio(sc, numerator(x), denominator(x)));

    case T_BIG_REAL:
      if (is_big_number(x))
	{
	  if (is_t_big_real(x))
	    {
	      if (copy)
		return(mpfr_to_big_real(sc, big_real(x)));
	      return(x);
	    }
	  if (is_t_big_ratio(x))
	    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));

    default:
      if (is_big_number(x))
	{
	  if (is_t_big_complex(x))
	    {
	      if (copy)
		return(mpc_to_big_complex(sc, big_complex(x)));
	      return(x);
	    }
	  if (is_t_big_real(x))
	    return(mpfr_to_big_complex(sc, big_real(x)));
	  if (is_t_big_ratio(x))
	    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));
    }
  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_normal_vector(vec)) && (is_big_number(obj)))
    {
      int gc_loc;
      s7_int i, len;
      s7_pointer *tp;

      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 big_bignum(s7_scheme *sc, s7_pointer args)
{
  #define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'"
  #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, sc->is_number_symbol, sc->is_integer_symbol)
  s7_pointer p;

  p = g_string_to_number_1(sc, args, sc->bignum_symbol);
  if (is_false(sc, p))                                       /* (bignum "1/3.0") */
    s7_error(sc, make_symbol(sc, "bignum-error"), 
	     set_elist_2(sc, make_string_wrapper(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 propagates 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:
      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 big_is_bignum(s7_scheme *sc, s7_pointer args)
{
  #define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number."
  #define Q_is_bignum pl_bt
  return(s7_make_boolean(sc, is_big_number(car(args))));
}

#define get_result_type(Sc, Type, P) \
  ((is_number(P)) ? normal_type_to_result_type(Type, type(p)) : ((is_big_number(P)) ? big_type_to_result_type(Type, type(p)) : result_type_via_method(Sc, Type, P)))

static int result_type_via_method(s7_scheme *sc, int result_type, s7_pointer p)
{
  s7_pointer f;
  if (!has_methods(p)) return(-1);

  f = find_method(sc, find_let(sc, p), sc->is_integer_symbol);
  if ((f != sc->undefined) &&
      (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
    return(big_type_to_result_type(result_type, T_BIG_INTEGER));

  f = find_method(sc, find_let(sc, p), sc->is_rational_symbol);
  if ((f != sc->undefined) &&
      (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
    return(big_type_to_result_type(result_type, T_BIG_RATIO));

  f = find_method(sc, find_let(sc, p), sc->is_real_symbol);
  if ((f != sc->undefined) &&
      (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
    return(big_type_to_result_type(result_type, T_BIG_REAL));

  /* might be a number, but not complex (quaternion) */
  f = find_method(sc, find_let(sc, p), sc->is_complex_symbol);
  if ((f != sc->undefined) &&
      (is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
    return(big_type_to_result_type(result_type, T_BIG_COMPLEX));

  return(-1);
}


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);
      result_type = get_result_type(sc, result_type, p);
      if (result_type < 0)
	return(g_add(sc, args));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_add(sc, args));
  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->add_symbol, 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;
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->add_symbol, cons(sc, result, x));

      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_int_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)))
    method_or_bust_with_type(sc, car(args), sc->subtract_symbol, args, a_number_string, 1);

  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);
      result_type = get_result_type(sc, result_type, p);
      if (result_type < 0)
	return(g_subtract(sc, args));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_subtract(sc, args));

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->subtract_symbol, 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;
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->subtract_symbol, cons(sc, result, x));

      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);
      result_type = get_result_type(sc, result_type, p);
      if (result_type < 0)
	return(g_multiply(sc, args));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_multiply(sc, args));

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->multiply_symbol, 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;
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->multiply_symbol, cons(sc, result, x));

      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_symbol, p));

  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) == s7_int_min)
	{
	  mpz_t n1, d1;

	  new_cell(sc, x, T_BIG_RATIO);
	  add_bigratio(sc, x);

	  mpz_init_set_s7_int(n1, 1);
	  mpz_init_set_s7_int(d1, s7_int_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(minus_one);
	  }

	new_cell(sc, 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, 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)))
    method_or_bust_with_type(sc, car(args), sc->divide_symbol, args, a_number_string, 1);

  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 divisor is 0, gmp throws an exception and halts s7!
       *   I don't think we can trap gmp errors, and the abort is built into the library code.
       */
      result_type = get_result_type(sc, result_type, p);
      if (result_type < 0)
	return(g_divide(sc, args));

      if ((x != args) &&
	  (s7_is_zero(p)))
	return(division_by_zero_error(sc, sc->divide_symbol, args));
    }

  if (result_type < T_BIG_INTEGER)
    return(g_divide(sc, args));

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->divide_symbol, args);

  if (!s7_is_number(cadr(args)))
    check_method(sc, cadr(args), sc->divide_symbol, 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;
      if (!s7_is_number(car(x)))
	{
	  s7_pointer func;
	  if ((has_methods(car(x))) && ((func = find_method(sc, find_let(sc, car(x)), sc->multiply_symbol)) != sc->undefined))
	    {
	      divisor = s7_apply_function(sc, func, cons(sc, divisor, x));
	      break;
	    }
	}

      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_symbol, args));

  /* it's possible for the divisor to be the wrong type here (if complex multiply -> real for example */
  divisor = promote_number_1(sc, result_type, divisor, false);

  result = copy_and_promote_number(sc, result_type, car(args));

  switch (result_type)
    {
    case T_BIG_INTEGER:
      {
	new_cell(sc, 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));

    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));
    }
  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"
  #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)  
  
  s7_pointer p, x;

  p = car(args);
  switch (type(p))
    {
    case T_INTEGER:
      if (integer(p) < 0)
	{
	  if (integer(p) == s7_int_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:
      method_or_bust(sc, p, sc->abs_symbol, args, T_REAL, 0);
    }
}


static s7_pointer big_magnitude(s7_scheme *sc, s7_pointer args)
{
  #define H_magnitude "(magnitude z) returns the magnitude of z"
  #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->magnitude_symbol, args, a_number_string, 0);

  if (is_t_big_complex(p))
    {
      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 (is_t_complex(p))
    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"
  #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)

  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, 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:
      method_or_bust_with_type(sc, p, sc->angle_symbol, args, a_number_string, 0);
    }
}


static s7_pointer c_big_complex(s7_scheme *sc, s7_pointer args)
{
  #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
  #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)

  s7_pointer p0, p1, p;
  mpfr_t rl, im;
  double x;

  p0 = car(args);
  if (!s7_is_real(p0))
    method_or_bust(sc, p0, sc->complex_symbol, args, T_REAL, 1);

  p1 = cadr(args);
  if (!s7_is_real(p1))
    method_or_bust(sc, p1, sc->complex_symbol, args, T_REAL, 2);

  if ((!is_big_number(p1)) && (real_to_double(sc, p1, "complex") == 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, 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? */

#if (!WITH_PURE_S7)
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"
  #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)

  s7_pointer p0, p1, p;
  mpfr_t ang, mag, rl, im;
  double x, y;

  p0 = car(args);
  if (!s7_is_real(p0))
    method_or_bust(sc, p0, sc->make_polar_symbol, args, T_REAL, 1);

  p1 = cadr(args);
  if (!s7_is_real(p1))
    method_or_bust(sc, p1, sc->make_polar_symbol, args, T_REAL, 2);

  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, 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);
}
#endif


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"
  #define Q_log pcl_n

  /* either arg can be big, second is optional */
  s7_pointer p0, p1 = NULL, p;

  p0 = car(args);
  if (!s7_is_number(p0))
    method_or_bust_with_type(sc, p0, sc->log_symbol, args, a_number_string, 1);

  if (is_not_null(cdr(args)))
    {
      p1 = cadr(args);
      if (!s7_is_number(p1))
	method_or_bust_with_type(sc, p1, sc->log_symbol, args, a_number_string, 2);
    }

  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_symbol, small_int(2), p1, make_string_wrapper(sc, "argument 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, 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, 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"
  #define Q_sqrt pcl_n  

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->sqrt_symbol, args, a_number_string, 0);
  p = to_big(sc, p);

  /* if big integer, try to return int if perfect square */
  if (is_t_big_integer(p))
    {
      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 (is_t_big_ratio(p))
    {
      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 (is_t_big_real(p))
    {
      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))
    method_or_bust_with_type(sc, p, sym, args, a_number_string, 0);
  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)"
  #define Q_sin pcl_n  

  return(big_trig(sc, args, mpfr_sin, mpc_sin, TRIG_NO_CHECK, sc->sin_symbol));
}


static s7_pointer big_cos(s7_scheme *sc, s7_pointer args)
{
  #define H_cos "(cos z) returns cos(z)"
  #define Q_cos pcl_n  

  return(big_trig(sc, args, mpfr_cos, mpc_cos, TRIG_NO_CHECK, sc->cos_symbol));
}


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)"
  #define Q_tan pcl_n  

  return(big_trig(sc, args, mpfr_tan, mpc_tan, TRIG_TAN_CHECK, sc->tan_symbol));
}


static s7_pointer big_sinh(s7_scheme *sc, s7_pointer args)
{
  #define H_sinh "(sinh z) returns sinh(z)"
  #define Q_sinh pcl_n  

  /* currently (sinh 0+0/0i) -> 0.0? */
  return(big_trig(sc, args, mpfr_sinh, mpc_sinh, TRIG_NO_CHECK, sc->sinh_symbol));
}


static s7_pointer big_cosh(s7_scheme *sc, s7_pointer args)
{
  #define H_cosh "(cosh z) returns cosh(z)"
  #define Q_cosh pcl_n  

  return(big_trig(sc, args, mpfr_cosh, mpc_cosh, TRIG_NO_CHECK, sc->cosh_symbol));
}


static s7_pointer big_tanh(s7_scheme *sc, s7_pointer args)
{
  #define H_tanh "(tanh z) returns tanh(z)"
  #define Q_tanh pcl_n  

  return(big_trig(sc, args, mpfr_tanh, mpc_tanh, TRIG_TANH_CHECK, sc->tanh_symbol));
}


static s7_pointer big_exp(s7_scheme *sc, s7_pointer args)
{
  #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
  #define Q_exp pcl_n  

  return(big_trig(sc, args, mpfr_exp, mpc_exp, TRIG_NO_CHECK, sc->exp_symbol));
}


static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
{
  #define H_expt "(expt z1 z2) returns z1^z2"
  #define Q_expt pcl_n

  s7_pointer x, y, p;

  /* see comment under g_expt
   *  if (is_not_null(cddr(args)))
   *    return(big_expt(sc, set_plist_2(sc, car(args), big_expt(sc, cdr(args)))));
   */

  x = car(args);
  if (!s7_is_number(x))
    method_or_bust_with_type(sc, x, sc->expt_symbol, args, a_number_string, 1);

  y = cadr(args);
  if (!s7_is_number(y))
    method_or_bust_with_type(sc, y, sc->expt_symbol, args, a_number_string, 2);

  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_symbol, args));
	}
      else
	{
	  if (s7_is_negative(g_real_part(sc, cdr(args))))
	    return(division_by_zero_error(sc, sc->expt_symbol, 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;
      yval = s7_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_int32_max) &&
	  (yval > s7_int32_min))
	{
	  /* from here yval can fit in an unsigned int
	   *    (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807)
	   */
	  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;

	      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 ((is_t_ratio(y)) &&              /* not s7_is_ratio which accepts bignums */
      (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_int32_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)"
  #define Q_asinh pcl_n  

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->asinh_symbol, args, a_number_string, 0);

  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)"
  #define Q_acosh pcl_n  

  s7_pointer p;
  double x;
  mpc_t n;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->acosh_symbol, args, a_number_string, 0);
  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)"
  #define Q_atanh pcl_n  

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->atanh_symbol, args, a_number_string, 0);

  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)"
  #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)  

  s7_pointer p0, p1 = NULL, p;

  p0 = car(args);
  if (!s7_is_number(p0))
    method_or_bust_with_type(sc, p0, sc->atan_symbol, args, a_number_string, 0);

  if (is_not_null(cdr(args)))
    {
      p1 = cadr(args);
      if (!s7_is_real(p1))
	method_or_bust(sc, p1, sc->atan_symbol, args, T_REAL, 2);

      if (!s7_is_real(p0))
	return(wrong_type_argument(sc, sc->atan_symbol, 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"
  #define Q_acos pcl_n  

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->acos_symbol, args, a_number_string, 0);

  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"
  #define Q_asin pcl_n  

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))
    method_or_bust_with_type(sc, p, sc->asin_symbol, args, a_number_string, 0);

  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 (is_t_big_integer(car(args)))
    {
      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));
}


#if (!WITH_PURE_S7)
static s7_pointer big_integer_length(s7_scheme *sc, s7_pointer args)
{
  if (is_t_big_integer(car(args)))
    {
      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));
}
#endif


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_symbol, small_int(2), p1, its_too_large_string));

	      /* here if p0 is negative, we need to return -1 */
	      if (p0_compared_to_zero == 1)
		return(small_int(0));
	      return(minus_one);
	    }
	  shift = mpz_get_si(big_integer(p1));
	}
      else
	{
	  shift = s7_integer(p1);
	  if (shift < s7_int32_min)
	    {
	      if (p0_compared_to_zero == 1)
		return(small_int(0));
	      return(minus_one);
	    }
	}

      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 bool is_integer_via_method(s7_scheme *sc, s7_pointer p)
{
  if (s7_is_integer(p))
    return(true);
  if (has_methods(p))
    {
      s7_pointer f;
      f = find_method(sc, find_let(sc, p), sc->is_integer_symbol);
      if (f != sc->undefined)
	return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
    }
  return(false);
}

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, lst;
  bool use_bigs = false;
  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!is_integer_via_method(sc, car(x)))
	return(wrong_type_argument(sc, sym, position_of(x, args), car(x), T_INTEGER));
      if (!use_bigs) use_bigs = (type(car(x)) != T_INTEGER);
    }
  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))
	{
	  s7_pointer i;
	  i = car(x);
	  switch (type(i))
	    {
	    case T_BIG_INTEGER:
	      mpz_bits(n, n, big_integer(i));
	      break;

	    case T_INTEGER:
	      mpz_bits(n, n, big_integer(s7_int_to_big_integer(sc, integer(i))));
	      break;

	    default:
	      /* we know it's an integer of some sort, but what about the method */
	      lst = cons(sc, mpz_to_big_integer(sc, n), x);
	      mpz_clear(n);
	      method_or_bust(sc, i, sym, lst, T_INTEGER, position_of(x, args));
	    }
	}
      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(minus_one);
  return(big_bits(sc, args, sc->logand_symbol, -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_symbol, 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_symbol, 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"
  #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)

  /* currently (rationalize 1/0 1e18) -> 0
   * remember to pad with many trailing zeros:
   *
   *    : (rationalize 0.1 0)
   *    3602879701896397/36028797018963968
   *    :(rationalize 0.1000000000000000 0)
   *    1/10
   *
   * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem?  (why is the non-gmp case ok?)
   *         also the bignum function is faking it.
   *         (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968
   *
   * a confusing case:
   *      > (rationalize 5925563891587147521650777143.74135805596e05)
   *   should be 148139097289678688041269428593533951399/250000
   *   but that requires more than 128 bits of bignum-precision.
   */

  s7_pointer 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))
    method_or_bust(sc, p0, sc->rationalize_symbol, args, T_REAL, 1);

  /* 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) -) */
	method_or_bust(sc, p1, sc->rationalize_symbol, args, T_REAL, 2);

      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, real_to_double(sc, p1, "rationalize"), 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_symbol, small_int(2), cadr(args), its_nan_string));
	}
      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, sc->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, real_to_double(sc, p0, "rationalize"), 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_symbol, small_int(1), car(args), its_nan_string));
    }
  if (mpfr_inf_p(ux) != 0)
    {
      mpfr_clear(ux);
      mpfr_clear(error);
      return(out_of_range(sc, sc->rationalize_symbol, small_int(1), car(args), its_infinite_string));
    }

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

#if (!WITH_PURE_S7)
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"
  #define Q_exact_to_inexact pcl_r

  s7_pointer p;

  p = car(args);
  if (!s7_is_number(p))   /* apparently (exact->inexact 1+i) is not an error */
    method_or_bust_with_type(sc, p, sc->exact_to_inexact_symbol, args, a_number_string, 0);

  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"
  #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_rational_symbol, sc->is_real_symbol)

  s7_pointer p;
  p = car(args);

  if (s7_is_rational(p))
    return(p);

  if (!s7_is_real(p))
    method_or_bust(sc, p, sc->inexact_to_exact_symbol, args, T_REAL, 0);
  return(big_rationalize(sc, args));
}
#endif

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))
    method_or_bust(sc, p, sym, args, T_REAL, 0);

  if (s7_is_integer(p))
    return(p);

  p = to_big(sc, p);
  if (is_t_big_ratio(p))
    {
      /* 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, (g_is_nan(sc, args) == sc->T) ? its_nan_string : its_infinite_string));

      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"
  #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  return(big_convert_to_int(sc, args, sc->floor_symbol, 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"
  #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  return(big_convert_to_int(sc, args, sc->ceiling_symbol, 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"
  #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  return(big_convert_to_int(sc, args, sc->truncate_symbol, 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"
  #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)

  s7_pointer p;
  mpz_t n;

  p = car(args);
  if (!s7_is_real(p))
    method_or_bust(sc, p, sc->round_symbol, args, T_REAL, 0);

  if (s7_is_integer(p))
    return(p);

  p = to_big(sc, p);
  if (is_t_big_integer(p))
    return(p);

  if (is_t_big_ratio(p))
    {
      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_symbol, p, (g_is_nan(sc, args) == sc->T) ? its_nan_string : its_infinite_string));

  {
    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"
  #define Q_quotient pcl_r

  s7_pointer x, y, p;
  x = car(args);
  y = cadr(args);

  if (!s7_is_real(x))
    method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 1);

  if (!s7_is_real(y))
    method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2);

  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_symbol, 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, set_plist_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"
  #define Q_remainder pcl_r

  s7_pointer x, y, p;
  x = car(args);
  y = cadr(args);

  if (!s7_is_real(x))
    method_or_bust(sc, x, sc->remainder_symbol, args, T_REAL, 1);

  if (!s7_is_real(y))
    method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2);

  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_symbol, 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,
            set_plist_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."
  #define Q_modulo pcl_r

  s7_pointer a, b, p;

  a = car(args);
  if (!s7_is_real(a))
    method_or_bust(sc, a, sc->modulo_symbol, args, T_REAL, 1);

  b = cadr(args);
  if (!s7_is_real(b))
    method_or_bust(sc, b, sc->modulo_symbol, args, T_REAL, 2);

  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,
              set_plist_1(sc,
               big_divide(sc,
	        set_plist_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 (!is_real_via_method(sc, p))
	return(-i);
      result_type = get_result_type(sc, result_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)
    return(wrong_type_argument(sc, sc->max_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));

  if (result_type < T_BIG_INTEGER)
    return(g_max(sc, args));

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->max_symbol, args);

  result = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->max_symbol, cons(sc, result, 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)
    return(wrong_type_argument(sc, sc->min_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));

  if (result_type < T_BIG_INTEGER)
    return(g_min(sc, args));

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->min_symbol, args);

  result = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->min_symbol, cons(sc, result, 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"
  #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  int result_type;
  s7_pointer x, previous, current;

  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    return(wrong_type_argument(sc, sc->lt_symbol, -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;

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->lt_symbol, args);

  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->lt_symbol, cons(sc, previous, 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"
  #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  int result_type;
  s7_pointer x, previous, current;

  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    return(wrong_type_argument(sc, sc->leq_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));

  if (result_type < T_BIG_INTEGER)
    result_type += 4;

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->leq_symbol, args);

  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->leq_symbol, cons(sc, previous, 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"
  #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  int result_type;
  s7_pointer x, previous, current;

  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    return(wrong_type_argument(sc, sc->gt_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));

  if (result_type < T_BIG_INTEGER)
    result_type += 4;

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->gt_symbol, args);

  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->gt_symbol, cons(sc, previous, 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"
  #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)

  int result_type;
  s7_pointer x, previous, current;

  result_type = big_real_scan_args(sc, args);
  if (result_type < 0)
    return(wrong_type_argument(sc, sc->geq_symbol, -result_type, s7_list_ref(sc, args, -1 - result_type), T_REAL));

  if (result_type < T_BIG_INTEGER)
    result_type += 4;

  if (!s7_is_number(car(args)))
    check_method(sc, car(args), sc->geq_symbol, args);
  previous = promote_number(sc, result_type, car(args));

  for (x = cdr(args); is_not_null(x); x = cdr(x))
    {
      if (!s7_is_number(car(x)))
	check_method(sc, car(x), sc->geq_symbol, cons(sc, previous, 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)
{
  #define Q_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)

  /* this is morally-equal? for bignums, the other case goes through big_numbers_are_eqv */
  int result_type = T_INTEGER;
  s7_pointer x, y, result;
  bool got_nan = false;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      s7_pointer p;
      p = car(x);
      if (!s7_is_number(p))
	{
	  check_method(sc, car(args), sc->eq_symbol, x);
	  return(wrong_type_argument_with_type(sc, sc->eq_symbol, position_of(x, args), p, a_number_string));
	}

      result_type = get_result_type(sc, result_type, p);
      if (!got_nan)
	got_nan = (((is_t_real(p)) && (is_NaN(real(p)))) ||  /* (= (bignum "3") 1/0) */
		   ((is_t_complex(p)) && ((is_NaN(real_part(p))) || (is_NaN(imag_part(p))))));
    }
  if (got_nan) return(sc->F); /* put this off until here so that non-numbers anywhere in the arg list will raise an error */

  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: 
	  {
	    mpfr_t *a1;
	    a1 = s7_double_to_mpfr(sc->morally_equal_float_epsilon);
	    if (mpfr_cmp(big_real(big_abs(sc, set_plist_1(sc, big_subtract(sc, set_plist_2(sc, result, arg))))), *a1) > 0)
	      return(sc->F);
	  }
	  break;

	case T_BIG_COMPLEX: 
	  {
	    mpfr_t *a1;
	    a1 = s7_double_to_mpfr(sc->morally_equal_float_epsilon);
	    if (mpfr_cmp(big_real(big_magnitude(sc, set_plist_1(sc, big_subtract(sc, set_plist_2(sc, result, arg))))), *a1) > 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"
  #define Q_gcd pcl_f

  bool rats = false;
  s7_pointer x, lst;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!is_rational_via_method(sc, car(x)))
	return(wrong_type_argument_with_type(sc, sc->gcd_symbol, position_of(x, args), car(x), a_rational_string));
      if (!rats)
	rats = (!is_integer_via_method(sc, 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))
	{
	  if (!s7_is_number(car(x)))
	    {
	      lst = cons(sc, mpz_to_big_integer(sc, n), x);
	      mpz_clear(n);
	      method_or_bust(sc, car(x), sc->gcd_symbol, lst, T_INTEGER, position_of(x, args));
	    }
	  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;

    if (!s7_is_number(car(args)))
      check_method(sc, car(args), sc->gcd_symbol, args);

    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))
      {
	if (!s7_is_number(car(x)))
	  {
	    mpq_init(q);
	    mpq_set_num(q, n);
	    mpq_set_den(q, d);
	    lst = cons(sc, mpq_to_big_ratio(sc, q), x);
	    mpz_clear(n);
	    mpz_clear(d);
	    mpq_clear(q);
	    method_or_bust_with_type(sc, car(x), sc->gcd_symbol, lst, a_rational_string, position_of(x, args));
	  }
	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"
  #define Q_lcm pcl_f

  s7_pointer x, lst;
  bool rats = false;

  for (x = args; is_not_null(x); x = cdr(x))
    {
      if (!is_rational_via_method(sc, car(x)))
	return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(x, args), car(x), a_rational_string));
      if (!rats)
	rats = (!is_integer_via_method(sc, 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))
	{
	  if (!s7_is_number(car(x)))
	    {
	      lst = cons(sc, mpz_to_big_integer(sc, n), x);
	      mpz_clear(n);
	      method_or_bust(sc, car(x), sc->lcm_symbol, lst, T_INTEGER, position_of(x, args));
	    }
	  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;

    if (!s7_is_number(car(args)))
      check_method(sc, car(args), sc->lcm_symbol, args);

    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))
      {
	if (!s7_is_number(car(x)))
	  {
	    mpq_init(q);
	    mpq_set_num(q, n);
	    mpq_set_den(q, d);
	    lst = cons(sc, mpq_to_big_ratio(sc, q), x);
	    mpz_clear(n);
	    mpz_clear(d);
	    mpq_clear(q);
	    method_or_bust_with_type(sc, car(x), sc->lcm_symbol, lst, a_rational_string, position_of(x, args));
	  }

	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 set_bignum_precision(s7_scheme *sc, int precision)
{
  mp_prec_t bits;
  if (precision <= 1)                   /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */
    return(s7_out_of_range_error(sc, "set! (*s7* 'bignum-precision)", 0, make_integer(sc, precision), "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_symbol, big_pi(sc));
  return(sc->F);
}


static s7_pointer big_random_state(s7_scheme *sc, s7_pointer args)
{
  #define H_random_state "(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 (random-state 1234))) (random 1.0 seed))"
  #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)

  s7_pointer r, seed;
  seed = car(args);
  if (!s7_is_integer(seed))
    method_or_bust(sc, seed, sc->random_state_symbol, args, T_INTEGER, 0);

  if (type(seed) != T_BIG_INTEGER)
    seed = promote_number(sc, T_BIG_INTEGER, seed);

  new_cell(sc, r, T_RANDOM_STATE);
  gmp_randinit_default(random_gmp_state(r));
  gmp_randseed(random_gmp_state(r), big_integer(seed));
  return(r);
}


static s7_pointer big_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)."
  #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
  s7_pointer num, state, x;

  num = car(args);
  if (!s7_is_number(num))
    method_or_bust_with_type(sc, num, sc->random_symbol, args, a_number_string, 1);

  state = sc->default_rng;
  if (is_not_null(cdr(args)))
    {
      state = cadr(args);
      if (!is_random_state(state))
	return(wrong_type_argument_with_type(sc, sc->random_symbol, 2, state, a_random_state_object_string));
    }

  if (s7_is_zero(num))
    return(num);

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

  switch (type(num))
    {
    case T_BIG_INTEGER:
      {
	mpz_t n;
	mpz_init(n);
	mpz_urandomm(n, random_gmp_state(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, random_gmp_state(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 (sc->default_rationalize_error = 1e-12 here)
	 *   clobbers everything to 0.
	 */
	x = big_rationalize(sc, set_plist_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, random_gmp_state(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, random_gmp_state(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(sc->F); /* make the compiler happy */
}

s7_double s7_random(s7_scheme *sc, s7_pointer state)
{
  s7_pointer p;
  p = big_random(sc, set_plist_1(sc, (state) ? state : sc->default_rng));
  return((s7_double)mpfr_get_d(big_real(p), GMP_RNDN));
}


static void s7_gmp_init(s7_scheme *sc)
{
  #define big_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_typed_function(sc, Scheme_Name, big_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
  #define c_big_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_typed_function(sc, Scheme_Name, c_big_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)

  sc->add_symbol =              big_defun("+",                add,              0, 0, true);
  sc->subtract_symbol =         big_defun("-",                subtract,         1, 0, true);
  sc->multiply_symbol =         big_defun("*",                multiply,         0, 0, true);
  sc->divide_symbol =           big_defun("/",                divide,           1, 0, true);
  sc->max_symbol =              big_defun("max",              max,              1, 0, true);
  sc->min_symbol =              big_defun("min",              min,              1, 0, true);
  sc->lt_symbol =               big_defun("<",                less,             2, 0, true);
  sc->leq_symbol =              big_defun("<=",               less_or_equal,    2, 0, true);
  sc->gt_symbol =               big_defun(">",                greater,          2, 0, true);
  sc->geq_symbol =              big_defun(">=",               greater_or_equal, 2, 0, true);
  sc->eq_symbol =               big_defun("=",                equal,            2, 0, true);
  sc->rationalize_symbol =      big_defun("rationalize",      rationalize,      1, 1, false);
#if (!WITH_PURE_S7)
  sc->exact_to_inexact_symbol = big_defun("exact->inexact",   exact_to_inexact, 1, 0, false);
  sc->inexact_to_exact_symbol = big_defun("inexact->exact",   inexact_to_exact, 1, 0, false);
  sc->integer_length_symbol =   big_defun("integer-length",   integer_length,   1, 0, false);
  sc->make_rectangular_symbol = c_big_defun("make-rectangular", complex,        2, 0, false);
  sc->make_polar_symbol =       big_defun("make-polar",       make_polar,       2, 0, false);
#endif
  sc->floor_symbol =            big_defun("floor",            floor,            1, 0, false);
  sc->ceiling_symbol =          big_defun("ceiling",          ceiling,          1, 0, false);
  sc->truncate_symbol =         big_defun("truncate",         truncate,         1, 0, false);
  sc->round_symbol =            big_defun("round",            round,            1, 0, false);
  sc->quotient_symbol =         big_defun("quotient",         quotient,         2, 0, false);
  sc->remainder_symbol =        big_defun("remainder",        remainder,        2, 0, false);
  sc->modulo_symbol =           big_defun("modulo",           modulo,           2, 0, false);
  sc->gcd_symbol =              big_defun("gcd",              gcd,              0, 0, true);
  sc->lcm_symbol =              big_defun("lcm",              lcm,              0, 0, true);
  sc->complex_symbol =          c_big_defun("complex",        complex,          2, 0, false);
  sc->magnitude_symbol =        big_defun("magnitude",        magnitude,        1, 0, false);
  sc->angle_symbol =            big_defun("angle",            angle,            1, 0, false);
  sc->abs_symbol =              big_defun("abs",              abs,              1, 0, false);
  sc->lognot_symbol =           big_defun("lognot",           lognot,           1, 0, false);
  sc->logior_symbol =           big_defun("logior",           logior,           0, 0, true);
  sc->logxor_symbol =           big_defun("logxor",           logxor,           0, 0, true);
  sc->logand_symbol =           big_defun("logand",           logand,           0, 0, true);
  sc->ash_symbol =              big_defun("ash",              ash,              2, 0, false);
  sc->exp_symbol =              big_defun("exp",              exp,              1, 0, false);
  sc->expt_symbol =             big_defun("expt",             expt,             2, 0, false);
  sc->log_symbol =              big_defun("log",              log,              1, 1, false);
  sc->sqrt_symbol =             big_defun("sqrt",             sqrt,             1, 0, false);
  sc->sin_symbol =              big_defun("sin",              sin,              1, 0, false);
  sc->cos_symbol =              big_defun("cos",              cos,              1, 0, false);
  sc->tan_symbol =              big_defun("tan",              tan,              1, 0, false);
  sc->asin_symbol =             big_defun("asin",             asin,             1, 0, false);
  sc->acos_symbol =             big_defun("acos",             acos,             1, 0, false);
  sc->atan_symbol =             big_defun("atan",             atan,             1, 1, false);
  sc->sinh_symbol =             big_defun("sinh",             sinh,             1, 0, false);
  sc->cosh_symbol =             big_defun("cosh",             cosh,             1, 0, false);
  sc->tanh_symbol =             big_defun("tanh",             tanh,             1, 0, false);
  sc->asinh_symbol =            big_defun("asinh",            asinh,            1, 0, false);
  sc->acosh_symbol =            big_defun("acosh",            acosh,            1, 0, false);
  sc->atanh_symbol =            big_defun("atanh",            atanh,            1, 0, false);

  sc->random_symbol =           big_defun("random",           random,           1, 1, false);
  sc->random_state_symbol =     big_defun("random-state",     random_state,     1, 1, false);

  sc->is_bignum_symbol =        big_defun("bignum?",          is_bignum,        1, 0, false); /* needed by Q_bignum below */
  sc->bignum_symbol =           big_defun("bignum",           bignum,           1, 1, false);

  sc->bignum_precision = DEFAULT_BIGNUM_PRECISION;
  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_symbol, 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 */



/* -------------------------------- *s7* environment -------------------------------- */

static void init_s7_let(s7_scheme *sc)
{
  sc->stack_top_symbol =                     s7_make_symbol(sc, "stack-top");
  sc->stack_size_symbol =                    s7_make_symbol(sc, "stack-size");
  sc->stacktrace_defaults_symbol =           s7_make_symbol(sc, "stacktrace-defaults");
  sc->symbol_table_is_locked_symbol =        s7_make_symbol(sc, "symbol-table-locked?");
  sc->heap_size_symbol =                     s7_make_symbol(sc, "heap-size");
  sc->free_heap_size_symbol =                s7_make_symbol(sc, "free-heap-size");
  sc->gc_freed_symbol =                      s7_make_symbol(sc, "gc-freed");
  sc->gc_protected_objects_symbol =          s7_make_symbol(sc, "gc-protected-objects");
  set_immutable(sc->gc_protected_objects_symbol);

  sc->input_ports_symbol =                   s7_make_symbol(sc, "input-ports");
  sc->output_ports_symbol =                  s7_make_symbol(sc, "output-ports");
  sc->strings_symbol =                       s7_make_symbol(sc, "strings");
  sc->gensyms_symbol =                       s7_make_symbol(sc, "gensyms");
  sc->vectors_symbol =                       s7_make_symbol(sc, "vectors");
  sc->hash_tables_symbol =                   s7_make_symbol(sc, "hash-tables");
  sc->continuations_symbol =                 s7_make_symbol(sc, "continuations");

  sc->c_objects_symbol =                     s7_make_symbol(sc, "c-objects");
  sc->file_names_symbol =                    s7_make_symbol(sc, "file-names");
  sc->symbol_table_symbol =                  s7_make_symbol(sc, "symbol-table");
  sc->rootlet_size_symbol =                  s7_make_symbol(sc, "rootlet-size");
  sc->c_types_symbol =                       s7_make_symbol(sc, "c-types");
  sc->safety_symbol =                        s7_make_symbol(sc, "safety");
  sc->undefined_identifier_warnings_symbol = s7_make_symbol(sc, "undefined-identifier-warnings");
  sc->gc_stats_symbol =                      s7_make_symbol(sc, "gc-stats");
  sc->max_stack_size_symbol =                s7_make_symbol(sc, "max-stack-size");
  sc->cpu_time_symbol =                      s7_make_symbol(sc, "cpu-time");
  sc->catches_symbol =                       s7_make_symbol(sc, "catches");
  sc->exits_symbol =                         s7_make_symbol(sc, "exits");
  sc->stack_symbol =                         s7_make_symbol(sc, "stack");
  sc->max_string_length_symbol =             s7_make_symbol(sc, "max-string-length");
  sc->max_list_length_symbol =               s7_make_symbol(sc, "max-list-length");
  sc->max_vector_length_symbol =             s7_make_symbol(sc, "max-vector-length");
  sc->max_vector_dimensions_symbol =         s7_make_symbol(sc, "max-vector-dimensions");
  sc->default_hash_table_length_symbol =     s7_make_symbol(sc, "default-hash-table-length");
  sc->initial_string_port_length_symbol =    s7_make_symbol(sc, "initial-string-port-length");
  sc->default_rationalize_error_symbol =     s7_make_symbol(sc, "default-rationalize-error");
  sc->default_random_state_symbol =          s7_make_symbol(sc, "default-random-state");
  sc->morally_equal_float_epsilon_symbol =   s7_make_symbol(sc, "morally-equal-float-epsilon");
  sc->hash_table_float_epsilon_symbol =      s7_make_symbol(sc, "hash-table-float-epsilon");
  sc->print_length_symbol =                  s7_make_symbol(sc, "print-length");
  sc->bignum_precision_symbol =              s7_make_symbol(sc, "bignum-precision");
  sc->memory_usage_symbol =                  s7_make_symbol(sc, "memory-usage");
  sc->float_format_precision_symbol =        s7_make_symbol(sc, "float-format-precision");
  sc->history_size_symbol =                  s7_make_symbol(sc, "history-size");
  sc->profile_info_symbol =                  s7_make_symbol(sc, "profile-info");
}

#ifdef __linux__
  #include <sys/resource.h>
#endif

static s7_pointer describe_memory_usage(s7_scheme *sc)
{
  /* heap, permanent, stack?, doc strings, sigs, c_func structs (and ports etc), vcts, mx_alloc, output bufs,
   *   sinc_tables, c-objects, rc_data, strbuf/tmpbuf[reallocs], autoload tables, hash_entrys, symbol_table,
   *   small_ints?
   */
  int i, syms = 0, len;
  s7_pointer x;

#ifdef __linux__
  struct rusage info;
  getrusage(RUSAGE_SELF, &info);
  fprintf(stderr, "process size: %lld\n", (s7_int)(info.ru_maxrss * 1024));
#endif

  fprintf(stderr, "heap: %u (%lld bytes)", sc->heap_size, (s7_int)(sc->heap_size * (sizeof(s7_pointer) + sizeof(s7_cell))));
  {
    unsigned int k;
    int ts[NUM_TYPES];
    for (i = 0; i < NUM_TYPES; i++) ts[i] = 0;
    for (k = 0; k < sc->heap_size; k++)
      ts[unchecked_type(sc->heap[k])]++;
    for (i = 0; i < NUM_TYPES; i++)
      {
	if ((i % 10) == 0) fprintf(stderr, "\n ");
	fprintf(stderr, " %d", ts[i]);
      }
    fprintf(stderr, "\n");
  }
  fprintf(stderr, "permanent cells: %d (%lld bytes)\n", permanent_cells, (s7_int)(permanent_cells * sizeof(s7_cell)));

  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))
      syms++;
  fprintf(stderr, "symbol table: %d (%d symbols, %lld bytes)\n", SYMBOL_TABLE_SIZE, syms, 
	  (s7_int)(SYMBOL_TABLE_SIZE * sizeof(s7_pointer) + syms * 3 * sizeof(s7_cell)));

  fprintf(stderr, "stack: %u (%lld bytes)\n", sc->stack_size, (s7_int)(sc->stack_size * sizeof(s7_pointer)));
  fprintf(stderr, "c_functions: %d (%d bytes)\n", c_functions, (int)(c_functions * sizeof(c_proc_t)));

  len = 0;
  for (i = 0; i < (int)(sc->strings_loc); i++)
    len += string_length(sc->strings[i]);
  fprintf(stderr, "strings: %u, %d bytes\n", sc->strings_loc, len); /* also doc strings, permanent strings, etc */

  {
    int hs;
    hash_entry_t *p;
    for (hs = 0, p = hash_free_list; p; p = (hash_entry_t *)(p->next), hs++);

    len = 0;
    for (i = 0; i < (int)(sc->hash_tables_loc); i++)
      len += (hash_table_mask(sc->hash_tables[i]) + 1);
    
    fprintf(stderr, "hash tables: %d (%d %d), ", (int)(sc->hash_tables_loc), len, hs);
  }

  {
    int fs;
    port_t *p;
    for (fs = 0, p = sc->port_heap; p; p = (port_t *)(p->next), fs++);
    fprintf(stderr, "vectors: %u, input: %u, output: %u, free port: %d\ncontinuations: %u, c_objects: %u, gensyms: %u, setters: %u\n",
	    sc->vectors_loc, sc->input_ports_loc, sc->output_ports_loc, fs, sc->continuations_loc, sc->c_objects_loc, sc->gensyms_loc, sc->setters_loc);
  }
  return(sc->F);
}

static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym;

  sym = cadr(args);
  if (!is_symbol(sym))
    return(simple_wrong_type_argument(sc, sc->let_ref_symbol, sym, T_SYMBOL));

  if (sym == sc->print_length_symbol)                                    /* print-length */
    return(s7_make_integer(sc, sc->print_length));

  if (sym == sc->stack_top_symbol)                                       /* stack-top = how many frames active (4 stack entries per frame) */
    return(s7_make_integer(sc, (sc->stack_end - sc->stack_start) / 4));
  if (sym == sc->stack_size_symbol)                                      /* stack-size (max so far) */
    return(s7_make_integer(sc, sc->stack_size));
  if (sym == sc->max_stack_size_symbol)                                  /* max-stack-size */
    return(s7_make_integer(sc, sc->max_stack_size));
  if (sym == sc->stacktrace_defaults_symbol)                             /* stacktrace-defaults (used to be *stacktrace*) */
    return(sc->stacktrace_defaults);

  if (sym == sc->symbol_table_is_locked_symbol)                          /* symbol-table-locked? */
    return(make_boolean(sc, sc->symbol_table_is_locked));
  if (sym == sc->symbol_table_symbol)                                    /* symbol-table (the raw vector) */
    return(sc->symbol_table);
  if (sym == sc->rootlet_size_symbol)                                    /* rootlet-size */
    return(s7_make_integer(sc, sc->rootlet_entries));
  if (sym == sc->safety_symbol)                                          /* safety */
    return(s7_make_integer(sc, sc->safety));
  if (sym == sc->undefined_identifier_warnings_symbol)                   /* undefined-identifier-warnings */
    return(s7_make_boolean(sc, sc->undefined_identifier_warnings));
  if (sym == sc->cpu_time_symbol)                                        /* cpu-time */
    return(s7_make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC));
  if (sym == sc->catches_symbol)                                         /* catches */
    return(active_catches(sc));
  if (sym == sc->exits_symbol)                                           /* exits */
    return(active_exits(sc));
  if (sym == sc->stack_symbol)                                           /* stack */
    return(stack_entries(sc, sc->stack, s7_stack_top(sc)));

  if (sym == sc->heap_size_symbol)                                       /* heap-size */
    return(s7_make_integer(sc, sc->heap_size));
  if (sym == sc->free_heap_size_symbol)                                  /* free-heap-size (number of unused cells in the heap) */
    return(s7_make_integer(sc, sc->free_heap_top - sc->free_heap));
  if (sym == sc->gc_freed_symbol)                                        /* gc-freed = how many cells freed during last GC sweep */
    return(s7_make_integer(sc, sc->gc_freed));
  if (sym == sc->gc_protected_objects_symbol)                            /* gc-protected-objects */
    return(sc->protected_objects);
  if (sym == sc->gc_stats_symbol)                                        /* gc-stats */
    return(make_integer(sc, sc->gc_stats));

  if (sym == sc->default_rationalize_error_symbol)                       /* default-rationalize-error */
    return(make_real(sc, sc->default_rationalize_error));
  if (sym == sc->default_random_state_symbol)                            /* default-random-state */
    return(sc->default_rng);

  if (sym == sc->history_size_symbol)                                    /* history-size (eval history circular buffer size) */
    return(s7_make_integer(sc, sc->history_size));
  if (sym == sc->profile_info_symbol)                                    /* profile-info -- profiling data hash-table */
    return(sc->profile_info);
  if (sym == sc->max_list_length_symbol)                                 /* max-list-length (as arg to make-list) */
    return(s7_make_integer(sc, sc->max_list_length));
  if (sym == sc->max_vector_length_symbol)                               /* max-vector-length (as arg to make-vector and make-hash-table) */
    return(s7_make_integer(sc, sc->max_vector_length));
  if (sym == sc->max_vector_dimensions_symbol)                           /* max-vector-dimensions (make-vector) */
    return(s7_make_integer(sc, sc->max_vector_dimensions));
  if (sym == sc->max_string_length_symbol)                               /* max-string-length (as arg to make-string and read-string) */
    return(s7_make_integer(sc, sc->max_string_length));
  if (sym == sc->default_hash_table_length_symbol)                       /* default size for make-hash-table */
    return(s7_make_integer(sc, sc->default_hash_table_length));
  if (sym == sc->morally_equal_float_epsilon_symbol)                     /* morally-equal-float-epsilon */
    return(s7_make_real(sc, sc->morally_equal_float_epsilon));
  if (sym == sc->hash_table_float_epsilon_symbol)                        /* hash-table-float-epsilon */
    return(s7_make_real(sc, sc->hash_table_float_epsilon));
  if (sym == sc->initial_string_port_length_symbol)                      /* initial-string-port-length */
    return(s7_make_integer(sc, sc->initial_string_port_length));

  if (sym == sc->input_ports_symbol)                                     /* input-ports */
    return(make_vector_wrapper(sc, sc->input_ports_loc, sc->input_ports));
  if (sym == sc->output_ports_symbol)                                    /* output-ports */
    return(make_vector_wrapper(sc, sc->output_ports_loc, sc->output_ports));
  if (sym == sc->strings_symbol)                                         /* strings */
    return(make_vector_wrapper(sc, sc->strings_loc, sc->strings));
  if (sym == sc->gensyms_symbol)                                         /* gensyms */
    return(make_vector_wrapper(sc, sc->gensyms_loc, sc->gensyms));
  if (sym == sc->vectors_symbol)                                         /* vectors */
    return(make_vector_wrapper(sc, sc->vectors_loc, sc->vectors));
  if (sym == sc->hash_tables_symbol)                                     /* hash-tables */
    return(make_vector_wrapper(sc, sc->hash_tables_loc, sc->hash_tables));
  if (sym == sc->continuations_symbol)                                   /* continuations */
    return(make_vector_wrapper(sc, sc->continuations_loc, sc->continuations));
  if (sym == sc->c_objects_symbol)                                       /* c-objects */
    return(make_vector_wrapper(sc, sc->c_objects_loc, sc->c_objects));

  if (sym == sc->file_names_symbol)                                      /* file-names (loaded files) */
    return(make_vector_wrapper(sc, sc->file_names_top, sc->file_names));
  if (sym == sc->c_types_symbol)                                         /* c-types */
    {
      s7_pointer res;
      int i;
      sc->w = sc->nil;
      for (i = 0; i < num_object_types; i++)                             /* c-object type (tag) is i */
	sc->w = cons(sc, object_types[i]->scheme_name, sc->w);
      res = safe_reverse_in_place(sc, sc->w);                            /*  so car(types) has tag 0 */
      sc->w = sc->nil;
      return(res);
    }

  if (sym == sc->bignum_precision_symbol)                                /* bignum-precision */
    return(s7_make_integer(sc, sc->bignum_precision));
  if (sym == sc->float_format_precision_symbol)                          /* float-format-precision */
    return(s7_make_integer(sc, float_format_precision));
  if (sym == sc->memory_usage_symbol)                                    /* memory-usage */
    return(describe_memory_usage(sc));

  /* sc->unlet is a scheme vector of slots -- not very useful at the scheme level */
  return(sc->undefined);
}

static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args)
{
  s7_pointer sym, val;

  sym = cadr(args);
  if (!is_symbol(sym))
    return(simple_wrong_type_argument(sc, sc->let_set_symbol, sym, T_SYMBOL));

  val = caddr(args);

  if ((sym == sc->print_length_symbol) ||
      (sym == sc->max_vector_length_symbol) ||
      (sym == sc->max_vector_dimensions_symbol) ||
      (sym == sc->max_list_length_symbol) ||
      (sym == sc->history_size_symbol) ||
      (sym == sc->max_string_length_symbol))
    {
      if (s7_is_integer(val))
	{
	  s7_int iv;
	  iv = s7_integer(val);         /* might be bignum if gmp */
	  if (iv < 0)            
	    return(simple_out_of_range(sc, sym, val, make_string_wrapper(sc, "should be a positive integer")));
	  if (sym == sc->print_length_symbol)
	    sc->print_length = iv;
	  else
	    {
	      if (sym == sc->max_vector_length_symbol)
		sc->max_vector_length = iv;
	      else
		{
		  if (sym == sc->max_vector_dimensions_symbol)
		    sc->max_vector_dimensions = iv;
		  else
		    {
		      if (sym == sc->history_size_symbol)
			{
#if WITH_HISTORY
			  s7_pointer p1, p2;
			  if (iv > sc->true_history_size)
			    {
			      /* splice in the new cells, reattach the circles */
			      s7_pointer next1, next2;
			      next1 = cdr(sc->eval_history1);
			      next2 = cdr(sc->eval_history2);
			      set_cdr(sc->eval_history1, permanent_list(sc, iv - sc->true_history_size));
			      set_cdr(sc->eval_history2, permanent_list(sc, iv - sc->true_history_size));
			      for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
			      set_cdr(p1, next1);
			      set_cdr(p2, next2);
			      sc->true_history_size = iv;
			    }
			  sc->history_size = iv;
			  /* clear out both bufffers to avoid GC confusion */
			  for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2))
			    {
			      set_car(p1, sc->nil);
			      set_car(p2, sc->nil);
			      p1 = cdr(p1);
			      if (p1 == sc->eval_history1) break;
			    }
#else
			  sc->history_size = iv;
#endif
			}
		      else
			{
			  if (sym == sc->max_list_length_symbol)
			    sc->max_list_length = iv;
			  else sc->max_string_length = iv;
			}
		    }
		}
	    }
	  return(val);
	}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->gc_stats_symbol)
    {
      if (s7_is_boolean(val)) {sc->gc_stats = ((val == sc->T) ? GC_STATS : 0); return(val);}
      if (s7_is_integer(val)) {sc->gc_stats = s7_integer(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
    }

  if (sym == sc->symbol_table_is_locked_symbol) 
    {
      if (s7_is_boolean(val)) {sc->symbol_table_is_locked = (val == sc->T); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
    }

  if (sym == sc->max_stack_size_symbol)
    {
      if (s7_is_integer(val))
	{
	  s7_int size;
	  size = s7_integer(val);
	  if (size >= INITIAL_STACK_SIZE)
	    {
	      sc->max_stack_size = (unsigned int)size;
	      return(val);
	    }
	  return(simple_out_of_range(sc, sym, val, make_string_wrapper(sc, "should be greater than the initial stack size (512)")));
	}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->safety_symbol)
    {
      if (s7_is_integer(val)) {sc->safety = s7_integer(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->undefined_identifier_warnings_symbol)
    {
      if (s7_is_boolean(val)) {sc->undefined_identifier_warnings = s7_boolean(sc, val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
    }

  if (sym == sc->default_hash_table_length_symbol)
    {
      if (s7_is_integer(val)) {sc->default_hash_table_length = s7_integer(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->initial_string_port_length_symbol)
    {
      if (s7_is_integer(val)) {sc->initial_string_port_length = s7_integer(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->morally_equal_float_epsilon_symbol)
    {
      if (s7_is_real(val)) {sc->morally_equal_float_epsilon = s7_real(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_REAL));
    }

  if (sym == sc->hash_table_float_epsilon_symbol)
    {
      if (s7_is_real(val)) {sc->hash_table_float_epsilon = s7_real(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_REAL));
    }

  if (sym == sc->float_format_precision_symbol)
    {
      if (s7_is_integer(val)) {float_format_precision = s7_integer(val); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if (sym == sc->default_rationalize_error_symbol)
    {
      if (s7_is_real(val)) {sc->default_rationalize_error = real_to_double(sc, val, "set! default-rationalize-error"); return(val);}
      return(simple_wrong_type_argument(sc, sym, val, T_REAL));
    }

  if (sym == sc->default_random_state_symbol)
    {
      if (is_random_state(val))
	{
#if (!WITH_GMP)
	  random_seed(sc->default_rng) = random_seed(val);
	  random_carry(sc->default_rng) = random_carry(val);
#endif
	  return(val);
	}
      return(wrong_type_argument_with_type(sc, sym, 1, val, a_random_state_object_string));
    }

  if (sym == sc->stacktrace_defaults_symbol)
    {
      if (!is_pair(val))                
	return(simple_wrong_type_argument(sc, sym, val, T_PAIR));
      if (s7_list_length(sc, val) != 5) 
	return(simple_wrong_type_argument_with_type(sc, sym, val, make_string_wrapper(sc, "a list with 5 entries")));
      if (!is_integer(car(val)))        
	return(wrong_type_argument_with_type(sc, sym, 1, car(val), make_string_wrapper(sc, "an integer (stack frames)")));
      if (!is_integer(cadr(val)))       
	return(wrong_type_argument_with_type(sc, sym, 2, cadr(val), make_string_wrapper(sc, "an integer (cols-for-data)")));
      if (!is_integer(caddr(val)))      
	return(wrong_type_argument_with_type(sc, sym, 3, caddr(val), make_string_wrapper(sc, "an integer (line length)")));
      if (!is_integer(cadddr(val)))     
	return(wrong_type_argument_with_type(sc, sym, 4, cadddr(val), make_string_wrapper(sc, "an integer (comment position)")));
      if (!s7_is_boolean(s7_list_ref(sc,val, 4))) 
	return(wrong_type_argument_with_type(sc, sym, 5, s7_list_ref(sc, val, 4), make_string_wrapper(sc, "a boolean (treat-data-as-comment)")));
      sc->stacktrace_defaults = copy_list(sc, val);
      return(val);
    }

  if (sym == sc->bignum_precision_symbol)
    {
      if (s7_is_integer(val))
	{
	  sc->bignum_precision = s7_integer(val);
#if WITH_GMP
	  set_bignum_precision(sc, sc->bignum_precision);
#endif
	  return(val);
	}
      return(simple_wrong_type_argument(sc, sym, val, T_INTEGER));
    }

  if ((sym == sc->cpu_time_symbol) || 
      (sym == sc->heap_size_symbol) || (sym == sc->free_heap_size_symbol) ||
      (sym == sc->gc_freed_symbol) || (sym == sc->gc_protected_objects_symbol) ||
      (sym == sc->file_names_symbol) || (sym == sc->c_types_symbol) || (sym == sc->catches_symbol) || (sym == sc->exits_symbol) || 
      (sym == sc->rootlet_size_symbol) || (sym == sc->profile_info_symbol) ||
      (sym == sc->stack_top_symbol) || (sym == sc->stack_size_symbol))
    return(s7_error(sc, sc->error_symbol, set_elist_2(sc, make_string_wrapper(sc, "can't set (*s7* '~S)"), sym)));
      
  return(sc->undefined);
}

/* some procedure-signature support functions */

static s7_pointer g_is_float(s7_scheme *sc, s7_pointer args)
{
  #define H_is_float "(float? x) returns #t is x is real and not rational."
  #define Q_is_float pl_bt
  s7_pointer p;
  p = car(args);
  return(make_boolean(sc, ((is_real(p)) && (!is_rational(p)))));
}

static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args)
{
  #define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted."
  #define Q_is_proper_list pl_bt
  s7_pointer p;
  p = car(args);
  return(make_boolean(sc, is_proper_list(sc, p)));
}

/* how to handle this? (float-vector-set! and vector-set! signature entries) */
static s7_pointer g_is_integer_or_real_at_end(s7_scheme *sc, s7_pointer args) {return(sc->T);}
static s7_pointer g_is_integer_or_any_at_end(s7_scheme *sc, s7_pointer args) {return(sc->T);}


#ifndef _MSC_VER
/* gdb stacktrace decoding */

static bool is_decodable(s7_scheme *sc, s7_pointer p)
{
  int i;
  s7_pointer x;
  s7_pointer *tp, *heap_top;

  if ((void *)p == (void *)sc) return(false);

  /* check basic constants */
  if ((p == sc->nil) || (p == sc->T) || (p == sc->F) || (p == sc->eof_object) || (p == sc->else_object) || (p == sc->rootlet) ||
      (p == sc->undefined) || (p == sc->unspecified) || (p == sc->no_value) || (p == sc->gc_nil) ||
      (p == sc->t1_1) || (p == sc->t2_1) || (p == sc->t3_1) || (p == sc->a1_1) || (p == sc->a2_1) || (p == sc->a3_1) || (p == sc->a4_1))
    return(true);

  /* check symbol-table */
  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;
	sym = car(x);
	if ((sym == p) ||
	    ((is_global(sym)) && (is_slot(global_slot(sym))) && (p == slot_value(global_slot(sym)))))
	  return(true);
      }

  for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true);
  for (i = 0; i <= NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true);
  /* also real_one and friends, sc->safe_lists, tmp_strs? p|elist? */

  /* check the heap */
  tp = sc->heap;
  heap_top = (s7_pointer *)(sc->heap + sc->heap_size);
  while (tp < heap_top)
    if (p == (*tp++))
      return(true);

  return(false);
}

char *s7_decode_bt(void)
{
  FILE *fp;
  fp = fopen("gdb.txt", "r");
  if (fp)
    {
      long i, size;
      size_t bytes;
      bool in_quotes = false;
      unsigned char *bt;
      s7_scheme *sc;
      sc = hidden_sc;

      fseek(fp, 0, SEEK_END);
      size = ftell(fp);
      rewind(fp);

      bt = (unsigned char *)malloc((size + 1) * sizeof(unsigned char));
      bytes = fread(bt, sizeof(unsigned char), size, fp);
      if (bytes != (size_t)size)
	{
	  fclose(fp);
	  free(bt);
	  return((char *)" oops ");
	}
      bt[size] = '\0';
      fclose(fp);

      for (i = 0; i < size; i++)
	{
	  fputc(bt[i], stdout);
	  if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\')))
	    in_quotes = (!in_quotes);
	  else
	    {
	      if ((!in_quotes) && (i < size - 8))
		{
		  if ((bt[i] == '=') &&
		      (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) ||
		       ((bt[i + 1] == ' ') && (bt[i + 2] == '0') && (bt[i + 3] == 'x'))))
		    {
		      void *vp;
		      int vals;
		      vals = sscanf((const char *)(bt + i + 1), "%p", &vp);
		      if (vals == 1)
			{
			  int k;
			  for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); (k < size) && (IS_DIGIT(bt[k], 16)); k++);
			  if ((bt[k] != ' ') || (bt[k + 1] != '"'))
			    {
			      s7_pointer p;
			      p = (s7_pointer)vp;
			      if ((is_decodable(sc, p)) &&
				  (!is_free(p)))
				{
				  if (bt[i + 1] == ' ') fputc(' ', stdout);
				  i = k - 1;
				  if (s7_is_valid(sc, p))
				    {
				      char *str;
				      str = s7_object_to_c_string(sc, p);
				      fprintf(stdout, "%s%s%s", BOLD_TEXT, str, UNBOLD_TEXT);
				      free(str);
				    }
				  else 
				    {
				      if (is_free(p))
					fprintf(stderr, "%p: %sfree cell%s", p, BOLD_TEXT, UNBOLD_TEXT);
				      else fprintf(stderr, "%p: %sunprintable?%s", p, BOLD_TEXT, UNBOLD_TEXT);
				    }
				}
			    }
			}
		    }
		}
	    }
	}
      free(bt);
    }
  return((char *)"");
}
#endif


/* ---------------- an experiment ---------------- */
static s7_int tree_len(s7_scheme *sc, s7_pointer p, s7_int i)
{
  if (is_null(p))
    return(i);
  if ((!is_pair(p)) ||
      (car(p) == sc->quote_symbol))
    return(i + 1);
  return(tree_len(sc, car(p), tree_len(sc, cdr(p), i)));
}

static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args)
{
  return(s7_make_integer(sc, tree_len(sc, car(args), 0)));
}
 


/* -------------------------------- initialization -------------------------------- */

static s7_pointer make_unique_object(const char* name, unsigned int typ)
{
  s7_pointer p;
  p = alloc_pointer();
  set_type(p, typ | T_IMMUTABLE);
  unique_name_length(p) = safe_strlen(name);
  unique_name(p) = copy_string_with_length(name, unique_name_length(p));
  unheap(p);
  return(p);
}

s7_scheme *s7_init(void)
{
  int i;
  s7_scheme *sc;
  s7_pointer sym;
  static bool already_inited = false;

#ifndef _MSC_VER
  setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */
#endif

  if (!already_inited)
    {
      init_types();
      init_ctables();
      init_mark_functions();
      init_equals();
      init_hash_maps();
      init_pows();
#if (!WITH_GMP)
      init_add_ops();
      init_multiply_ops();
#endif
      init_uppers();
      all_x_function_init();
      init_catchers();
      /* sizeof(__float128) == sizeof(long double) so how to distinguish them for printf (L vs Q)? */
      /* if (sizeof(s7_double) >= 16) float_format_g = "%.*Qg"; */      /* __float128 */
      if (sizeof(s7_double) > 8)
	float_format_g = "%.*Lg";   /* long double (80-bit precision?) */
      else float_format_g = "%.*g"; /* float and double */
    }

  sc = (s7_scheme *)calloc(1, sizeof(s7_scheme)); /* malloc is not recommended here */
  hidden_sc = sc;                                 /* for gdb/debugging */
  sc->gc_off = true;                              /* sc->args and so on are not set yet, so a gc during init -> segfault */
  sc->gc_stats = 0;
  init_gc_caches(sc);

  sc->longjmp_ok = false;
  sc->setjmp_loc = NO_SET_JUMP;
  sc->symbol_table_is_locked = false;

  if (sizeof(s7_int) == 4)
    sc->max_vector_length = (1 << 24);
  else sc->max_vector_length = (1LL << 32);
  sc->max_string_length = 1073741824;
  sc->max_list_length = 1073741824;
  sc->max_vector_dimensions = 512;

  sc->strbuf_size = INITIAL_STRBUF_SIZE;
  sc->strbuf = (char *)calloc(sc->strbuf_size, sizeof(char));
  sc->tmpbuf = (char *)calloc(TMPBUF_SIZE, sizeof(char));
  sc->print_width = sc->max_string_length;
  sc->short_print = false;

  sc->initial_string_port_length = 128;
  sc->format_depth = -1;
  sc->slash_str_size = 0;
  sc->slash_str = NULL;

  sc->singletons = (s7_pointer *)calloc(256, sizeof(s7_pointer));
  sc->read_line_buf = NULL;
  sc->read_line_buf_size = 0;

  sc->cur_rf = NULL;
  sc->rf_free_list = NULL;
  sc->rf_stack = NULL;

  sc->nil =         make_unique_object("()",             T_NIL);
  sc->gc_nil =      make_unique_object("#<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->undefined =   make_unique_object("#<undefined>",   T_UNIQUE);
  sc->else_object = make_unique_object("else",           T_UNIQUE);
  /* "else" is added to the rootlet below -- can't do it here because the symbol table and environment don't exist yet. */
  sc->unspecified = make_unique_object("#<unspecified>", T_UNSPECIFIED);
  sc->no_value =    make_unique_object("#<unspecified>", T_UNSPECIFIED);

  set_car(sc->nil, set_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
   *    let_id which is the same as opt1 is unaffected.  To get the names
   *    built-in, I'll append unique_name and unique_name_length fields to
   *    the envr struct.
   */
  let_id(sc->nil) = -1;
  unique_cdr(sc->unspecified) = sc->unspecified;
  unique_cdr(sc->undefined) = sc->undefined;
  /* this way find_symbol of an undefined symbol returns #<undefined> not #<unspecified> */

  sc->temp_cell_1 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->temp_cell = permanent_cons(sc->temp_cell_1, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->temp_cell_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);

  sc->t1_1 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);

  sc->t2_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->t2_1 = permanent_cons(sc->nil, sc->t2_2, T_PAIR | T_IMMUTABLE);
  sc->z2_2 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->z2_1 = permanent_cons(sc->nil, sc->z2_2, T_PAIR | T_IMMUTABLE);

  sc->t3_3 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->t3_2 = permanent_cons(sc->nil, sc->t3_3, T_PAIR | T_IMMUTABLE);
  sc->t3_1 = permanent_cons(sc->nil, sc->t3_2, T_PAIR | T_IMMUTABLE);

  sc->a4_4 = permanent_cons(sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
  sc->a4_3 = permanent_cons(sc->nil, sc->a4_4, T_PAIR | T_IMMUTABLE);
  sc->a4_2 = permanent_cons(sc->nil, sc->a4_3, T_PAIR | T_IMMUTABLE);
  sc->a4_1 = permanent_cons(sc->nil, sc->a4_2, T_PAIR | T_IMMUTABLE);

  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++)
    sc->safe_lists[i] = permanent_list(sc, i);

  sc->input_port_stack = sc->nil;
  sc->code = sc->nil;
#if WITH_HISTORY
  sc->eval_history1 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
  sc->eval_history2 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
  {
    s7_pointer p1, p2;
    for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
    set_cdr(p1, sc->eval_history1);
    set_cdr(p2, sc->eval_history2);
    sc->cur_code = sc->eval_history1;
    sc->using_history1 = true;
  }
#else
  sc->cur_code = sc->F;
#endif
  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->temp5 = sc->nil;
  sc->temp6 = sc->nil;
  sc->temp7 = sc->nil;
  sc->temp8 = sc->nil;
  sc->temp9 = sc->nil;
  sc->temp10 = sc->nil;

  sc->begin_hook = NULL;
  sc->autoload_table = sc->nil;
  sc->autoload_names = NULL;
  sc->autoload_names_sizes = NULL;
  sc->autoloaded_already = NULL;
  sc->autoload_names_loc = 0;

  sc->port_heap = NULL;
  sc->permanent_objects = 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;
	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->gpofl = (unsigned int *)malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(unsigned int));
  sc->gpofl_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1;
  sc->protected_objects = s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE);

  sc->protected_accessors_size = INITIAL_PROTECTED_OBJECTS_SIZE;
  sc->protected_accessors_loc = 0;
  sc->protected_accessors = 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;
      vector_element(sc->protected_accessors, i) = sc->gc_nil;
      sc->gpofl[i] = i;
    }

  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);
  sc->max_stack_size = (1 << 30);

  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);
  unheap(sc->symbol_table);

  sc->tmp_strs = (s7_pointer *)malloc(2 * sizeof(s7_pointer));
  for (i = 0; i < 2; i++)
    {
      s7_pointer p;
      p = alloc_pointer();
      sc->tmp_strs[i] = p;
      unheap(p);
      set_type(p, T_STRING | T_SAFE_PROCEDURE);
      string_hash(p) = 0;
      string_needs_free(p) = false;
      string_length(p) = 0;
      string_value(p) = (char *)malloc(INITIAL_TMP_STR_SIZE * sizeof(char));
      string_temp_true_length(p) = INITIAL_TMP_STR_SIZE;
    }
  sc->typnam = NULL;
  sc->typnam_len = 0;
  sc->help_arglist = NULL;
  sc->default_rationalize_error = 1.0e-12;
  sc->hash_table_float_epsilon = 1.0e-12;
  sc->morally_equal_float_epsilon = 1.0e-15;
  sc->default_hash_table_length = 8;
  sc->gensym_counter = 0;
  sc->capture_let_counter = 0;
  sc->f_class = 0;
  sc->add_class = 0;
  sc->equal_class = 0;
  sc->let_number = 0;
  sc->format_column = 0;
  sc->file_names = NULL;
  sc->file_names_size = 0;
  sc->file_names_top = -1;
  sc->no_values = 0;
  sc->s7_call_line = 0;
  sc->s7_call_file = NULL;
  sc->s7_call_name = NULL;
  sc->safety = 0;
  sc->print_length = 8;
  sc->history_size = DEFAULT_HISTORY_SIZE;
  sc->true_history_size = DEFAULT_HISTORY_SIZE;
  sc->profile_info = sc->nil;
  sc->baffle_ctr = 0;
  sc->syms_tag = 0;
  sc->class_name_symbol = make_symbol(sc, "class-name");
  sc->circle_info = NULL;
  sc->fdats = (format_data **)calloc(8, sizeof(format_data *));
  sc->num_fdats = 8;
  sc->plist_1 = permanent_list(sc, 1);
  sc->plist_2 = permanent_list(sc, 2);
  sc->plist_3 = permanent_list(sc, 3);
  sc->elist_1 = permanent_list(sc, 1);
  sc->elist_2 = permanent_list(sc, 2);
  sc->elist_3 = permanent_list(sc, 3);
  sc->elist_4 = permanent_list(sc, 4);
  sc->elist_5 = permanent_list(sc, 5);
  sc->direct_str = s7_make_permanent_string(NULL);
  sc->undefined_identifier_warnings = false;
  sc->wrap_only = make_wrap_only(sc);
  sc->dox_slot_symbol = s7_make_symbol(sc, "(dox_slot)");

  sc->rootlet = s7_make_vector(sc, ROOTLET_SIZE);
  set_type(sc->rootlet, T_LET);
  sc->rootlet_entries = 0;
  for (i = 0; i < ROOTLET_SIZE; i++)
    vector_element(sc->rootlet, i) = sc->nil;
  sc->envir = sc->nil;
  sc->shadow_rootlet = sc->nil;

  if (!already_inited)
    {
      /* 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;
	    unheap(p);
	    integer(p) = i;
	  }
      }

      real_zero = make_permanent_real(0.0);
      real_one = make_permanent_real(1.0);
      real_NaN = make_permanent_real(NAN);
      real_infinity = make_permanent_real(INFINITY);
      real_minus_infinity = make_permanent_real(-INFINITY);
      real_pi = make_permanent_real(3.1415926535897932384626433832795029L); /* M_PI is not good enough for s7_double = long double */
      arity_not_set = make_permanent_integer_unchecked(CLOSURE_ARITY_NOT_SET);
      max_arity = make_permanent_integer_unchecked(MAX_ARITY);
      minus_one = make_permanent_integer_unchecked(-1);
      minus_two = make_permanent_integer_unchecked(-2);
      /* prebuilt null string is tricky mainly because it overlaps #u8() */

      /* 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;
	    unheap(cp);
	    character(cp) = c;
	    upper_character(cp) = (unsigned char)toupper(i);
	    is_char_alphabetic(cp) = (bool)isalpha(i);
	    is_char_numeric(cp) = (bool)isdigit(i);
	    is_char_whitespace(cp) = white_space[i];
	    is_char_uppercase(cp) = (((bool)isupper(i)) || ((i >= 192) && (i < 208)));
	    is_char_lowercase(cp) = (bool)islower(i);
	    chars[i] = cp;

            #define make_character_name(C, S) strncat((char *)(&(character_name(C))), S, character_name_length(C) = strlen(S))
	    switch (c)
	      {
	      case ' ':	       make_character_name(cp, "#\\space");     break;
	      case '\n':       make_character_name(cp, "#\\newline");   break;
	      case '\r':       make_character_name(cp, "#\\return");    break;
	      case '\t':       make_character_name(cp, "#\\tab");       break;
	      case '\0':       make_character_name(cp, "#\\null");      break;
	      case (char)0x1b: make_character_name(cp, "#\\escape");    break;
	      case (char)0x7f: make_character_name(cp, "#\\delete");    break;
	      case (char)7:    make_character_name(cp, "#\\alarm");     break;
	      case (char)8:    make_character_name(cp, "#\\backspace"); break;
	      default:
		{
                  #define P_SIZE 12
		  int len;
		  if ((c < 32) || (c >= 127))
		    len = snprintf((char *)(&(character_name(cp))), P_SIZE, "#\\x%x", c);
		  else len = snprintf((char *)(&(character_name(cp))), P_SIZE, "#\\%c", c);
		  character_name_length(cp) = len;
		  break;
		}
	      }
	  }
      }
    }

  make_standard_ports(sc);

  sc->syn_docs = (s7_pointer *)calloc(OP_MAX_DEFINED, sizeof(s7_pointer));
  #define QUOTE_HELP             "(quote obj) returns obj unevaluated.  'obj is an abbreviation for (quote obj)."
  #define IF_HELP                "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \
                                      if optional-false-stuff exists, it is evaluated."
  #define WHEN_HELP              "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last"
  #define UNLESS_HELP            "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last"
  #define BEGIN_HELP             "(begin ...) evaluates each form in its body, returning the value of the last one"
  #define SET_HELP               "(set! variable value) sets the value of variable to value."
  #define LET_HELP               "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\
                                      returning the value of the last form.  The let variables are local to it, and \
                                      are not available for use until all have been initialized."
  #define LET_STAR_HELP          "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \
                                      returning the value of the last form.  The let* variables are local to it, and are available immediately."
  #define LETREC_HELP            "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \
                                      (i.e. you can define local recursive functions)"
  #define LETREC_STAR_HELP       "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*"
  #define COND_HELP              "(cond (expr clause...)...) is like if..then.  Each expr is evaluated in order, and if one is not #f, \
                                      the associated clauses are evaluated, whereupon cond returns."
  #define AND_HELP               "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \
                                      as soon as one of them returns #f.  If all are non-#f, it returns the last value."
  #define OR_HELP                "(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."
  #define CASE_HELP              "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \
                                      match is found (via eqv?), the associated clauses are evaluated, and case returns."
  #define DO_HELP                "(do (vars...) (loop control and return value) ...) is a do-loop."
  #define LAMBDA_HELP            "(lambda args ...) returns a function."
  #define LAMBDA_STAR_HELP       "(lambda* args ...) returns a function; the args list can have default values, \
                                      the parameters themselves can be accessed via keywords."
  #define DEFINE_HELP            "(define var val) assigns val to the variable (symbol) var.  (define (func args) ...) is \
                                      shorthand for (define func (lambda args ...))"
  #define DEFINE_STAR_HELP       "(define* (func args) ...) defines a function with optional/keyword arguments."
  #define DEFINE_CONSTANT_HELP   "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val."
  #define DEFINE_MACRO_HELP      "(define-macro (mac args) ...) defines mac to be a macro."
  #define DEFINE_MACRO_STAR_HELP "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments."
  #define DEFINE_EXPANSION_HELP  "(define-expansion (mac args) ...) defines mac to be a read-time macro."
  #define DEFINE_BACRO_HELP      "(define-bacro (mac args) ...) defines mac to be a bacro."
  #define DEFINE_BACRO_STAR_HELP "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments."
  #define WITH_BAFFLE_HELP       "(with-baffle ...) evaluates its body in a context that is safe from outside interference."
  #define MACROEXPAND_HELP       "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call."
  #define WITH_LET_HELP          "(with-let env ...) evaluates its body in the environment env."

  sc->quote_symbol =             assign_syntax(sc, "quote",           OP_QUOTE,             small_int(1), small_int(1), QUOTE_HELP);
  sc->if_symbol =                assign_syntax(sc, "if",              OP_IF,                small_int(2), small_int(3), IF_HELP);
  sc->when_symbol =              assign_syntax(sc, "when",            OP_WHEN,              small_int(2), max_arity,    WHEN_HELP);
  sc->unless_symbol =            assign_syntax(sc, "unless",          OP_UNLESS,            small_int(2), max_arity,    UNLESS_HELP);
  sc->begin_symbol =             assign_syntax(sc, "begin",           OP_BEGIN,             small_int(0), max_arity,    BEGIN_HELP);
  sc->set_symbol =               assign_syntax(sc, "set!",            OP_SET,               small_int(2), small_int(2), SET_HELP);
  sc->let_symbol =               assign_syntax(sc, "let",             OP_LET,               small_int(2), max_arity,    LET_HELP);
  sc->let_star_symbol =          assign_syntax(sc, "let*",            OP_LET_STAR,          small_int(2), max_arity,    LET_STAR_HELP);
  sc->letrec_symbol =            assign_syntax(sc, "letrec",          OP_LETREC,            small_int(2), max_arity,    LETREC_HELP);
  sc->letrec_star_symbol =       assign_syntax(sc, "letrec*",         OP_LETREC_STAR,       small_int(2), max_arity,    LETREC_STAR_HELP);
  sc->cond_symbol =              assign_syntax(sc, "cond",            OP_COND,              small_int(1), max_arity,    COND_HELP);
  sc->and_symbol =               assign_syntax(sc, "and",             OP_AND,               small_int(0), max_arity,    AND_HELP);
  sc->or_symbol =                assign_syntax(sc, "or",              OP_OR,                small_int(0), max_arity,    OR_HELP);
  sc->case_symbol =              assign_syntax(sc, "case",            OP_CASE,              small_int(2), max_arity,    CASE_HELP);
  sc->do_symbol =                assign_syntax(sc, "do",              OP_DO,                small_int(2), max_arity,    DO_HELP); /* 2 because body can be null */
  sc->lambda_symbol =            assign_syntax(sc, "lambda",          OP_LAMBDA,            small_int(2), max_arity,    LAMBDA_HELP);
  sc->lambda_star_symbol =       assign_syntax(sc, "lambda*",         OP_LAMBDA_STAR,       small_int(2), max_arity,    LAMBDA_STAR_HELP);
  sc->define_symbol =            assign_syntax(sc, "define",          OP_DEFINE,            small_int(2), max_arity,    DEFINE_HELP);
  sc->define_star_symbol =       assign_syntax(sc, "define*",         OP_DEFINE_STAR,       small_int(2), max_arity,    DEFINE_STAR_HELP);
  sc->define_constant_symbol =   assign_syntax(sc, "define-constant", OP_DEFINE_CONSTANT,   small_int(2), max_arity,    DEFINE_CONSTANT_HELP);
  sc->define_macro_symbol =      assign_syntax(sc, "define-macro",    OP_DEFINE_MACRO,      small_int(2), max_arity,    DEFINE_MACRO_HELP);
  sc->define_macro_star_symbol = assign_syntax(sc, "define-macro*",   OP_DEFINE_MACRO_STAR, small_int(2), max_arity,    DEFINE_MACRO_STAR_HELP);
  sc->define_expansion_symbol =  assign_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION,  small_int(2), max_arity,    DEFINE_EXPANSION_HELP);
  sc->define_bacro_symbol =      assign_syntax(sc, "define-bacro",    OP_DEFINE_BACRO,      small_int(2), max_arity,    DEFINE_BACRO_HELP);
  sc->define_bacro_star_symbol = assign_syntax(sc, "define-bacro*",   OP_DEFINE_BACRO_STAR, small_int(2), max_arity,    DEFINE_BACRO_STAR_HELP);
  sc->with_baffle_symbol =       assign_syntax(sc, "with-baffle",     OP_WITH_BAFFLE,       small_int(1), max_arity,    WITH_BAFFLE_HELP);
  sc->macroexpand_symbol =       assign_syntax(sc, "macroexpand",     OP_MACROEXPAND,       small_int(1), small_int(1), MACROEXPAND_HELP);
  sc->with_let_symbol =          assign_syntax(sc, "with-let",        OP_WITH_LET,          small_int(1), max_arity,    WITH_LET_HELP);
  set_immutable(sc->with_let_symbol);

#if WITH_OPTIMIZATION
  syntax_rp(slot_value(global_slot(sc->set_symbol))) = set_rf;
  syntax_ip(slot_value(global_slot(sc->set_symbol))) = set_if;
  syntax_pp(slot_value(global_slot(sc->set_symbol))) = set_pf;
  syntax_rp(slot_value(global_slot(sc->if_symbol))) = if_rf;
  syntax_pp(slot_value(global_slot(sc->if_symbol))) = if_pf;
  syntax_pp(slot_value(global_slot(sc->or_symbol))) = or_pf;
  syntax_pp(slot_value(global_slot(sc->and_symbol))) = and_pf;
  syntax_pp(slot_value(global_slot(sc->quote_symbol))) = quote_pf;
#endif

  sc->quote_unchecked_symbol =       assign_internal_syntax(sc, "quote",       OP_QUOTE_UNCHECKED);
  sc->begin_unchecked_symbol =       assign_internal_syntax(sc, "begin",       OP_BEGIN_UNCHECKED);
  sc->with_baffle_unchecked_symbol = assign_internal_syntax(sc, "with-baffle", OP_WITH_BAFFLE_UNCHECKED);
  sc->let_unchecked_symbol =         assign_internal_syntax(sc, "let",         OP_LET_UNCHECKED);
  sc->let_star_unchecked_symbol =    assign_internal_syntax(sc, "let*",        OP_LET_STAR_UNCHECKED);
  sc->letrec_unchecked_symbol =      assign_internal_syntax(sc, "letrec",      OP_LETREC_UNCHECKED);
  sc->letrec_star_unchecked_symbol = assign_internal_syntax(sc, "letrec*",     OP_LETREC_STAR_UNCHECKED);
  sc->let_no_vars_symbol =           assign_internal_syntax(sc, "let",         OP_LET_NO_VARS);
  sc->let_c_symbol =                 assign_internal_syntax(sc, "let",         OP_LET_C);
  sc->let_s_symbol =                 assign_internal_syntax(sc, "let",         OP_LET_S);
  sc->let_all_c_symbol =             assign_internal_syntax(sc, "let",         OP_LET_ALL_C);
  sc->let_all_s_symbol =             assign_internal_syntax(sc, "let",         OP_LET_ALL_S);
  sc->let_all_x_symbol =             assign_internal_syntax(sc, "let",         OP_LET_ALL_X);
  sc->let_star_all_x_symbol =        assign_internal_syntax(sc, "let*",        OP_LET_STAR_ALL_X);
  sc->let_opcq_symbol =              assign_internal_syntax(sc, "let",         OP_LET_opCq);
  sc->let_opssq_symbol =             assign_internal_syntax(sc, "let",         OP_LET_opSSq);
  sc->let_opsq_symbol =              assign_internal_syntax(sc, "let",         OP_LET_opSq);
  sc->let_opsq_p_symbol =            assign_internal_syntax(sc, "let",         OP_LET_opSq_P);
  sc->let_one_symbol =               assign_internal_syntax(sc, "let",         OP_LET_ONE);
  sc->let_z_symbol =                 assign_internal_syntax(sc, "let",         OP_LET_Z);
  sc->let_all_opsq_symbol =          assign_internal_syntax(sc, "let",         OP_LET_ALL_opSq);
  sc->named_let_no_vars_symbol =     assign_internal_syntax(sc, "let",         OP_NAMED_LET_NO_VARS);
  sc->named_let_symbol =             assign_internal_syntax(sc, "let",         OP_NAMED_LET);
  sc->named_let_star_symbol =        assign_internal_syntax(sc, "let*",        OP_NAMED_LET_STAR);
  sc->let_star2_symbol =             assign_internal_syntax(sc, "let*",        OP_LET_STAR2);
  sc->with_let_unchecked_symbol =    assign_internal_syntax(sc, "with-let",    OP_WITH_LET_UNCHECKED);
  sc->with_let_s_symbol =            assign_internal_syntax(sc, "with-let",    OP_WITH_LET_S);
  sc->case_unchecked_symbol =        assign_internal_syntax(sc, "case",        OP_CASE_UNCHECKED);
  sc->case_simple_symbol =           assign_internal_syntax(sc, "case",        OP_CASE_SIMPLE);
  sc->case_simpler_symbol =          assign_internal_syntax(sc, "case",        OP_CASE_SIMPLER);
  sc->case_simpler_1_symbol =        assign_internal_syntax(sc, "case",        OP_CASE_SIMPLER_1);
  sc->case_simpler_ss_symbol =       assign_internal_syntax(sc, "case",        OP_CASE_SIMPLER_SS);
  sc->case_simplest_symbol =         assign_internal_syntax(sc, "case",        OP_CASE_SIMPLEST);
  sc->case_simplest_ss_symbol =      assign_internal_syntax(sc, "case",        OP_CASE_SIMPLEST_SS);
  sc->cond_unchecked_symbol =        assign_internal_syntax(sc, "cond",        OP_COND_UNCHECKED);
  sc->cond_simple_symbol =           assign_internal_syntax(sc, "cond",        OP_COND_SIMPLE);
  sc->do_unchecked_symbol =          assign_internal_syntax(sc, "do",          OP_DO_UNCHECKED);
  sc->lambda_unchecked_symbol =      assign_internal_syntax(sc, "lambda",      OP_LAMBDA_UNCHECKED);
  sc->lambda_star_unchecked_symbol = assign_internal_syntax(sc, "lambda*",     OP_LAMBDA_STAR_UNCHECKED);
  sc->define_unchecked_symbol =      assign_internal_syntax(sc, "define",      OP_DEFINE_UNCHECKED);
  sc->define_funchecked_symbol =     assign_internal_syntax(sc, "define",      OP_DEFINE_FUNCHECKED);
  sc->define_star_unchecked_symbol = assign_internal_syntax(sc, "define*",     OP_DEFINE_STAR_UNCHECKED);
  sc->define_constant_unchecked_symbol = assign_internal_syntax(sc, "define-constant", OP_DEFINE_CONSTANT_UNCHECKED);
  sc->set_unchecked_symbol =         assign_internal_syntax(sc, "set!",        OP_SET_UNCHECKED);
  sc->set_symbol_c_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_C);
  sc->set_symbol_s_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_S);
  sc->set_symbol_q_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_Q);
  sc->set_symbol_opsq_symbol =       assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_opSq);
  sc->set_symbol_opssq_symbol =      assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_opSSq);
  sc->set_symbol_opsssq_symbol =     assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_opSSSq);
  sc->set_symbol_opcq_symbol =       assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_opCq);
  sc->set_symbol_p_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_P);
  sc->set_symbol_z_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_Z);
  sc->set_symbol_a_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_SYMBOL_A);
  sc->set_normal_symbol =            assign_internal_syntax(sc, "set!",        OP_SET_NORMAL);
  sc->set_pws_symbol =               assign_internal_syntax(sc, "set!",        OP_SET_PWS);
  sc->set_pair_symbol =              assign_internal_syntax(sc, "set!",        OP_SET_PAIR);
  sc->set_pair_p_symbol =            assign_internal_syntax(sc, "set!",        OP_SET_PAIR_P);
  sc->set_pair_z_symbol =            assign_internal_syntax(sc, "set!",        OP_SET_PAIR_Z);
  sc->set_pair_a_symbol =            assign_internal_syntax(sc, "set!",        OP_SET_PAIR_A);
  sc->set_pair_za_symbol =           assign_internal_syntax(sc, "set!",        OP_SET_PAIR_ZA);
  sc->set_let_s_symbol =             assign_internal_syntax(sc, "set!",        OP_SET_LET_S);
  sc->set_let_all_x_symbol =         assign_internal_syntax(sc, "set!",        OP_SET_LET_ALL_X);
  sc->set_pair_c_symbol =            assign_internal_syntax(sc, "set!",        OP_SET_PAIR_C);
  sc->set_pair_c_p_symbol =          assign_internal_syntax(sc, "set!",        OP_SET_PAIR_C_P);
  sc->increment_1_symbol =           assign_internal_syntax(sc, "set!",        OP_INCREMENT_1);
  sc->increment_ss_symbol =          assign_internal_syntax(sc, "set!",        OP_INCREMENT_SS);
  sc->increment_sss_symbol =         assign_internal_syntax(sc, "set!",        OP_INCREMENT_SSS);
  sc->increment_sz_symbol =          assign_internal_syntax(sc, "set!",        OP_INCREMENT_SZ);
  sc->increment_sa_symbol =          assign_internal_syntax(sc, "set!",        OP_INCREMENT_SA);
  sc->increment_saa_symbol =         assign_internal_syntax(sc, "set!",        OP_INCREMENT_SAA);
  sc->decrement_1_symbol =           assign_internal_syntax(sc, "set!",        OP_DECREMENT_1);
  sc->set_cons_symbol =              assign_internal_syntax(sc, "set!",        OP_SET_CONS);
  sc->and_unchecked_symbol =         assign_internal_syntax(sc, "and",         OP_AND_UNCHECKED);
  sc->and_p_symbol =                 assign_internal_syntax(sc, "and",         OP_AND_P);
  sc->and_p2_symbol =                assign_internal_syntax(sc, "and",         OP_AND_P2);
  sc->or_unchecked_symbol =          assign_internal_syntax(sc, "or",          OP_OR_UNCHECKED);
  sc->or_p_symbol =                  assign_internal_syntax(sc, "or",          OP_OR_P);
  sc->or_p2_symbol =                 assign_internal_syntax(sc, "or",          OP_OR_P2);
  sc->if_unchecked_symbol =          assign_internal_syntax(sc, "if",          OP_IF_UNCHECKED);

  sc->if_p_p_symbol =                assign_internal_syntax(sc, "if",          OP_IF_P_P);
  sc->if_p_p_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_P_P_P);
  sc->if_andp_p_symbol =             assign_internal_syntax(sc, "if",          OP_IF_ANDP_P);
  sc->if_andp_p_p_symbol =           assign_internal_syntax(sc, "if",          OP_IF_ANDP_P_P);
  sc->if_orp_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_ORP_P);
  sc->if_orp_p_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_ORP_P_P);
  sc->if_s_p_symbol =                assign_internal_syntax(sc, "if",          OP_IF_S_P);
  sc->if_s_p_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_S_P_P);
  sc->if_p_feed_symbol =             assign_internal_syntax(sc, "cond",        OP_IF_P_FEED);
  sc->cond_all_x_symbol =            assign_internal_syntax(sc, "cond",        OP_COND_ALL_X);
  sc->cond_all_x_2_symbol =          assign_internal_syntax(sc, "cond",        OP_COND_ALL_X_2);
  sc->cond_s_symbol =                assign_internal_syntax(sc, "cond",        OP_COND_S);
  sc->if_z_p_symbol =                assign_internal_syntax(sc, "if",          OP_IF_Z_P);
  sc->if_z_p_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_Z_P_P);
  sc->if_a_p_symbol =                assign_internal_syntax(sc, "if",          OP_IF_A_P);
  sc->if_a_p_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_A_P_P);
  sc->if_cc_p_symbol =               assign_internal_syntax(sc, "if",          OP_IF_CC_P);
  sc->if_cc_p_p_symbol =             assign_internal_syntax(sc, "if",          OP_IF_CC_P_P);
  sc->if_cs_p_symbol =               assign_internal_syntax(sc, "if",          OP_IF_CS_P);
  sc->if_cs_p_p_symbol =             assign_internal_syntax(sc, "if",          OP_IF_CS_P_P);
  sc->if_csq_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_CSQ_P);
  sc->if_csq_p_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_CSQ_P_P);
  sc->if_css_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_CSS_P);
  sc->if_css_p_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_CSS_P_P);
  sc->if_csc_p_symbol =              assign_internal_syntax(sc, "if",          OP_IF_CSC_P);
  sc->if_csc_p_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_CSC_P_P);
  sc->if_s_opcq_p_symbol =           assign_internal_syntax(sc, "if",          OP_IF_S_opCq_P);
  sc->if_s_opcq_p_p_symbol =         assign_internal_syntax(sc, "if",          OP_IF_S_opCq_P_P);
  sc->if_opssq_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_opSSq_P);
  sc->if_opssq_p_p_symbol =          assign_internal_syntax(sc, "if",          OP_IF_opSSq_P_P);
  sc->if_is_pair_p_symbol =          assign_internal_syntax(sc, "if",          OP_IF_IS_PAIR_P);
  sc->if_is_pair_p_p_symbol =        assign_internal_syntax(sc, "if",          OP_IF_IS_PAIR_P_P);
  sc->if_is_symbol_p_symbol =        assign_internal_syntax(sc, "if",          OP_IF_IS_SYMBOL_P);
  sc->if_is_symbol_p_p_symbol =      assign_internal_syntax(sc, "if",          OP_IF_IS_SYMBOL_P_P);
  sc->if_not_s_p_symbol =            assign_internal_syntax(sc, "if",          OP_IF_NOT_S_P);
  sc->if_not_s_p_p_symbol =          assign_internal_syntax(sc, "if",          OP_IF_NOT_S_P_P);
  sc->if_and2_p_symbol =             assign_internal_syntax(sc, "if",          OP_IF_AND2_P);
  sc->if_and2_p_p_symbol =           assign_internal_syntax(sc, "if",          OP_IF_AND2_P_P);
  sc->when_s_symbol =                assign_internal_syntax(sc, "when",        OP_WHEN_S);
  sc->unless_s_symbol =              assign_internal_syntax(sc, "unless",      OP_UNLESS_S);
  sc->when_unchecked_symbol =        assign_internal_syntax(sc, "when",        OP_WHEN_UNCHECKED);
  sc->unless_unchecked_symbol =      assign_internal_syntax(sc, "unless",      OP_UNLESS_UNCHECKED);
  sc->dotimes_p_symbol =             assign_internal_syntax(sc, "do",          OP_DOTIMES_P);
  sc->simple_do_symbol =             assign_internal_syntax(sc, "do",          OP_SIMPLE_DO);
  sc->simple_do_p_symbol =           assign_internal_syntax(sc, "do",          OP_SIMPLE_DO_P);
  sc->simple_do_a_symbol =           assign_internal_syntax(sc, "do",          OP_SIMPLE_DO_A);
  sc->simple_do_e_symbol =           assign_internal_syntax(sc, "do",          OP_SIMPLE_DO_E);
  sc->safe_dotimes_symbol =          assign_internal_syntax(sc, "do",          OP_SAFE_DOTIMES);
  sc->safe_do_symbol =               assign_internal_syntax(sc, "do",          OP_SAFE_DO);
  sc->dox_symbol =                   assign_internal_syntax(sc, "do",          OP_DOX);

  sc->documentation_symbol =  make_symbol(sc, "documentation");
  sc->signature_symbol =      make_symbol(sc, "signature");

#if WITH_IMMUTABLE_UNQUOTE
  /* 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_symbol =              make_symbol(sc, ",");
  set_immutable(sc->unquote_symbol);
#else
  sc->unquote_symbol =              make_symbol(sc, "unquote");
#endif

  sc->feed_to_symbol =              make_symbol(sc, "=>");
  sc->baffle_symbol =               make_symbol(sc, "(baffle)");
  sc->body_symbol =                 make_symbol(sc, "body");
  sc->error_symbol =                make_symbol(sc, "error");
  sc->read_error_symbol =           make_symbol(sc, "read-error");
  sc->string_read_error_symbol =    make_symbol(sc, "string-read-error");
  sc->syntax_error_symbol =         make_symbol(sc, "syntax-error");
  sc->wrong_type_arg_symbol =       make_symbol(sc, "wrong-type-arg");
  sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args");
  sc->format_error_symbol =         make_symbol(sc, "format-error");
  sc->out_of_range_symbol =         make_symbol(sc, "out-of-range");
  sc->no_catch_symbol =             make_symbol(sc, "no-catch");
  sc->io_error_symbol =             make_symbol(sc, "io-error");
  sc->invalid_escape_function_symbol = make_symbol(sc, "invalid-escape-function");
  sc->baffled_symbol =              make_symbol(sc, "baffled!");

  sc->key_allow_other_keys_symbol = s7_make_keyword(sc, "allow-other-keys");
  sc->key_rest_symbol =             s7_make_keyword(sc, "rest");
  sc->key_readable_symbol =         s7_make_keyword(sc, "readable");

  sc->value_symbol =                s7_make_symbol(sc, "value");
  sc->type_symbol =                 s7_make_symbol(sc, "type");

  sc->__func___symbol = make_symbol(sc, "__func__");
  s7_make_slot(sc, sc->nil, sc->else_symbol = make_symbol(sc, "else"), sc->else_object);
  sc->owlet = init_owlet(sc);

  sc->wrong_type_arg_info = permanent_list(sc, 6);
  set_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 = permanent_list(sc, 5);
  set_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 = permanent_list(sc, 5);
  set_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 = permanent_list(sc, 4);
  set_car(sc->simple_out_of_range_info, s7_make_permanent_string("~A argument, ~S, is out of range (~A)"));

  sc->too_many_arguments_string = s7_make_permanent_string("~A: too many arguments: ~A");
  sc->not_enough_arguments_string = s7_make_permanent_string("~A: not enough arguments: ~A");
  sc->division_by_zero_error_string = s7_make_permanent_string("~A: division by zero, ~S");
  sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero");

  if (!already_inited)
    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;
    }
  /* unset built-ins: T_STACK (can't happen), T_C_OBJECT (want actual name), T_INPUT|OUTPUT_PORT (want string|file|etc included) */

  sc->gc_off = false;

  #define defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
  #define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)

  /* we need the sc->IS_* symbols first for the procedure signature lists */
  sc->is_boolean_symbol = make_symbol(sc, "boolean?");
  pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T);

  sc->is_symbol_symbol =             defun("symbol?",		is_symbol,		1, 0, false);
  sc->is_gensym_symbol =             defun("gensym?",		is_gensym,		1, 0, false); 
  sc->is_keyword_symbol =            defun("keyword?",		is_keyword,		1, 0, false);
  sc->is_let_symbol =                defun("let?",		is_let,			1, 0, false);
  sc->is_openlet_symbol =            defun("openlet?",		is_openlet,		1, 0, false);
  sc->is_iterator_symbol =           defun("iterator?",	        is_iterator,		1, 0, false);
  sc->is_constant_symbol =           defun("constant?",	        is_constant,		1, 0, false);
  sc->is_macro_symbol =              defun("macro?",		is_macro,		1, 0, false);
  sc->is_c_pointer_symbol =          defun("c-pointer?",	is_c_pointer,		1, 0, false);
  sc->is_c_object_symbol =           defun("c-object?",	        is_c_object,		1, 0, false);
  sc->is_input_port_symbol =         defun("input-port?",	is_input_port,		1, 0, false);
  sc->is_output_port_symbol =        defun("output-port?",	is_output_port,		1, 0, false);
  sc->is_eof_object_symbol =         defun("eof-object?",	is_eof_object,		1, 0, false);
  sc->is_integer_symbol =            defun("integer?",		is_integer,		1, 0, false);
  sc->is_number_symbol =             defun("number?",		is_number,		1, 0, false);
  sc->is_real_symbol =               defun("real?",		is_real,		1, 0, false);
  sc->is_complex_symbol =            defun("complex?",		is_complex,		1, 0, false);
  sc->is_rational_symbol =           defun("rational?",	        is_rational,		1, 0, false);
  sc->is_random_state_symbol =       defun("random-state?",	is_random_state,	1, 0, false);
  sc->is_char_symbol =               defun("char?",		is_char,		1, 0, false);
  sc->is_string_symbol =             defun("string?",		is_string,		1, 0, false);
  sc->is_list_symbol =               defun("list?",		is_list,		1, 0, false);
  sc->is_pair_symbol =               defun("pair?",		is_pair,		1, 0, false);
  sc->is_vector_symbol =             defun("vector?",		is_vector,		1, 0, false);
  sc->is_float_vector_symbol =       defun("float-vector?",	is_float_vector,	1, 0, false);
  sc->is_int_vector_symbol =         defun("int-vector?",	is_int_vector,		1, 0, false);
  sc->is_byte_vector_symbol =        defun("byte-vector?",	is_byte_vector,		1, 0, false);
  sc->is_hash_table_symbol =         defun("hash-table?",	is_hash_table,		1, 0, false);
  sc->is_continuation_symbol =       defun("continuation?",	is_continuation,	1, 0, false);
  sc->is_procedure_symbol =          defun("procedure?",	is_procedure,		1, 0, false);
  sc->is_dilambda_symbol =           defun("dilambda?",	        is_dilambda,		1, 0, false);
  /* set above */                    defun("boolean?",		is_boolean,		1, 0, false);
  sc->is_float_symbol =              defun("float?",            is_float,               1, 0, false);
  sc->is_proper_list_symbol =        defun("proper-list?",      is_proper_list,         1, 0, false);
  sc->is_sequence_symbol =           defun("sequence?",	        is_sequence,		1, 0, false);
  sc->is_null_symbol =               defun("null?",		is_null,		1, 0, false);
  /* do we need 'syntax? */

  sc->is_integer_or_real_at_end_symbol = s7_define_function(sc, "integer:real?", g_is_integer_or_real_at_end, 1, 0, false, "internal signature helper");
  sc->is_integer_or_any_at_end_symbol =  s7_define_function(sc, "integer:any?",  g_is_integer_or_any_at_end,  1, 0, false, "internal signature helper");

  pl_p =   s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol);
  pl_tl =  s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */
  pl_bc =  s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol);
  pl_bn =  s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol);
  pl_sf =  s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, sc->is_procedure_symbol);
  pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T);
  pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
  pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol);

  pcl_i =  s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol);
  pcl_t =  s7_make_circular_signature(sc, 0, 1, sc->T);
  pcl_r =  s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol);
  pcl_f =  s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol);
  pcl_n =  s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol);
  pcl_s =  s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol);
  pcl_v =  s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol);
  pcl_c =  s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol);

  sc->values_symbol = make_symbol(sc, "values");

  sc->gensym_symbol =                defun("gensym",		gensym,			0, 1, false);
                                     defun("symbol-table",	symbol_table,		0, 0, false);
  sc->symbol_to_string_symbol =      defun("symbol->string",	symbol_to_string,	1, 0, false);
  sc->string_to_symbol_symbol =      defun("string->symbol",	string_to_symbol,	1, 0, false);
  sc->symbol_symbol =                defun("symbol",		symbol,			1, 0, true);
  sc->symbol_to_value_symbol =       defun("symbol->value",	symbol_to_value,	1, 1, false);
  sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false);
  s7_typed_dilambda(sc, "symbol-access", g_symbol_access, 1, 1, g_symbol_set_access,	2, 1, H_symbol_access, Q_symbol_access, NULL);
  sc->symbol_access_symbol = make_symbol(sc, "symbol-access");

  sc->make_keyword_symbol =          defun("make-keyword",	make_keyword,		1, 0, false);
  sc->symbol_to_keyword_symbol =     defun("symbol->keyword",	symbol_to_keyword,	1, 0, false);
  sc->keyword_to_symbol_symbol =     defun("keyword->symbol",	keyword_to_symbol,	1, 0, false);

  sc->outlet_symbol =                defun("outlet",		outlet,			1, 0, false);
  sc->rootlet_symbol =               defun("rootlet",		rootlet,		0, 0, false);
  sc->curlet_symbol =                defun("curlet",		curlet,			0, 0, false);
  sc->unlet_symbol =                 defun("unlet",		unlet,			0, 0, false);
  set_immutable(sc->unlet_symbol);
  /* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */
  sc->sublet_symbol =                defun("sublet",		sublet,			1, 0, true);
  sc->varlet_symbol =                unsafe_defun("varlet",	varlet,			1, 0, true);
  sc->cutlet_symbol =                unsafe_defun("cutlet",	cutlet,			1, 0, true);
  sc->inlet_symbol =                 defun("inlet",		inlet,			0, 0, true);
  sc->owlet_symbol =                 defun("owlet",		owlet,			0, 0, false);
  sc->coverlet_symbol =              defun("coverlet",		coverlet,		1, 0, false);
  sc->openlet_symbol =               defun("openlet",		openlet,		1, 0, false);
  sc->let_ref_symbol =               defun("let-ref",		let_ref,		2, 0, false);
  sc->let_set_symbol =               defun("let-set!",		let_set,		3, 0, false);
  sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback");
  sc->let_set_fallback_symbol = make_symbol(sc, "let-set!-fallback");

  sc->make_iterator_symbol =         defun("make-iterator",	make_iterator,		1, 1, false);
  sc->iterate_symbol =               defun("iterate",		iterate,		1, 0, false);
  sc->iterator_sequence_symbol =     defun("iterator-sequence", iterator_sequence,	1, 0, false);
  sc->iterator_is_at_end_symbol =    defun("iterator-at-end?",  iterator_is_at_end,	1, 0, false);

  sc->is_provided_symbol =           defun("provided?",	        is_provided,		1, 0, false);
  sc->provide_symbol =               defun("provide",		provide,		1, 0, false);
  sc->is_defined_symbol =            defun("defined?",		is_defined,		1, 2, false);

  sc->c_pointer_symbol =             defun("c-pointer",	        c_pointer,		1, 0, false);

  sc->port_line_number_symbol =      defun("port-line-number",  port_line_number,	0, 1, false);
  sc->port_filename_symbol =         defun("port-filename",	port_filename,		0, 1, false);
  sc->pair_line_number_symbol =      defun("pair-line-number",  pair_line_number,	1, 0, false);
  sc->pair_filename_symbol =         defun("pair-filename",     pair_filename,	        1, 0, false);

  sc->is_port_closed_symbol =        defun("port-closed?",	is_port_closed,		1, 0, false);

  sc->current_input_port_symbol =    defun("current-input-port", current_input_port,	0, 0, false);
  sc->current_output_port_symbol =   defun("current-output-port", current_output_port,  0, 0, false);
  sc->current_error_port_symbol =    defun("current-error-port", current_error_port,    0, 0, false);
                                     defun("set-current-error-port", set_current_error_port, 1, 0, false);
#if (!WITH_PURE_S7)
  sc->let_to_list_symbol =           defun("let->list",	         let_to_list,		1, 0, false);
                                     defun("set-current-input-port", set_current_input_port, 1, 0, false);
                                     defun("set-current-output-port", set_current_output_port, 1, 0, false);
  sc->is_char_ready_symbol =         defun("char-ready?",	is_char_ready,		0, 1, false); /* the least-used scheme function */
#endif

  sc->close_input_port_symbol =      defun("close-input-port",   close_input_port,	1, 0, false);
  sc->close_output_port_symbol =     defun("close-output-port",  close_output_port,	1, 0, false);
  sc->flush_output_port_symbol =     defun("flush-output-port",  flush_output_port,	0, 1, false);
  sc->open_input_file_symbol =       defun("open-input-file",    open_input_file,	1, 1, false);
  sc->open_output_file_symbol =      defun("open-output-file",   open_output_file,	1, 1, false);
  sc->open_input_string_symbol =     defun("open-input-string",  open_input_string,	1, 0, false);
                                     defun("open-output-string", open_output_string,	0, 0, false);
  sc->get_output_string_symbol =     defun("get-output-string",  get_output_string,	1, 1, false);

  sc->newline_symbol =               defun("newline",		newline,		0, 1, false);
  sc->write_symbol =                 defun("write",		write,			1, 1, false);
  sc->display_symbol =               defun("display",		display,		1, 1, false);
  sc->read_char_symbol =             defun("read-char",	        read_char,		0, 1, false);
  sc->peek_char_symbol =             defun("peek-char",	        peek_char,		0, 1, false);
  sc->write_char_symbol =            defun("write-char",	write_char,		1, 1, false);
  sc->write_string_symbol =          defun("write-string",	write_string,		1, 3, false);
  sc->read_byte_symbol =             defun("read-byte",	        read_byte,		0, 1, false);
  sc->write_byte_symbol =            defun("write-byte",	write_byte,		1, 1, false);
  sc->read_line_symbol =             defun("read-line",	        read_line,		0, 2, false);
  sc->read_string_symbol =           defun("read-string",	read_string,		1, 1, false);
  sc->read_symbol =                  unsafe_defun("read",	read,			0, 1, false);
  /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence 
   *   (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns
   *   expecting goto START, which would be nonsense if arg=c_call(read) -> c_call(arg).
   *   a safe procedure leaves its argument list alone and does not push anything on the stack
   */

  sc->call_with_input_string_symbol = unsafe_defun("call-with-input-string", call_with_input_string, 2, 0, false);
  sc->call_with_input_file_symbol =   unsafe_defun("call-with-input-file",   call_with_input_file,   2, 0, false);
  sc->with_input_from_string_symbol = unsafe_defun("with-input-from-string", with_input_from_string, 2, 0, false);
  sc->with_input_from_file_symbol =   unsafe_defun("with-input-from-file",   with_input_from_file,   2, 0, false);

  sc->call_with_output_string_symbol = unsafe_defun("call-with-output-string", call_with_output_string, 1, 0, false);
  sc->call_with_output_file_symbol =   unsafe_defun("call-with-output-file",   call_with_output_file,   2, 0, false);
  sc->with_output_to_string_symbol =   unsafe_defun("with-output-to-string",   with_output_to_string,   1, 0, false);
  sc->with_output_to_file_symbol =     unsafe_defun("with-output-to-file",     with_output_to_file,     2, 0, false);

#if WITH_SYSTEM_EXTRAS
  sc->is_directory_symbol =          defun("directory?",	is_directory,		1, 0, false);
  sc->file_exists_symbol =           defun("file-exists?",	file_exists,		1, 0, false);
  sc->delete_file_symbol =           defun("delete-file",	delete_file,		1, 0, false);
  sc->getenv_symbol =                defun("getenv",		getenv,			1, 0, false);
  sc->system_symbol =                defun("system",		system,			1, 1, false);
#ifndef _MSC_VER
  sc->directory_to_list_symbol =     defun("directory->list",   directory_to_list,	1, 0, false);
  sc->file_mtime_symbol =            defun("file-mtime",	file_mtime,		1, 0, false);
#endif
#endif

  sc->real_part_symbol =             defun("real-part",	        real_part,		1, 0, false);
  sc->imag_part_symbol =             defun("imag-part",	        imag_part,		1, 0, false);
  sc->numerator_symbol =             defun("numerator",	        numerator,		1, 0, false);
  sc->denominator_symbol =           defun("denominator",	denominator,		1, 0, false);
  sc->is_even_symbol =               defun("even?",		is_even,		1, 0, false);
  sc->is_odd_symbol =                defun("odd?",		is_odd,			1, 0, false);
  sc->is_zero_symbol =               defun("zero?",		is_zero,		1, 0, false);
  sc->is_positive_symbol =           defun("positive?",	        is_positive,		1, 0, false);
  sc->is_negative_symbol =           defun("negative?",	        is_negative,		1, 0, false);
  sc->is_infinite_symbol =           defun("infinite?",	        is_infinite,		1, 0, false);
  sc->is_nan_symbol =                defun("nan?",		is_nan,			1, 0, false);

#if (!WITH_GMP)
  sc->complex_symbol =               defun("complex",	        complex,	        2, 0, false);
  sc->magnitude_symbol =             defun("magnitude",	        magnitude,		1, 0, false);
  sc->angle_symbol =                 defun("angle",		angle,			1, 0, false);
  sc->rationalize_symbol =           defun("rationalize",	rationalize,		1, 1, false);
  sc->abs_symbol =                   defun("abs",		abs,			1, 0, false);
  sc->exp_symbol =                   defun("exp",		exp,			1, 0, false);
  sc->log_symbol =                   defun("log",		log,			1, 1, false);
  sc->sin_symbol =                   defun("sin",		sin,			1, 0, false);
  sc->cos_symbol =                   defun("cos",		cos,			1, 0, false);
  sc->tan_symbol =                   defun("tan",		tan,			1, 0, false);
  sc->asin_symbol =                  defun("asin",		asin,			1, 0, false);
  sc->acos_symbol =                  defun("acos",		acos,			1, 0, false);
  sc->atan_symbol =                  defun("atan",		atan,			1, 1, false);
  sc->sinh_symbol =                  defun("sinh",		sinh,			1, 0, false);
  sc->cosh_symbol =                  defun("cosh",		cosh,			1, 0, false);
  sc->tanh_symbol =                  defun("tanh",		tanh,			1, 0, false);
  sc->asinh_symbol =                 defun("asinh",		asinh,			1, 0, false);
  sc->acosh_symbol =                 defun("acosh",		acosh,			1, 0, false);
  sc->atanh_symbol =                 defun("atanh",		atanh,			1, 0, false);
  sc->sqrt_symbol =                  defun("sqrt",		sqrt,			1, 0, false);
  sc->expt_symbol =                  defun("expt",		expt,			2, 0, false);
  sc->floor_symbol =                 defun("floor",		floor,			1, 0, false);
  sc->ceiling_symbol =               defun("ceiling",		ceiling,		1, 0, false);
  sc->truncate_symbol =              defun("truncate",		truncate,		1, 0, false);
  sc->round_symbol =                 defun("round",		round,			1, 0, false);
  sc->lcm_symbol =                   defun("lcm",		lcm,			0, 0, true);
  sc->gcd_symbol =                   defun("gcd",		gcd,			0, 0, true);
  sc->add_symbol =                   defun("+",		        add,			0, 0, true);
  sc->subtract_symbol =              defun("-",		        subtract,		1, 0, true);
  sc->multiply_symbol =              defun("*",		        multiply,		0, 0, true);
  sc->divide_symbol =                defun("/",		        divide,			1, 0, true);
  sc->max_symbol =                   defun("max",		max,			1, 0, true);
  sc->min_symbol =                   defun("min",		min,			1, 0, true);
  sc->quotient_symbol =              defun("quotient",		quotient,		2, 0, false);
  sc->remainder_symbol =             defun("remainder",	        remainder,		2, 0, false);
  sc->modulo_symbol =                defun("modulo",		modulo,			2, 0, false);
  sc->eq_symbol =                    defun("=",		        equal,			2, 0, true);
  sc->lt_symbol =                    defun("<",		        less,			2, 0, true);
  sc->gt_symbol =                    defun(">",		        greater,		2, 0, true);
  sc->leq_symbol =                   defun("<=",		less_or_equal,		2, 0, true);
  sc->geq_symbol =                   defun(">=",		greater_or_equal,	2, 0, true);
  sc->logior_symbol =                defun("logior",		logior,			0, 0, true);
  sc->logxor_symbol =                defun("logxor",		logxor,			0, 0, true);
  sc->logand_symbol =                defun("logand",		logand,			0, 0, true);
  sc->lognot_symbol =                defun("lognot",		lognot,			1, 0, false);
  sc->ash_symbol =                   defun("ash",		ash,			2, 0, false);
  sc->random_state_symbol =          defun("random-state",      random_state,	        1, 1, false);
  sc->random_symbol =                defun("random",		random,			1, 1, false);
#if (!WITH_PURE_S7)
  sc->inexact_to_exact_symbol =      defun("inexact->exact",	inexact_to_exact,	1, 0, false);
  sc->exact_to_inexact_symbol =      defun("exact->inexact",	exact_to_inexact,	1, 0, false);
  sc->integer_length_symbol =        defun("integer-length",	integer_length,		1, 0, false);
  sc->make_polar_symbol =            defun("make-polar",	make_polar,		2, 0, false);
  sc->make_rectangular_symbol =      defun("make-rectangular",  complex,	        2, 0, false);
#endif
#endif /* !gmp */

  sc->logbit_symbol =                defun("logbit?",		logbit,			2, 0, false);
  sc->integer_decode_float_symbol =  defun("integer-decode-float", integer_decode_float, 1, 0, false);
#if (!WITH_PURE_S7)
  sc->is_exact_symbol =              defun("exact?",		is_exact,		1, 0, false);
  sc->is_inexact_symbol =            defun("inexact?",		is_inexact,		1, 0, false);
#endif
  sc->random_state_to_list_symbol =  defun("random-state->list", random_state_to_list, 0, 1, false);

  sc->number_to_string_symbol =      defun("number->string",	number_to_string,	1, 1, false);
  sc->string_to_number_symbol =      defun("string->number",	string_to_number,	1, 1, false);

  sc->char_upcase_symbol =           defun("char-upcase",	char_upcase,		1, 0, false);
  sc->char_downcase_symbol =         defun("char-downcase",	char_downcase,		1, 0, false);
  sc->char_to_integer_symbol =       defun("char->integer",	char_to_integer,	1, 0, false);
  sc->integer_to_char_symbol =       defun("integer->char",	integer_to_char,	1, 0, false);

  sc->is_char_upper_case_symbol =    defun("char-upper-case?",  is_char_upper_case,	1, 0, false);
  sc->is_char_lower_case_symbol =    defun("char-lower-case?",  is_char_lower_case,	1, 0, false);
  sc->is_char_alphabetic_symbol =    defun("char-alphabetic?",  is_char_alphabetic,	1, 0, false);
  sc->is_char_numeric_symbol =       defun("char-numeric?",	is_char_numeric,	1, 0, false);
  sc->is_char_whitespace_symbol =    defun("char-whitespace?",  is_char_whitespace,	1, 0, false);

  sc->char_eq_symbol =               defun("char=?",		chars_are_equal,	2, 0, true);
  sc->char_lt_symbol =               defun("char<?",		chars_are_less,		2, 0, true);
  sc->char_gt_symbol =               defun("char>?",		chars_are_greater,	2, 0, true);
  sc->char_leq_symbol =              defun("char<=?",		chars_are_leq,		2, 0, true);
  sc->char_geq_symbol =              defun("char>=?",		chars_are_geq,		2, 0, true);
  sc->char_position_symbol =         defun("char-position",	char_position,		2, 1, false);
  sc->string_position_symbol =       defun("string-position",	string_position,	2, 1, false);

  sc->make_string_symbol =           defun("make-string",	make_string,		1, 1, false);
  sc->string_ref_symbol =            defun("string-ref",	string_ref,		2, 0, false);
  sc->string_set_symbol =            defun("string-set!",	string_set,		3, 0, false);
  sc->string_eq_symbol =             defun("string=?",		strings_are_equal,	2, 0, true);
  sc->string_lt_symbol =             defun("string<?",		strings_are_less,	2, 0, true);
  sc->string_gt_symbol =             defun("string>?",		strings_are_greater,	2, 0, true);
  sc->string_leq_symbol =            defun("string<=?",	        strings_are_leq,	2, 0, true);
  sc->string_geq_symbol =            defun("string>=?",	        strings_are_geq,	2, 0, true);

#if (!WITH_PURE_S7)
  sc->char_ci_eq_symbol =            defun("char-ci=?",	        chars_are_ci_equal,	2, 0, true);
  sc->char_ci_lt_symbol =            defun("char-ci<?",	        chars_are_ci_less,	2, 0, true);
  sc->char_ci_gt_symbol =            defun("char-ci>?",	        chars_are_ci_greater,	2, 0, true);
  sc->char_ci_leq_symbol =           defun("char-ci<=?",	chars_are_ci_leq,	2, 0, true);
  sc->char_ci_geq_symbol =           defun("char-ci>=?",	chars_are_ci_geq,	2, 0, true);
  sc->string_ci_eq_symbol =          defun("string-ci=?",	strings_are_ci_equal,	2, 0, true);
  sc->string_ci_lt_symbol =          defun("string-ci<?",	strings_are_ci_less,	2, 0, true);
  sc->string_ci_gt_symbol =          defun("string-ci>?",	strings_are_ci_greater, 2, 0, true);
  sc->string_ci_leq_symbol =         defun("string-ci<=?",	strings_are_ci_leq,	2, 0, true);
  sc->string_ci_geq_symbol =         defun("string-ci>=?",	strings_are_ci_geq,	2, 0, true);
  sc->string_copy_symbol =           defun("string-copy",	string_copy,		1, 0, false);
  sc->string_fill_symbol =           defun("string-fill!",	string_fill,		2, 2, false);
  sc->list_to_string_symbol =        defun("list->string",	list_to_string,		1, 0, false);
  sc->string_length_symbol =         defun("string-length",	string_length,		1, 0, false);
  sc->string_to_list_symbol =        defun("string->list",	string_to_list,		1, 2, false);
#endif

  sc->string_downcase_symbol =       defun("string-downcase",	string_downcase,	1, 0, false);
  sc->string_upcase_symbol =         defun("string-upcase",	string_upcase,		1, 0, false);
  sc->string_append_symbol =         defun("string-append",	string_append,		0, 0, true);
  sc->substring_symbol =             defun("substring",	        substring,		2, 1, false);
  sc->string_symbol =                defun("string",		string,			0, 0, true);
  sc->object_to_string_symbol =      defun("object->string",	object_to_string,	1, 1, false);
  sc->format_symbol =                defun("format",		format,			1, 0, true);
  /* this was unsafe, but was that due to the (ill-advised) use of temp_call_2 in the arg lists? */
  sc->object_to_let_symbol =         defun("object->let",	object_to_let,	        1, 0, false);

  sc->cons_symbol =                  defun("cons",		cons,			2, 0, false);
  sc->car_symbol =                   defun("car",		car,			1, 0, false);
  sc->cdr_symbol =                   defun("cdr",		cdr,			1, 0, false);
  sc->set_car_symbol =               defun("set-car!",		set_car,		2, 0, false);
  sc->set_cdr_symbol =               unsafe_defun("set-cdr!",	set_cdr,		2, 0, false);
  sc->caar_symbol =                  defun("caar",		caar,			1, 0, false);
  sc->cadr_symbol =                  defun("cadr",		cadr,			1, 0, false);
  sc->cdar_symbol =                  defun("cdar",		cdar,			1, 0, false);
  sc->cddr_symbol =                  defun("cddr",		cddr,			1, 0, false);
  sc->caaar_symbol =                 defun("caaar",		caaar,			1, 0, false);
  sc->caadr_symbol =                 defun("caadr",		caadr,			1, 0, false);
  sc->cadar_symbol =                 defun("cadar",		cadar,			1, 0, false);
  sc->cdaar_symbol =                 defun("cdaar",		cdaar,			1, 0, false);
  sc->caddr_symbol =                 defun("caddr",		caddr,			1, 0, false);
  sc->cdddr_symbol =                 defun("cdddr",		cdddr,			1, 0, false);
  sc->cdadr_symbol =                 defun("cdadr",		cdadr,			1, 0, false);
  sc->cddar_symbol =                 defun("cddar",		cddar,			1, 0, false);
  sc->caaaar_symbol =                defun("caaaar",		caaaar,			1, 0, false);
  sc->caaadr_symbol =                defun("caaadr",		caaadr,			1, 0, false);
  sc->caadar_symbol =                defun("caadar",		caadar,			1, 0, false);
  sc->cadaar_symbol =                defun("cadaar",		cadaar,			1, 0, false);
  sc->caaddr_symbol =                defun("caaddr",		caaddr,			1, 0, false);
  sc->cadddr_symbol =                defun("cadddr",		cadddr,			1, 0, false);
  sc->cadadr_symbol =                defun("cadadr",		cadadr,			1, 0, false);
  sc->caddar_symbol =                defun("caddar",		caddar,			1, 0, false);
  sc->cdaaar_symbol =                defun("cdaaar",		cdaaar,			1, 0, false);
  sc->cdaadr_symbol =                defun("cdaadr",		cdaadr,			1, 0, false);
  sc->cdadar_symbol =                defun("cdadar",		cdadar,			1, 0, false);
  sc->cddaar_symbol =                defun("cddaar",		cddaar,			1, 0, false);
  sc->cdaddr_symbol =                defun("cdaddr",		cdaddr,			1, 0, false);
  sc->cddddr_symbol =                defun("cddddr",		cddddr,			1, 0, false);
  sc->cddadr_symbol =                defun("cddadr",		cddadr,			1, 0, false);
  sc->cdddar_symbol =                defun("cdddar",		cdddar,			1, 0, false);

  sc->assq_symbol =                  defun("assq",		assq,			2, 0, false);
  sc->assv_symbol =                  defun("assv",		assv,			2, 0, false);
  sc->assoc_symbol =                 unsafe_defun("assoc",	assoc,			2, 1, false); 
  set_is_possibly_safe(slot_value(global_slot(sc->assoc_symbol)));
  sc->memq_symbol =                  defun("memq",		memq,			2, 0, false);
  sc->memv_symbol =                  defun("memv",		memv,			2, 0, false);
  sc->member_symbol =                unsafe_defun("member",	member,			2, 1, false); 
  set_is_possibly_safe(slot_value(global_slot(sc->member_symbol)));

  sc->list_symbol =                  defun("list",		list,			0, 0, true);
  sc->list_ref_symbol =              defun("list-ref",		list_ref,		2, 0, true);
  sc->list_set_symbol =              defun("list-set!",	        list_set,		3, 0, true);
  sc->list_tail_symbol =             defun("list-tail",	        list_tail,		2, 0, false);
  sc->make_list_symbol =             defun("make-list",  	make_list,		1, 1, false);

  sc->length_symbol =                defun("length",		length,			1, 0, false);
  sc->copy_symbol =                  defun("copy",		copy,			1, 3, false);
  sc->fill_symbol =                  defun("fill!",		fill,			2, 2, false);
  sc->reverse_symbol =               defun("reverse",		reverse,		1, 0, false);
  sc->reverseb_symbol =              defun("reverse!",		reverse_in_place,	1, 0, false);
  sc->sort_symbol =                  unsafe_defun("sort!",	sort,			2, 0, false); 
  sc->append_symbol =                defun("append",		append,			0, 0, true);

#if (!WITH_PURE_S7)
  sc->vector_append_symbol =         defun("vector-append",	vector_append,		0, 0, true);
  sc->list_to_vector_symbol =        defun("list->vector",	list_to_vector,		1, 0, false);
  sc->vector_fill_symbol =           defun("vector-fill!",	vector_fill,		2, 2, false);
  sc->vector_length_symbol =         defun("vector-length",	vector_length,		1, 0, false);
  sc->vector_to_list_symbol =        defun("vector->list",	vector_to_list,		1, 2, false);
#else
  sc->vector_append_symbol = sc->append_symbol;
  sc->vector_fill_symbol = sc->fill_symbol;
  sc->string_fill_symbol = sc->fill_symbol;
#endif
  sc->vector_ref_symbol =            defun("vector-ref",	vector_ref,		2, 0, true);
  sc->vector_set_symbol =            defun("vector-set!",	vector_set,		3, 0, true);
  sc->vector_dimensions_symbol =     defun("vector-dimensions", vector_dimensions,	1, 0, false);
  sc->make_vector_symbol =           defun("make-vector",	make_vector,		1, 1, false);
  sc->make_shared_vector_symbol =    defun("make-shared-vector", make_shared_vector,	2, 1, false);
  sc->vector_symbol =                defun("vector",		vector,			0, 0, true);
  set_setter(sc->vector_symbol); /* like cons, I guess */
  sc->vector_function = slot_value(global_slot(sc->vector_symbol));

  sc->float_vector_symbol =          defun("float-vector",	float_vector,		0, 0, true);
  sc->make_float_vector_symbol =     defun("make-float-vector", make_float_vector,	1, 1, false);
  sc->float_vector_set_symbol =      defun("float-vector-set!", float_vector_set,	3, 0, true);
  sc->float_vector_ref_symbol =      defun("float-vector-ref",  float_vector_ref,	2, 0, true);

  sc->int_vector_symbol =            defun("int-vector",	int_vector,		0, 0, true);
  sc->make_int_vector_symbol =       defun("make-int-vector",	make_int_vector,	1, 1, false);
  sc->int_vector_set_symbol =        defun("int-vector-set!",	int_vector_set,		3, 0, true);
  sc->int_vector_ref_symbol =        defun("int-vector-ref",	int_vector_ref,		2, 0, true);

  sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false);
  sc->byte_vector_symbol =           defun("byte-vector",	byte_vector,		0, 0, true);
  sc->make_byte_vector_symbol =      defun("make-byte-vector",  make_byte_vector,	1, 1, false);

  sc->hash_table_symbol =            defun("hash-table",	hash_table,		0, 0, true);
  sc->hash_table_star_symbol =       defun("hash-table*",	hash_table_star,	0, 0, true);
  sc->make_hash_table_symbol =       defun("make-hash-table",	make_hash_table,	0, 2, false);
  sc->hash_table_ref_symbol =        defun("hash-table-ref",	hash_table_ref,		2, 0, true);
  sc->hash_table_set_symbol =        defun("hash-table-set!",	hash_table_set,		3, 0, false);
  sc->hash_table_entries_symbol =    defun("hash-table-entries", hash_table_entries,	1, 0, false);

                                     defun("cyclic-sequences",  cyclic_sequences,	1, 0, false);
  sc->call_cc_symbol =               unsafe_defun("call/cc",	call_cc,		1, 0, false);
  sc->call_with_current_continuation_symbol = unsafe_defun("call-with-current-continuation", call_cc, 1, 0, false);
  sc->call_with_exit_symbol =        unsafe_defun("call-with-exit", call_with_exit,	1, 0, false);

  sc->load_symbol =                  unsafe_defun("load",	load,			1, 1, false);
  sc->autoload_symbol =              unsafe_defun("autoload",	autoload,		2, 0, false);
  sc->eval_symbol =                  unsafe_defun("eval",	eval,			1, 1, false);
  sc->eval_string_symbol =           unsafe_defun("eval-string", eval_string,		1, 1, false);
  sc->apply_symbol =                 unsafe_defun("apply",	apply,			1, 0, true);
  sc->apply_function = slot_value(global_slot(sc->apply_symbol));
  set_type(sc->apply_function, type(sc->apply_function) | T_COPY_ARGS | T_PROCEDURE);
  /* (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_symbol =              unsafe_defun("for-each",	for_each,		2, 0, true); 
  sc->map_symbol =                   unsafe_defun("map",	map,			2, 0, true); 
  sc->dynamic_wind_symbol =          unsafe_defun("dynamic-wind", dynamic_wind,	3, 0, false);
  /* sc->values_symbol = */          unsafe_defun("values",	values,			0, 0, true);
  sc->catch_symbol =                 unsafe_defun("catch",	catch,			3, 0, false);
  sc->throw_symbol =                 unsafe_defun("throw",	throw,			1, 0, true);
  sc->error_symbol =                 unsafe_defun("error",	error,			0, 0, true);
  /* it's faster to leave error/throw unsafe than to set needs_copied_args and use s7_define_safe_function because copy_list overwhelms any other savings */
  sc->stacktrace_symbol =            defun("stacktrace",	stacktrace,		0, 5, false);

  { /* these are internal for quasiquote's use */
    s7_pointer sym;
    sym = unsafe_defun("{apply_values}", apply_values, 0, 0, true);
    set_immutable(sym);
    sc->qq_apply_values_function = slot_value(global_slot(sym));

    sym = unsafe_defun("{append}", append, 0, 0, true);
    set_immutable(sym);
    sc->qq_append_function = slot_value(global_slot(sym));

    sym = unsafe_defun("{list}", qq_list, 0, 0, true);
    set_immutable(sym);
    sc->qq_list_function = slot_value(global_slot(sym));
    set_type(sc->qq_list_function, T_C_RST_ARGS_FUNCTION | T_PROCEDURE | T_COPY_ARGS);
  }
  
  sc->procedure_documentation_symbol = defun("procedure-documentation", procedure_documentation, 1, 0, false);
  sc->procedure_signature_symbol =   defun("procedure-signature", procedure_signature,	1, 0, false);
  sc->help_symbol =                  defun("help",		help,			1, 0, false);
  sc->procedure_source_symbol =      defun("procedure-source",  procedure_source,	1, 0, false);
  sc->funclet_symbol =               defun("funclet",		funclet,		1, 0, false);
  sc->dilambda_symbol =              defun("dilambda",          dilambda,               2, 0, false);
  s7_typed_dilambda(sc, "procedure-setter", g_procedure_setter, 1, 0, g_procedure_set_setter, 2, 0, H_procedure_setter, Q_procedure_setter, NULL);

  sc->arity_symbol =                 defun("arity",		arity,			1, 0, false);
  sc->is_aritable_symbol =           defun("aritable?",	        is_aritable,		2, 0, false);

  sc->not_symbol =                   defun("not",		not,			1, 0, false);
  sc->is_eq_symbol =                 defun("eq?",		is_eq,			2, 0, false);
  sc->is_eqv_symbol =                defun("eqv?",		is_eqv,			2, 0, false);
  sc->is_equal_symbol =              defun("equal?",		is_equal,		2, 0, false);
  sc->is_morally_equal_symbol =      defun("morally-equal?",	is_morally_equal,	2, 0, false);

  sc->gc_symbol =                    defun("gc",		gc,			0, 1, false);
                                     defun("s7-version",	s7_version,		0, 0, false);
                                     defun("emergency-exit",	emergency_exit,		0, 1, false);
                                     defun("exit",		exit,			0, 1, false);
#if DEBUGGING
                              s7_define_function(sc, "abort",  g_abort,         0, 0, true, "drop into gdb I hope");
#endif

  sym = s7_define_function(sc, "(c-object set)", g_internal_object_set, 1, 0, true, "internal object setter redirection");
  sc->object_set_function = slot_value(global_slot(sym));

  s7_define_safe_function(sc, "tree-leaves", g_tree_leaves, 1, 0, false, "an experiment");


  /* -------- *features* -------- */
  sc->features_symbol = s7_define_variable(sc, "*features*", sc->nil);
  s7_symbol_set_access(sc, sc->features_symbol, s7_make_function(sc, "(set *features*)", g_features_set, 2, 0, false, "*features* accessor"));

  /* -------- *load-path* -------- */
  sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil, 
			   "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name");
  s7_symbol_set_access(sc, sc->load_path_symbol, s7_make_function(sc, "(set *load-path*)", g_load_path_set, 2, 0, false, "*load-path* accessor"));

#ifdef CLOAD_DIR
  sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR));
  s7_add_to_load_path(sc, (const char *)CLOAD_DIR);
#else
  sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", make_empty_string(sc, 0, 0));
#endif
  s7_symbol_set_access(sc, sc->cload_directory_symbol, s7_make_function(sc, "(set *cload-directory*)", g_cload_directory_set, 2, 0, false, 
                           "*cload-directory* accessor"));


  /* -------- *autoload* --------
   * this pretends to be a hash-table or environment, but it's actually a function
   */
  sc->autoloader_symbol = s7_define_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader);
  sym = s7_define_variable(sc, "*libraries*", sc->nil);
  sc->libraries = global_slot(sym);

  s7_autoload(sc, make_symbol(sc, "cload.scm"),       s7_make_permanent_string("cload.scm"));
  s7_autoload(sc, make_symbol(sc, "lint.scm"),        s7_make_permanent_string("lint.scm"));
  s7_autoload(sc, make_symbol(sc, "stuff.scm"),       s7_make_permanent_string("stuff.scm"));
  s7_autoload(sc, make_symbol(sc, "mockery.scm"),     s7_make_permanent_string("mockery.scm"));
  s7_autoload(sc, make_symbol(sc, "write.scm"),       s7_make_permanent_string("write.scm"));
  s7_autoload(sc, make_symbol(sc, "repl.scm"),        s7_make_permanent_string("repl.scm"));
  s7_autoload(sc, make_symbol(sc, "r7rs.scm"),        s7_make_permanent_string("r7rs.scm"));

  s7_autoload(sc, make_symbol(sc, "libc.scm"),        s7_make_permanent_string("libc.scm"));
  s7_autoload(sc, make_symbol(sc, "libm.scm"),        s7_make_permanent_string("libm.scm"));
  s7_autoload(sc, make_symbol(sc, "libdl.scm"),       s7_make_permanent_string("libdl.scm"));
  s7_autoload(sc, make_symbol(sc, "libgsl.scm"),      s7_make_permanent_string("libgsl.scm"));
  s7_autoload(sc, make_symbol(sc, "libgdbm.scm"),     s7_make_permanent_string("libgdbm.scm"));
  s7_autoload(sc, make_symbol(sc, "libutf8proc.scm"), s7_make_permanent_string("libutf8proc.scm"));

  sc->require_symbol = s7_define_macro(sc, "require", g_require, 0, 0, true, H_require);
  sc->stacktrace_defaults = s7_list(sc, 5, small_int(3), small_int(45), small_int(80), small_int(45), sc->T);


  /* -------- *#readers* -------- */
  sym = s7_define_variable(sc, "*#readers*", sc->nil);
  sc->sharp_readers = global_slot(sym);
  s7_symbol_set_access(sc, sym, s7_make_function(sc, "(set *#readers*)", g_sharp_readers_set, 2, 0, false, "*#readers* accessor"));

  /* sigh... I don't like these! */
  s7_define_constant(sc, "nan.0", real_NaN);
  s7_define_constant(sc, "-nan.0", real_NaN);
  s7_define_constant(sc, "inf.0", real_infinity);
  s7_define_constant(sc, "-inf.0", real_minus_infinity);

  /* *features* */
  s7_provide(sc, "s7");
  s7_provide(sc, "s7-" S7_VERSION);
  s7_provide(sc, "ratio");

#if WITH_PURE_S7
  s7_provide(sc, "pure-s7");
#endif
#if WITH_EXTRA_EXPONENT_MARKERS
  s7_provide(sc, "dfls-exponents");
#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 WITH_PROFILE
  s7_provide(sc, "profiling");
#endif
#if HAVE_COMPLEX_NUMBERS
  s7_provide(sc, "complex-numbers");
#endif
#if WITH_C_LOADER
  s7_provide(sc, "dlopen");
#endif
#if (!DISABLE_AUTOLOAD)
  s7_provide(sc, "autoload");
#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
#ifdef __SUNPRO_C
  s7_provide(sc, "sunpro_c");
#endif


  sc->vector_set_function = slot_value(global_slot(sc->vector_set_symbol));
  set_setter(sc->vector_set_symbol);
  /* not float-vector-set! here */

  sc->list_set_function = slot_value(global_slot(sc->list_set_symbol));
  set_setter(sc->list_set_symbol);

  sc->hash_table_set_function = slot_value(global_slot(sc->hash_table_set_symbol));
  set_setter(sc->hash_table_set_symbol);

  sc->let_set_function = slot_value(global_slot(sc->let_set_symbol));
  set_setter(sc->let_set_symbol);

  set_setter(sc->cons_symbol); /* (this blocks an over-eager do loop optimization -- see do-test-15 in s7test) */

  sc->string_set_function = slot_value(global_slot(sc->string_set_symbol));
  set_setter(sc->string_set_symbol);

  set_setter(sc->set_car_symbol);
  set_setter(sc->set_cdr_symbol);

#if (!WITH_PURE_S7)
  set_setter(s7_make_symbol(sc, "set-current-input-port"));
  set_setter(s7_make_symbol(sc, "set-current-output-port"));
  s7_function_set_setter(sc, "current-input-port",  "set-current-input-port");
  s7_function_set_setter(sc, "current-output-port", "set-current-output-port");
#endif

  set_setter(s7_make_symbol(sc, "set-current-error-port"));
  s7_function_set_setter(sc, "current-error-port",  "set-current-error-port");
  /* despite the similar names, current-error-port is different from the other two, and a setter is needed
   *    in scheme because error and warn send output to it by default.  It is not a "dynamic variable" unlike
   *    the other two.  In the input/output cases, setting the port can only cause confusion.
   *    current-error-port should simply be an s7 variable with a name like *error-port* and an accessor to
   *    ensure its new value, if any, is an output 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, "float-vector-ref", "float-vector-set!");
  s7_function_set_setter(sc, "int-vector-ref",   "int-vector-set!");
  s7_function_set_setter(sc, "list-ref",         "list-set!");
  s7_function_set_setter(sc, "let-ref",          "let-set!");
  s7_function_set_setter(sc, "string-ref",       "string-set!");
  c_function_set_setter(slot_value(global_slot(sc->outlet_symbol)), s7_make_function(sc, "(set! outlet)", g_set_outlet, 2, 0, false, "outlet setter"));
  c_function_set_setter(slot_value(global_slot(sc->port_line_number_symbol)), s7_make_function(sc, "(set! port-line-number)", g_set_port_line_number, 1, 1, false, "port line setter"));

  {
    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_int32_max = (top == 8) ? S7_LONG_MAX : S7_SHORT_MAX;
    s7_int32_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_unchecked((top == 8) ? s7_int_max : ((top == 4) ? S7_LONG_MAX : S7_SHORT_MAX)));
    s7_define_constant(sc, "most-negative-fixnum", make_permanent_integer_unchecked((top == 8) ? s7_int_min : ((top == 4) ? S7_LONG_MIN : S7_SHORT_MIN)));

    if (top == 4) sc->default_rationalize_error = 1.0e-6;
    s7_define_constant(sc, "pi", real_pi);
    sc->pi_symbol = s7_make_symbol(sc, "pi");

    {
      s7_pointer p;
      new_cell(sc, p, T_RANDOM_STATE);
#if WITH_GMP
      {
	mpz_t seed;
	mpz_init_set_ui(seed, (unsigned int)time(NULL));
	gmp_randinit_default(random_gmp_state(p));
	gmp_randseed(random_gmp_state(p), seed);
	mpz_clear(seed);
      }
#else
      random_seed(p) = (unsigned long long int)time(NULL);
      random_carry(p) = 1675393560;
#endif
      sc->default_rng = p;
    }
    
    for (i = 0; i < 10; i++) sc->singletons[(unsigned char)'0' + i] = small_int(i);
    sc->singletons[(unsigned char)'+'] = sc->add_symbol;
    sc->singletons[(unsigned char)'-'] = sc->subtract_symbol;
    sc->singletons[(unsigned char)'*'] = sc->multiply_symbol;
    sc->singletons[(unsigned char)'/'] = sc->divide_symbol;
    sc->singletons[(unsigned char)'<'] = sc->lt_symbol;
    sc->singletons[(unsigned char)'>'] = sc->gt_symbol;
    sc->singletons[(unsigned char)'='] = sc->eq_symbol;
  }

#if WITH_GMP
  s7_gmp_init(sc);
#endif

  init_choosers(sc);

  s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote);

#if (!WITH_PURE_S7)
  s7_eval_c_string(sc, "(define-macro (defmacro name args . body) `(define-macro ,(cons name args) ,@body))");
  s7_eval_c_string(sc, "(define-macro (defmacro* name args . body) `(define-macro* ,(cons name args) ,@body))");

  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)                            \n\
                          `((lambda ,vars ,@body) ,expression))");

  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))))");
#endif

  s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses)                                             \n\
                          (call-with-exit                                                                     \n\
                            (lambda (return)                                                                  \n\
                              (for-each                                                                       \n\
                                (lambda (clause)                                                              \n\
	                          (let ((val (eval (car clause))))                                            \n\
                                    (if val                                                                   \n\
                                        (return (if (null? (cdr clause))                                      \n\
                                                    val                                                       \n\
	                                            (if (null? (cddr clause))                                 \n\
                                                        (cadr clause)                                         \n\
                                                        (apply values (map quote (cdr clause)))))))))         \n\
                                clauses)                                                                      \n\
                              (values))))");

  s7_eval_c_string(sc, "(define make-hook                                                                     \n\
                          (let ((signature '(procedure?))                                                     \n\
                                (documentation \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\
                            (lambda args                                                                      \n\
                              (let ((body ()))                                                                \n\
                                (apply lambda* args                                                           \n\
                                  '(let ((result #<unspecified>))                                             \n\
                                     (let ((hook (curlet)))                                                   \n\
                                       (for-each (lambda (hook-function) (hook-function hook)) body)          \n\
                                       result))                                                               \n\
                                  ())))))");

  s7_eval_c_string(sc, "(define hook-functions                                                                \n\
                          (let ((signature '(list? procedure?))                                               \n\
                                (documentation \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\
                            (dilambda                                                                         \n\
                              (lambda (hook)                                                                  \n\
                                ((funclet 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! ((funclet hook) 'body) lst)                                         \n\
                                    (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))");

  s7_eval_c_string(sc, "(define-macro (let-temporarily vars . body)                                           \n\
                          `(with-let (#_inlet :orig (#_curlet)                                                \n\
                        		      :saved (#_list ,@(map car vars))                                \n\
                        		      :new (#_list ,@(map cadr vars)))                                \n\
                             (when (memq #<undefined> saved)                                                  \n\
                               (error 'unbound-variable \"let-temporarily: ~A is unbound\"                    \n\
	                              (car (list-ref ',vars (- (length saved) (length (memq #<undefined> saved))))))) \n\
                             (dynamic-wind                                                                    \n\
                               (lambda () #f)                                                                 \n\
                               (lambda ()                                                                     \n\
                        	 ,@(map (let ((ctr -1))                                                       \n\
                        	          (lambda (v)                                                         \n\
                        		    (if (symbol? (car v))                                             \n\
                        			`(set! (orig ',(car v)) (list-ref new ,(set! ctr (+ ctr 1)))) \n\
                        			`(set! (with-let orig ,(car v)) (list-ref new ,(set! ctr (+ ctr 1))))))) \n\
                        		  vars)                                                               \n\
                                 ,(and (pair? body) `(with-let orig ,@body)))                                 \n\
                               (lambda ()                                                                     \n\
                        	 ,@(map (let ((ctr -1))                                                       \n\
                        	          (lambda (v)                                                         \n\
                        		    (if (symbol? (car v))                                             \n\
                        			`(set! (orig ',(car v)) (list-ref saved ,(set! ctr (+ ctr 1)))) \n\
                        			`(set! (with-let orig ,(car v)) (list-ref saved ,(set! ctr (+ ctr 1))))))) \n\
                        		vars)))))");


  /* -------- *unbound-variable-hook* -------- */
  sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)");
  s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", sc->unbound_variable_hook, 
					"*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable).");

  /* -------- *missing-close-paren-hook* -------- */
  sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)");
  s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", sc->missing_close_paren_hook, 
					"*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing");

  /* -------- *load-hook* -------- */
  sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)");
  s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook, 
					"*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)");

  /* -------- *error-hook* -------- */
  sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook, 
					"*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data).");

  /* -------- *read-error-hook* -------- */
  sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
  s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook, 
					"*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data).");

  s7_define_constant(sc, "*s7*",
    s7_openlet(sc, s7_inlet(sc,
       s7_list(sc, 2,
	       s7_cons(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "s7-let-ref", g_s7_let_ref_fallback, 2, 0, false, "*s7* reader")),
	       s7_cons(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "s7-let-set", g_s7_let_set_fallback, 3, 0, false, "*s7* writer"))))));


#if (!DISABLE_DEPRECATED)
  s7_eval_c_string(sc, "(begin                                         \n\
                          (define global-environment         rootlet)  \n\
                          (define current-environment        curlet)   \n\
                          (define make-procedure-with-setter dilambda) \n\
                          (define procedure-with-setter?     dilambda?)\n\
                          (define make-random-state          random-state) \n\
                          (define make-complex               complex) \n\
                          (define ->byte-vector              string->byte-vector) \n\
                          (define (procedure-arity obj) (let ((c (arity obj))) (list (car c) (- (cdr c) (car c)) (> (cdr c) 100000)))))");
#endif

  /* fprintf(stderr, "size: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), OP_MAX_DEFINED, OPT_MAX_DEFINED); */
  /* 64 bit machine: size: 48 [size 72 if gmp], op: 321, opt: 400 */

  if (sizeof(void *) > sizeof(s7_int))
    fprintf(stderr, "s7_int is too small: it has %d bytes, but void* has %d\n", (int)sizeof(s7_int), (int)sizeof(void *));

  save_unlet(sc);
  init_s7_let(sc);          /* set up *s7* */
  already_inited = true;
  return(sc);
}


/* -------------------------------- repl -------------------------------- */

#ifndef USE_SND
  #define USE_SND 0
#endif
#ifndef WITH_MAIN
  #define WITH_MAIN 0
#endif

#if (WITH_MAIN && (!USE_SND))

int main(int argc, char **argv)
{
  s7_scheme *sc;

  sc = s7_init();
  if (argc == 2)
    {
      fprintf(stderr, "load %s\n", argv[1]);
      s7_load(sc, argv[1]);
    }
  else 
    {
#ifndef _MSC_VER
      s7_load(sc, "repl.scm");              /* this is libc dependent */
      s7_eval_c_string(sc, "((*repl* 'run))");
#else
      while (1)                             /* a minimal repl -- taken from s7.html */
	{
	  char buffer[512];
	  char response[1024];
	  fprintf(stdout, "\n> ");
	  fgets(buffer, 512, stdin);
	  if ((buffer[0] != '\n') || (strlen(buffer) > 1))
	    { 
	      sprintf(response, "(write %s)", buffer);
	      s7_eval_c_string(sc, response); 
	    }
	}
#endif
    }
  return(0);
}

/* in Linux:  gcc s7.c -o repl -DWITH_MAIN -I. -g3 -ldl -lm -Wl,-export-dynamic
 * in *BSD:   gcc s7.c -o repl -DWITH_MAIN -I. -g3 -lm -Wl,-export-dynamic
 * in OSX:    gcc s7.c -o repl -DWITH_MAIN -I. -g3 -lm
 *   (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux)
 */
#endif


/* --------------------------------------------------------------------
 *
 *           12  |  13  |  14  |  15  | 16.0  16.7  16.8
 *                                           
 * s7test   1721 | 1358 |  995 | 1194 | 1122  1928
 * index    44.3 | 3291 | 1725 | 1276 | 1156  1166
 * teq           |      |      | 6612 | 2380  2382
 * tauto     265 |   89 |  9   |  8.4 | 2638  2688
 * tcopy         |      |      | 13.6 | 3204  3133
 * bench    42.7 | 8752 | 4220 | 3506 | 3230  3220
 * tform         |      |      | 6816 | 3627  3709
 * tmap          |      |      |  9.3 | 4176  4172
 * titer         |      |      | 7503 | 5218  5235
 * thash         |      |      | 50.7 | 8491  8496
 * lg            |      |      |      |       180.
 *               |      |      |      |       
 * tgen          |   71 | 70.6 | 38.0 | 12.0  11.8
 * tall       90 |   43 | 14.5 | 12.7 | 15.0  14.9
 * calls     359 |  275 | 54   | 34.7 | 37.1  39.1
 * 
 * --------------------------------------------------------------------
 *
 * new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive
 *
 * with-set setter (op_set_with_let) still sometimes conses up the new expression
 * if with_history, each func could keep a (circular) history of calls(args/results/stack), vars via symbol-access?
 *
 * Snd:
 * dac loop [need start/end of loop in dac_info, reader goes to start when end reached (requires rebuffering)
 *   looper does not stop/restart -- just keep going]
 *   play_selection_1 could put ends somewhere, set ends to NO_END_SPECIFIED, dac_loop_sample can
 *   use begs/other-ends to get loop points, so free_dac_info does not need to restart the loop(?)
 *   If start/end selection changed while playing, are these loop points updated?
 *
 * gtk gl: I can't see how to switch gl in and out as in the motif version -- I guess I need both gl_area and drawing_area
 * the old mus-audio-* code needs to use play or something, especially bess*
 * musglyphs gtk version is broken (probably cairo_t confusion)
 * snd+gtk+script->eps fails??  Also why not make a graph in the no-gui case? t415.scm.
 * remove as many edpos args as possible, and num+bool->num
 * snd namespaces: clm2xen, dac, edits, fft, gxcolormaps, mix, region, snd
 *   for snd-mix, tie-ins are in place
 */